├── .ghci ├── .ghci.repl ├── .gitignore ├── .hlint.yaml ├── .stylish-haskell.yaml ├── Brewfile ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── cabal.project ├── data ├── .gitignore ├── ephemerides.sql ├── factions.sql └── ship-names.txt ├── fonts └── DejaVuSans.ttf ├── hie.yaml ├── notes ├── ✅ Todo.md ├── 🏁 Fixed time interval physics integration.md └── 📈 setLabel performance.md ├── script ├── ghci-flags ├── ghci-flags-dependencies └── repl ├── src ├── Control │ ├── Carrier │ │ ├── Database │ │ │ └── SQLite.hs │ │ ├── Error │ │ │ └── IO.hs │ │ ├── Finally.hs │ │ ├── Reader │ │ │ └── Relation.hs │ │ ├── State │ │ │ ├── IORef.hs │ │ │ ├── ST │ │ │ │ └── Strict.hs │ │ │ └── STM │ │ │ │ └── TVar.hs │ │ ├── Thread │ │ │ └── IO.hs │ │ └── Trace │ │ │ └── Lift.hs │ ├── Concurrent │ │ └── Lift.hs │ ├── Effect │ │ ├── Database.hs │ │ ├── Finally.hs │ │ ├── Lens │ │ │ └── Exts.hs │ │ └── Thread.hs │ ├── Exception │ │ └── Lift.hs │ └── Monad │ │ └── IO │ │ └── Class │ │ └── Lift.hs ├── Data │ ├── Flag.hs │ └── Functor │ │ ├── C.hs │ │ ├── I.hs │ │ ├── Interval.hs │ │ └── K.hs ├── Foreign │ ├── C │ │ └── String │ │ │ └── Lift.hs │ └── Marshal │ │ ├── Alloc │ │ └── Lift.hs │ │ ├── Array │ │ └── Lift.hs │ │ └── Utils │ │ └── Lift.hs ├── GL.hs ├── GL │ ├── Array.hs │ ├── Buffer.hs │ ├── Carrier │ │ ├── Bind.hs │ │ └── Check │ │ │ ├── IO.hs │ │ │ └── Identity.hs │ ├── Effect │ │ ├── Bind.hs │ │ └── Check.hs │ ├── Enum.hs │ ├── Error.hs │ ├── Framebuffer.hs │ ├── Object.hs │ ├── Primitive.hs │ ├── Program.hs │ ├── Shader.hs │ ├── Shader │ │ ├── DSL.hs │ │ └── Vars.hs │ ├── Texture.hs │ ├── TextureUnit.hs │ ├── Type.hs │ ├── Uniform.hs │ └── Viewport.hs ├── Geometry │ ├── Circle.hs │ ├── Transform.hs │ └── Triangle.hs ├── Linear │ └── Exts.hs ├── Starlight │ ├── AI.hs │ ├── Actor.hs │ ├── Body.hs │ ├── CLI.hs │ ├── Character.hs │ ├── Controls.hs │ ├── Draw.hs │ ├── Draw │ │ ├── Body.hs │ │ ├── Radar.hs │ │ ├── Ship.hs │ │ ├── Starfield.hs │ │ └── Weapon │ │ │ └── Laser.hs │ ├── Faction.hs │ ├── Game.hs │ ├── Identifier.hs │ ├── Input.hs │ ├── Integration.hs │ ├── Main.hs │ ├── Physics.hs │ ├── Radar.hs │ ├── Ship.hs │ ├── Sol.hs │ ├── System.hs │ ├── Time.hs │ ├── UI.hs │ ├── View.hs │ └── Weapon │ │ └── Laser.hs ├── Stochastic │ ├── Distribution.hs │ ├── Histogram.hs │ ├── PDF.hs │ └── Sample │ │ ├── Markov.hs │ │ ├── Metropolis.hs │ │ ├── Rejection.hs │ │ └── Slice.hs ├── UI │ ├── Colour.hs │ ├── Context.hs │ ├── Drawable.hs │ ├── Glyph.hs │ ├── Graph.hs │ ├── Graph │ │ ├── Lines.hs │ │ ├── Points.hs │ │ └── Vertex.hs │ ├── Label.hs │ ├── Label │ │ ├── Glyph.hs │ │ └── Text.hs │ ├── Path.hs │ ├── Typeface.hs │ └── Window.hs ├── Unit.hs └── Unit │ ├── Algebra.hs │ ├── Angle.hs │ ├── Count.hs │ ├── Density │ └── Number │ │ └── Areal.hs │ ├── Force.hs │ ├── Length.hs │ ├── Mass.hs │ ├── Multiple.hs │ ├── Power.hs │ └── Time.hs └── starlight.cabal /.ghci: -------------------------------------------------------------------------------- 1 | -- Disable the ghci sandbox so we can run the SDL thread 2 | :set -fno-ghci-sandbox 3 | 4 | -- Disable breaking on error since it hangs on uncaught exceptions when the sandbox is disabled: https://gitlab.haskell.org/ghc/ghc/issues/17743 5 | :set -fno-break-on-error 6 | -------------------------------------------------------------------------------- /.ghci.repl: -------------------------------------------------------------------------------- 1 | -- GHCI settings for starlight, collected by running cabal repl -v and checking out the flags cabal passes to ghc. 2 | -- These live here instead of script/repl for ease of commenting. 3 | -- These live here instead of .ghci so cabal repl remains unaffected. 4 | -- These live here instead of script/ghci-flags so ghcide remains unaffected. 5 | 6 | -- Basic verbosity 7 | :set -v1 8 | 9 | -- Compile to object code, write interface files. 10 | :set -fwrite-interface -fobject-code 11 | 12 | -- Disable breaking on error since it hangs on uncaught exceptions when the sandbox is disabled: https://gitlab.haskell.org/ghc/ghc/issues/17743 13 | -- This was already disabled in .ghci, but it turns out that if your user-wide .ghci file sets -fbreak-on-error, it gets overriden, so we override it back again here. 14 | :set -fno-break-on-error 15 | 16 | -- Bonus: silence “add these modules to your .cabal file” warnings for files we :load 17 | :set -Wno-missing-home-modules 18 | 19 | -- Warnings for code written in the repl 20 | :seti -Weverything 21 | :seti -Wno-all-missed-specialisations 22 | :seti -Wno-implicit-prelude 23 | :seti -Wno-missed-specialisations 24 | :seti -Wno-missing-import-lists 25 | :seti -Wno-missing-local-signatures 26 | :seti -Wno-monomorphism-restriction 27 | :seti -Wno-name-shadowing 28 | :seti -Wno-safe 29 | :seti -Wno-unsafe 30 | :seti -Wno-missing-deriving-strategies 31 | 32 | -- We have this one on in the project but not in the REPL to reduce noise 33 | :seti -Wno-type-defaults 34 | 35 | :load Main 36 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.png 2 | dist-newstyle/ 3 | Brewfile.lock.json 4 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - fixity: "infixl 7 .*." 2 | - fixity: "infixl 7 ./." 3 | - fixity: "infixl 7 :*:" 4 | - fixity: "infixl 7 :/:" 5 | - fixity: "infixr 2 ~>" 6 | - fixity: "infixr 2 <~>" 7 | - fixity: "infixr 2 <--" 8 | - fixity: "infixr 2 -->" 9 | - fixity: "infixr 2 <->" 10 | 11 | - fixity: "infixl 6 .+." 12 | - fixity: "infixl 6 .-." 13 | - fixity: "infixl 7 .*." 14 | - fixity: "infixl 7 ^*." 15 | - fixity: "infixl 7 .*^" 16 | - fixity: "infixl 7 ./." 17 | - fixity: "infixl 7 ^/." 18 | - fixity: "infixl 7 ./^" 19 | - fixity: "infixl 7 :*:" 20 | - fixity: "infixl 7 :/:" 21 | 22 | - warn: { lhs: to f . to g, rhs: to (g . f), name: combine to } 23 | 24 | - ignore: {name: Reduce duplication} 25 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - simple_align: 3 | cases: true 4 | top_level_patterns: true 5 | records: true 6 | 7 | - imports: 8 | align: file 9 | list_align: after_alias 10 | pad_module_names: false 11 | long_list_align: new_line_multiline 12 | empty_list_align: inherit 13 | list_padding: 2 14 | separate_lists: false 15 | space_surround: false 16 | 17 | - language_pragmas: 18 | style: vertical 19 | align: false 20 | remove_redundant: true 21 | 22 | - tabs: 23 | spaces: 2 24 | 25 | - trailing_whitespace: {} 26 | 27 | columns: 120 28 | 29 | newline: native 30 | 31 | language_extensions: 32 | - FlexibleContexts 33 | - MultiParamTypeClasses 34 | -------------------------------------------------------------------------------- /Brewfile: -------------------------------------------------------------------------------- 1 | brew "sdl2" 2 | brew "sqlite3" 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Rob Rix (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Rob Rix nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # `starlight` 2 | 3 | screenshot showing player’s ship in quite a close approach to Mercury 4 | 5 | 6 | ## Development 7 | 8 | Development currently assumes a Mac with `ghc` 8.8 & `cabal` 3.0. You can install them directly, or use [`ghcup`](https://www.haskell.org/ghcup/). 9 | 10 | Initial setup: 11 | 12 | ```bash 13 | brew bundle # for sdl2 & sqlite3 14 | cat data/ephemerides.sql | sqlite3 data/data.db # to populate the solar system db with planets 15 | cat data/factions.sql | sqlite3 data/data.db # to populate the solar system db with factions 16 | cabal build # to set up dist-newstyle with the ghc package db 17 | ``` 18 | 19 | Run `script/repl` to load the project (both library & executable) into the REPL. In the REPL, `:main` will launch the game. Use `:main --profile` to enable profiling (timings for various parts of the game, shown on exit). 20 | 21 | Alternatively, `cabal run starlight` will launch the game. Use `cabal run starlight -- --profile` to enable profiling. 22 | 23 | 24 | ## Controls 25 | 26 | Controls are currently hard-coded; I intend to eventually make them configurable. 27 | 28 | - Up arrow: forward thrust 29 | - Left/right arrows: turn left/right 30 | - Down arrow: turn to face opposite direction from current heading (relative to target’s heading, if any, or absolute otherwise; helps you match speed and heading to target’s) 31 | - +/-: increase/decrease throttle (controls rate of thrust) 32 | - tab/shift tab: switch to the next/prev target 33 | - escape: clear the target 34 | - space: fire weapons in the direction you’re facing 35 | - t: turn to face the selected target (if any) 36 | - f: face in the direction the ship is moving 37 | - b: brake/match speed to target 38 | - j: jump to the target (if any) 39 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | ( main 3 | ) where 4 | 5 | import Starlight.Main (main) 6 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | source-repository-package 4 | type: git 5 | location: https://github.com/fused-effects/fused-effects.git 6 | tag: 40cf33031576f179c9e4ba3f9e8a33ba642fcc91 7 | 8 | source-repository-package 9 | type: git 10 | location: https://github.com/fused-effects/fused-effects-profile.git 11 | tag: b23b07efbabd82d20d316f409bacd06110a72192 12 | 13 | source-repository-package 14 | type: git 15 | location: https://github.com/fused-effects/fused-effects-random.git 16 | tag: 175b1d1a296ed2608bfd3fbdcb9200987b708700 17 | 18 | source-repository-package 19 | type: git 20 | location: https://github.com/robrix/haskell-opentype.git 21 | tag: a1b6967d895530ea691bd83084a2d85c588a6213 22 | -------------------------------------------------------------------------------- /data/.gitignore: -------------------------------------------------------------------------------- 1 | data.db 2 | -------------------------------------------------------------------------------- /data/factions.sql: -------------------------------------------------------------------------------- 1 | drop table if exists factions; 2 | 3 | -- schema for factions & their relationships 4 | create table factions 5 | ( name text not null 6 | , colour integer not null 7 | ); 8 | 9 | insert into factions values 10 | ( "venusian" 11 | , 0xffff80ff 12 | ); 13 | 14 | insert into factions values 15 | ( "terran" 16 | , 0x0000ffff 17 | ); 18 | 19 | insert into factions values 20 | ( "martian" 21 | , 0xff0000ff 22 | ); 23 | 24 | 25 | drop table if exists relationships; 26 | 27 | create table relationships 28 | ( factionId1 integer not null 29 | , factionId2 integer not null 30 | , relationship real not null 31 | ); 32 | -------------------------------------------------------------------------------- /data/ship-names.txt: -------------------------------------------------------------------------------- 1 | A Bullet Through 2 | A Cigarette Long 3 | A Collection of Things 4 | A Feverish Dream 5 | A Letter Washes 6 | A Little Beyond 7 | A Matter for Wrong or Right 8 | A Million Miles from Nowhere 9 | A Nation Whispers 10 | A Neutral Fury 11 | A Nobody Without 12 | A Pleasure 13 | A Precious Few 14 | A Scene from Memory 15 | A Serious Dream 16 | A Shame to Leave 17 | A Thought That’s Never 18 | A Time of Neither 19 | A Wish That Wasn’t Granted 20 | Across the Front 21 | After a Glimpse 22 | All Its Delicate Fear 23 | All Your Surroundings 24 | Alone to Get Gigantic 25 | Along the Line of the Road 26 | An Epic Too Small 27 | An Inch an Hour 28 | As a Lightbulb 29 | As Parasites Might 30 | At Their Shoes 31 | Blues on the Street 32 | Bride of the Northern Woods 33 | By the Burning 34 | Casting a Golden Light 35 | Come on Just Let’s Go 36 | Could No Longer Contain 37 | Dance the Sidewalk 38 | Days of Shockley 39 | Defanged 40 | Desperate Measures 41 | Desperate Times 42 | Don’t Know Me When 43 | Doubts or Maybes 44 | Drifts of Serengeti 45 | Fell Through the Night 46 | Find the Whole 47 | First Thing 48 | For a Decade 49 | For an Eclectic Choice 50 | For Neglect 51 | For the Time 52 | Forty Things 53 | From High up Above 54 | From the North 55 | From the Rooftops 56 | Give Me a Line 57 | Heavy Is the Head 58 | Her Ragged Sleeves 59 | High Card Is Taste 60 | Home by Sundown 61 | Illusions of Someday 62 | In a Lifeboat 63 | In Whispers Again 64 | Into That Good Night 65 | It Couldn’t Come at a Worse Time 66 | Kicked off Our Pantleg 67 | Look Ma, No Hands 68 | Loose and Complete 69 | Low Card Is Hunger 70 | Memory 71 | Motorcycle Language 72 | Move Right Through Me 73 | Neither This Nor That 74 | No Picture Postcards 75 | No Simple Explanation 76 | No Souvenirs 77 | No Time for Shadowed 78 | Of Living 79 | Of Living in the Past 80 | Of Machine-Revving Tension 81 | Only a Fool 82 | Or Sit Silently 83 | Our Thousand Mile Suits 84 | Out of the Wilderness 85 | Out the Highlights 86 | Over Glasgow 87 | Slow at Your Leisure 88 | Slow Time Away 89 | Slowly, Sadly, and Properly 90 | So Fast Asleep 91 | So Softly in Accordance 92 | Some Air to Clear 93 | St. Peter Wouldn’t Mind 94 | Standing in a Killer’s Place 95 | Suspicious or Hostile 96 | Swollen City-Breeze 97 | The After-Effects 98 | The Baffled King Composing 99 | The Beautiful Lull 100 | The Bottle Is Dusty 101 | The Dead Art 102 | The Faster It Gets 103 | The Front Door Smiling 104 | The Hearts of Everyone 105 | The Last Goal 106 | The Less You Need 107 | The Louder They Clap 108 | The Mention of Berlin 109 | The Sky Was Dull 110 | The Start of Another 111 | The Tap on the Window 112 | Their Voices Rang 113 | This Masterpiece 114 | Those Left in the Water 115 | Til Nineteen Sixty-Two 116 | To Feel Small 117 | To Sweep Them All 118 | Two Roads Diverged 119 | Two-Fifths of Lead 120 | Until We Meet Again 121 | Up to the Lord 122 | Weave the Sun 123 | What I Propose 124 | What’s This River 125 | Win Another 126 | With Revenge and Doubt 127 | With Skill and its Frustration 128 | With the Consequences 129 | You Should’ve Seen the Look on Your Face 130 | You Will Come Back Like the Tide 131 | You’re Not the First 132 | Your Faith in Human Nature 133 | Your Lanterns Low 134 | -------------------------------------------------------------------------------- /fonts/DejaVuSans.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/robrix/starlight/ad80ab74dc2eedbb52a75ac8ce507661d32f488e/fonts/DejaVuSans.ttf -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | bios: 3 | program: script/ghci-flags 4 | dependency-program: script/ghci-flags-dependencies 5 | -------------------------------------------------------------------------------- /notes/🏁 Fixed time interval physics integration.md: -------------------------------------------------------------------------------- 1 | # 🏁 Fixed time interval physics integration 2 | 3 | Goals: 4 | 5 | 1. Decouple physics from the frame rate. 6 | 7 | 2. Improve the accuracy of the simulation. 8 | 9 | 10 | To this end, this work intends to: 11 | 12 | 1. Run the physics in a background thread. 13 | 14 | 2. Reduce the integration intervals. 15 | 16 | 3. Fix the integration intervals. 17 | 18 | 19 | ## Tasks 20 | 21 | - [x] Start a background thread to run the physics. 22 | - [ ] Run the physics in a loop with a fixed time interval. 23 | - [ ] Sleep at the end of each iteration until the next multiple of the interval. 24 | - [x] Communicate state changes (physics in background, controls in foreground) via STM. 25 | - [x] Draw from the read-only copy. 26 | - [ ] Interpolate drawing relative to the integration interval. 27 | -------------------------------------------------------------------------------- /script/ghci-flags: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Computes the flags for ghcide to pass to ghci. You probably won’t be running this yourself, but rather ghcide will via configuration in hie.yaml. 3 | 4 | set -e 5 | 6 | cd "$(dirname "$0")/.." 7 | 8 | ghc_version="$(ghc --numeric-version)" 9 | 10 | # recent hie-bios requires us to output to the file at $HIE_BIOS_OUTPUT, but older builds & script/repl don’t set that var, so we default it to stdout 11 | output_file="${HIE_BIOS_OUTPUT:-/dev/stdout}" 12 | 13 | build_dir="dist-newstyle/build/x86_64-osx/ghc-$ghc_version" 14 | build_products_dir="$build_dir/build-repl" 15 | 16 | cores=$(sysctl -n machdep.cpu.core_count || echo 4) 17 | 18 | function flags { 19 | # disable optimizations for faster loading 20 | echo "-O0" 21 | # don’t load .ghci files (for ghcide) 22 | echo "-ignore-dot-ghci" 23 | 24 | # use as many jobs as there are physical cores 25 | echo "-j$((cores + 1))" 26 | 27 | # where to put build products 28 | echo "-outputdir $build_products_dir" 29 | echo "-odir $build_products_dir" 30 | echo "-hidir $build_products_dir" 31 | echo "-stubdir $build_products_dir" 32 | 33 | # preprocessor options, for -XCPP 34 | echo "-optP-include" 35 | echo "-optP$build_dir/starlight-0.0.0.0/build/autogen/cabal_macros.h" 36 | 37 | # autogenerated sources, both .hs and .h (e.g. Foo_paths.hs) 38 | echo "-i$build_dir/starlight-0.0.0.0/build/autogen" 39 | echo "-I$build_dir/starlight-0.0.0.0/build/autogen" 40 | 41 | # .hs source dirs 42 | echo "-iapp" 43 | echo "-isrc" 44 | 45 | # disable automatic selection of packages 46 | echo "-hide-all-packages" 47 | 48 | # run cabal and emit package flags from the environment file, removing comments & prefixing with - 49 | cabal v2-exec -v0 bash -- -c 'cat "$GHC_ENVIRONMENT"' | grep -v '^--' | sed -e 's/^/-/' 50 | 51 | # default language extensions 52 | echo "-XHaskell2010" 53 | 54 | # treat warnings as warnings 55 | echo "-Wwarn" 56 | 57 | # default warning flags 58 | echo "-Weverything" 59 | echo "-Wno-all-missed-specialisations" 60 | echo "-Wno-implicit-prelude" 61 | echo "-Wno-missed-specialisations" 62 | echo "-Wno-missing-import-lists" 63 | echo "-Wno-missing-local-signatures" 64 | echo "-Wno-monomorphism-restriction" 65 | echo "-Wno-name-shadowing" 66 | echo "-Wno-safe" 67 | echo "-Wno-unsafe" 68 | [[ "$ghc_version" = 8.8.* ]] && echo "-Wno-missing-deriving-strategies" || true 69 | } 70 | 71 | flags > "$output_file" 72 | -------------------------------------------------------------------------------- /script/ghci-flags-dependencies: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Computes the paths to files causing changes to the ghci flags. You probably won’t be running this yourself, but rather ghcide will via configuration in hie.yaml. 3 | 4 | set -e 5 | 6 | cd $(dirname "$0")/.. 7 | 8 | echo "cabal.project" 9 | 10 | echo "starlight.cabal" 11 | -------------------------------------------------------------------------------- /script/repl: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Usage: script/repl [ARGS...] 3 | # Run a repl session capable of loading all of the components. Any passed arguments, e.g. module names or flags, will be passed to ghci. 4 | 5 | set -e 6 | 7 | cd "$(dirname "$0")/.." 8 | 9 | # cabal v2-build all --only-dependencies 10 | 11 | cores=$(sysctl -n machdep.cpu.core_count || echo 4) 12 | env starlight_datadir=. cabal v2-exec env -- -u GHC_ENVIRONMENT ghci +RTS -N$((cores + 1)) -RTS -ghci-script=.ghci.repl $(script/ghci-flags) -no-ignore-dot-ghci $@ 13 | -------------------------------------------------------------------------------- /src/Control/Carrier/Database/SQLite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | module Control.Carrier.Database.SQLite 8 | ( -- * Database carrier 9 | runDatabase 10 | , DatabaseC(DatabaseC) 11 | -- * Database effect 12 | , module Control.Effect.Database 13 | ) where 14 | 15 | import Control.Carrier.Reader 16 | import Control.Effect.Database 17 | import Control.Effect.Labelled 18 | import Control.Effect.Lift 19 | import Control.Exception.Lift 20 | import Control.Monad.Fix 21 | import Control.Monad.IO.Class 22 | import Control.Monad.Trans.Class 23 | import Data.Text (pack) 24 | import qualified Database.SQLite3 as SQLite 25 | 26 | runDatabase :: Has (Lift IO) sig m => FilePath -> DatabaseC m a -> m a 27 | runDatabase file (DatabaseC m) = bracket (sendM (SQLite.open (pack file))) (sendM . SQLite.close) (`runReader` m) 28 | 29 | newtype DatabaseC m a = DatabaseC { runDatabaseC :: ReaderC SQLite.Database m a } 30 | deriving (Applicative, Functor, Monad, MonadFail, MonadFix, MonadIO, MonadTrans) 31 | 32 | instance Has (Lift IO) sig m => Algebra (Labelled Database (Database SQLite.Statement) :+: sig) (DatabaseC m) where 33 | alg hdl sig ctx = case sig of 34 | L (Labelled (Execute cmd m)) -> do 35 | db <- DatabaseC ask 36 | stmt <- sendM (SQLite.prepare db cmd) 37 | a <- hdl (m stmt <$ ctx) 38 | a <$ sendM (SQLite.finalize stmt) 39 | L (Labelled (Step stmt)) -> do 40 | res <- sendM (SQLite.step stmt) 41 | case res of 42 | SQLite.Done -> pure (Nothing <$ ctx) 43 | SQLite.Row -> (<$ ctx) . Just <$> sendM (SQLite.columns stmt) 44 | R other -> DatabaseC (alg (runDatabaseC . hdl) (R other) ctx) 45 | -------------------------------------------------------------------------------- /src/Control/Carrier/Error/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | module Control.Carrier.Error.IO 7 | ( -- * Error carrier 8 | runError 9 | , ErrorC(ErrorC) 10 | -- * Error effect 11 | , module Control.Effect.Error 12 | ) where 13 | 14 | import Control.Algebra 15 | import Control.Effect.Error 16 | import Control.Effect.Lift 17 | import Control.Exception.Lift 18 | import Control.Monad.IO.Class 19 | import Control.Monad.Trans.Class 20 | 21 | runError :: (Exception e, Has (Lift IO) sig m) => ErrorC e m a -> m (Either e a) 22 | runError (ErrorC m) = try m 23 | 24 | newtype ErrorC e m a = ErrorC { runErrorC :: m a } 25 | deriving (Applicative, Functor, Monad, MonadFail, MonadIO) 26 | 27 | instance MonadTrans (ErrorC e) where 28 | lift = ErrorC 29 | 30 | instance (Exception e, Has (Lift IO) sig m) => Algebra (Error e :+: sig) (ErrorC e m) where 31 | alg hdl sig ctx = case sig of 32 | L (L (Throw e)) -> throwIO e 33 | L (R (Catch m h)) -> hdl (m <$ ctx) `catch` (hdl . (<$ ctx) . h) 34 | R other -> ErrorC (alg (runErrorC . hdl) other ctx) 35 | -------------------------------------------------------------------------------- /src/Control/Carrier/Finally.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | module Control.Carrier.Finally 8 | ( -- * Finally carrier 9 | runFinally 10 | , FinallyC(..) 11 | -- * Finally effect 12 | , module Control.Effect.Finally 13 | ) where 14 | 15 | import Control.Algebra 16 | import Control.Carrier.State.IORef 17 | import Control.Effect.Finally 18 | import qualified Control.Exception.Lift as E 19 | import Control.Monad.Fix 20 | import Control.Monad.IO.Class.Lift 21 | import Data.Foldable (traverse_) 22 | import Data.Functor (void) 23 | import Data.IORef 24 | 25 | runFinally :: Has (Lift IO) sig m => FinallyC m a -> m a 26 | runFinally (FinallyC m) = do 27 | ref <- sendM (newIORef []) 28 | runStateRef ref m `E.finally` (sendM (readIORef ref) >>= traverse_ runFinally) 29 | 30 | newtype FinallyC m a = FinallyC { runFinallyC :: StateC [FinallyC m ()] m a } 31 | deriving (Applicative, Functor, Monad, MonadFail, MonadFix, MonadIO) 32 | 33 | instance Has (Lift IO) sig m => Algebra (Finally :+: sig) (FinallyC m) where 34 | alg hdl sig ctx = case sig of 35 | L (OnExit m) -> ctx <$ FinallyC (modify (void (hdl (m <$ ctx)) :)) 36 | R other -> FinallyC (alg (runFinallyC . hdl) (R other) ctx) 37 | -------------------------------------------------------------------------------- /src/Control/Carrier/Reader/Relation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | module Control.Carrier.Reader.Relation 4 | ( -- * Relations 5 | runRelation 6 | , Relation(Relation) 7 | , expect 8 | ) where 9 | 10 | import Control.Algebra 11 | import Control.Applicative (Alternative) 12 | import Control.Carrier.Reader 13 | import Control.Effect.Lens (view) 14 | import Control.Effect.Sum (inj) 15 | import Control.Lens (Getting) 16 | import Control.Monad (guard, (<=<)) 17 | 18 | runRelation :: i -> Relation i a -> Maybe a 19 | runRelation i (Relation m) = runReader i m 20 | 21 | newtype Relation i a = Relation { runRelationC :: ReaderC i Maybe a } 22 | deriving (Alternative, Applicative, Functor, Monad) 23 | 24 | instance Algebra (Reader i) (Relation i) where 25 | alg hdl sig = Relation . alg (runRelationC . hdl) (inj sig) 26 | 27 | 28 | expect :: (Alternative m, Has (Reader r) sig m) => Getting Bool r Bool -> m () 29 | expect = guard <=< view 30 | -------------------------------------------------------------------------------- /src/Control/Carrier/State/IORef.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitForAll #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | module Control.Carrier.State.IORef 9 | ( -- * State carrier 10 | runStateRef 11 | , runState 12 | , evalState 13 | , execState 14 | , StateC(..) 15 | -- * State effect 16 | , module Control.Effect.State 17 | ) where 18 | 19 | import Control.Algebra 20 | import Control.Carrier.Reader 21 | import Control.Effect.State 22 | import Control.Monad.Fix 23 | import Control.Monad.IO.Class.Lift 24 | import Control.Monad.Trans.Class 25 | import Data.IORef 26 | 27 | runStateRef :: IORef s -> StateC s m a -> m a 28 | runStateRef ref (StateC m) = runReader ref m 29 | 30 | runState :: forall s m a sig . Has (Lift IO) sig m => s -> StateC s m a -> m (s, a) 31 | runState s m = do 32 | ref <- sendM (newIORef s) 33 | a <- runStateRef ref m 34 | s' <- sendM (readIORef ref) 35 | pure (s', a) 36 | 37 | evalState :: forall s m a sig . Has (Lift IO) sig m => s -> StateC s m a -> m a 38 | evalState s = fmap snd . runState s 39 | 40 | execState :: forall s m a sig . Has (Lift IO) sig m => s -> StateC s m a -> m s 41 | execState s = fmap fst . runState s 42 | 43 | newtype StateC s m a = StateC { runStateC :: ReaderC (IORef s) m a } 44 | deriving (Applicative, Functor, Monad, MonadFail, MonadFix, MonadIO, MonadTrans) 45 | 46 | instance Has (Lift IO) sig m => Algebra (State s :+: sig) (StateC s m) where 47 | alg hdl sig ctx = case sig of 48 | L Get -> (<$ ctx) <$> (StateC ask >>= sendM . readIORef) 49 | L (Put s) -> ctx <$ (StateC ask >>= sendM . flip writeIORef s) 50 | R other -> StateC (alg (runStateC . hdl) (R other) ctx) 51 | -------------------------------------------------------------------------------- /src/Control/Carrier/State/ST/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 6 | {-# HLINT ignore "Use execState" #-} 7 | {-# HLINT ignore "Use evalState" #-} 8 | module Control.Carrier.State.ST.Strict 9 | ( -- * State carrier 10 | runStateRef 11 | , runState 12 | , evalState 13 | , execState 14 | , StateC(..) 15 | -- * State effect 16 | , module Control.Effect.State 17 | ) where 18 | 19 | import Control.Algebra 20 | import Control.Carrier.Reader 21 | import Control.Effect.State 22 | import Control.Monad (ap) 23 | import Control.Monad.ST.Strict 24 | import Data.STRef 25 | 26 | runStateRef :: STRef t s -> StateC s a -> ST t a 27 | runStateRef ref (StateC m) = runReader ref m 28 | 29 | runState :: s -> StateC s a -> (s, a) 30 | runState s m = runST $ do 31 | ref <- newSTRef s 32 | a <- runStateRef ref m 33 | s' <- readSTRef ref 34 | pure (s', a) 35 | 36 | evalState :: s -> StateC s a -> a 37 | evalState s = snd . runState s 38 | 39 | execState :: s -> StateC s a -> s 40 | execState s = fst . runState s 41 | 42 | newtype StateC s a = StateC (forall t . ReaderC (STRef t s) (ST t) a) 43 | deriving (Functor) 44 | 45 | instance Applicative (StateC s) where 46 | pure a = StateC (pure a) 47 | (<*>) = ap 48 | 49 | instance Monad (StateC s) where 50 | StateC m >>= f = StateC (m >>= (\ (StateC m) -> m) . f) 51 | 52 | instance Algebra (State s) (StateC s) where 53 | alg _ sig ctx = case sig of 54 | Get -> StateC (ReaderC (fmap (<$ ctx) . readSTRef)) 55 | Put s -> StateC (ReaderC (\ ref -> ctx <$ writeSTRef ref s)) 56 | -------------------------------------------------------------------------------- /src/Control/Carrier/State/STM/TVar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitForAll #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | -- | A 'Control.Concurrent.STM.TVar.TVar'-backed carrier for 'State'. Individual 'get's and 'put's are run 'atomically', but NB that 'modify' is /not/ atomic, so this is likely unsuitable for complex interleaving of concurrent reads and writes. 9 | module Control.Carrier.State.STM.TVar 10 | ( -- * State carrier 11 | runStateVar 12 | , runState 13 | , evalState 14 | , execState 15 | , StateC(..) 16 | -- * State effect 17 | , module Control.Effect.State 18 | ) where 19 | 20 | import Control.Algebra 21 | import Control.Carrier.Lift 22 | import Control.Carrier.Reader 23 | import Control.Concurrent.STM.TVar 24 | import Control.Effect.State 25 | import Control.Monad.Fix 26 | import Control.Monad.IO.Class 27 | import Control.Monad.STM 28 | import Control.Monad.Trans.Class 29 | 30 | runStateVar :: TVar s -> StateC s m a -> m a 31 | runStateVar var (StateC m) = runReader var m 32 | 33 | runState :: forall s m a sig . Has (Lift IO) sig m => s -> StateC s m a -> m (s, a) 34 | runState s m = do 35 | var <- sendM (newTVarIO s) 36 | a <- runStateVar var m 37 | s' <- sendM (readTVarIO var) 38 | pure (s', a) 39 | 40 | evalState :: forall s m a sig . Has (Lift IO) sig m => s -> StateC s m a -> m a 41 | evalState s = fmap snd . runState s 42 | 43 | execState :: forall s m a sig . Has (Lift IO) sig m => s -> StateC s m a -> m s 44 | execState s = fmap fst . runState s 45 | 46 | newtype StateC s m a = StateC { runStateC :: ReaderC (TVar s) m a } 47 | deriving (Applicative, Functor, Monad, MonadFail, MonadFix, MonadIO, MonadTrans) 48 | 49 | instance Has (Lift IO) sig m => Algebra (State s :+: sig) (StateC s m) where 50 | alg hdl sig ctx = case sig of 51 | L Get -> (<$ ctx) <$> (StateC ask >>= sendM . readTVarIO) 52 | L (Put s) -> do 53 | var <- StateC ask 54 | ctx <$ StateC (sendM (atomically (writeTVar var s))) 55 | R other -> StateC (alg (runStateC . hdl) (R other) ctx) 56 | -------------------------------------------------------------------------------- /src/Control/Carrier/Thread/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | module Control.Carrier.Thread.IO 8 | ( runThread 9 | , ThreadC(ThreadC) 10 | -- * Thread effect 11 | , module Control.Effect.Thread 12 | ) where 13 | 14 | import Control.Algebra 15 | import qualified Control.Concurrent as CC 16 | import Control.Effect.Labelled 17 | import Control.Effect.Lift 18 | import Control.Effect.Thread 19 | import Control.Monad (void) 20 | import Control.Monad.Fix 21 | import Control.Monad.IO.Class 22 | 23 | newtype ThreadC m a = ThreadC { runThread :: m a } 24 | deriving (Applicative, Functor, Monad, MonadFail, MonadFix, MonadIO) 25 | 26 | instance Has (Lift IO) sig m => Algebra (Labelled Thread (Thread CC.ThreadId) :+: sig) (ThreadC m) where 27 | alg hdl sig ctx = case sig of 28 | -- NB: this discards state changes in the other thread 29 | L (Labelled (Fork m)) -> liftWith (\ hdl2 ctx2 -> (<$ ctx2) . (<$ ctx) <$> CC.forkIO (void (hdl2 (hdl (m <$ ctx) <$ ctx2)))) 30 | L (Labelled (Kill i)) -> ctx <$ sendM (CC.killThread i) 31 | L (Labelled Yield) -> ctx <$ sendM CC.yield 32 | R other -> ThreadC (alg (runThread . hdl) other ctx) 33 | -------------------------------------------------------------------------------- /src/Control/Carrier/Trace/Lift.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | module Control.Carrier.Trace.Lift 8 | ( -- * Trace carrier 9 | runTrace 10 | , TraceC(TraceC) 11 | -- * Trace effect 12 | , module Control.Effect.Trace 13 | ) where 14 | 15 | import Control.Algebra 16 | import Control.Effect.Lift 17 | import Control.Effect.Trace 18 | import Control.Monad.Fix 19 | import Control.Monad.IO.Class 20 | import System.IO 21 | 22 | newtype TraceC m a = TraceC { runTrace :: m a } 23 | deriving (Applicative, Functor, Monad, MonadFail, MonadFix, MonadIO) 24 | 25 | instance Has (Lift IO) sig m => Algebra (Trace :+: sig) (TraceC m) where 26 | alg hdl sig ctx = case sig of 27 | L (Trace s) -> ctx <$ sendM (hPutStrLn stderr s) 28 | R other -> TraceC (alg (runTrace . hdl) other ctx) 29 | -------------------------------------------------------------------------------- /src/Control/Concurrent/Lift.hs: -------------------------------------------------------------------------------- 1 | module Control.Concurrent.Lift 2 | ( runInBoundThread 3 | ) where 4 | 5 | import qualified Control.Concurrent as CC 6 | import Control.Effect.Lift 7 | 8 | -- | See @"Control.Concurrent".'CC.runInBoundThread'@. 9 | runInBoundThread :: Has (Lift IO) sig m => m a -> m a 10 | runInBoundThread m = liftWith $ \ hdl ctx -> CC.runInBoundThread (hdl (m <$ ctx)) 11 | -------------------------------------------------------------------------------- /src/Control/Effect/Database.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | module Control.Effect.Database 5 | ( -- * Database effect 6 | execute 7 | , step 8 | , Database(..) 9 | -- * Re-exports 10 | , Algebra 11 | , HasLabelled 12 | , run 13 | ) where 14 | 15 | import Control.Algebra 16 | import Control.Effect.Labelled 17 | import Data.Text (Text) 18 | import Database.SQLite3 (SQLData) 19 | 20 | execute :: HasLabelled Database (Database stmt) sig m => Text -> (stmt -> m a) -> m a 21 | execute cmd m = sendLabelled @Database (Execute cmd m) 22 | 23 | step :: HasLabelled Database (Database stmt) sig m => stmt -> m (Maybe [SQLData]) 24 | step stmt = sendLabelled @Database (Step stmt) 25 | 26 | data Database stmt m k where 27 | Execute :: Text -> (stmt -> m a) -> Database stmt m a 28 | Step :: stmt -> Database stmt m (Maybe [SQLData]) 29 | -------------------------------------------------------------------------------- /src/Control/Effect/Finally.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | module Control.Effect.Finally 3 | ( -- * Finally effect 4 | Finally(..) 5 | , onExit 6 | -- * Re-exports 7 | , Algebra 8 | , Has 9 | , run 10 | ) where 11 | 12 | import Control.Algebra 13 | 14 | data Finally m k where 15 | OnExit :: m a -> Finally m () 16 | 17 | 18 | onExit :: Has Finally sig m => m () -> m () 19 | onExit m = send (OnExit m) 20 | -------------------------------------------------------------------------------- /src/Control/Effect/Lens/Exts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module Control.Effect.Lens.Exts 3 | ( (~>) 4 | , (<~>) 5 | , (<--) 6 | , (-->) 7 | , (<->) 8 | , locally 9 | , asserting 10 | , module Control.Effect.Lens 11 | ) where 12 | 13 | import Control.Effect.Reader 14 | import Control.Effect.State 15 | import Control.Effect.Lens 16 | import Control.Exception (assert) 17 | import Control.Lens (ASetter, Getting, Iso', Lens', iso, over, set, (^.)) 18 | import GHC.Stack (HasCallStack, withFrozenCallStack) 19 | 20 | -- | Compose a getter onto the input of a Kleisli arrow and run it on the 'State'. 21 | (~>) :: Has (State s) sig m => Getting a s a -> (a -> m b) -> m b 22 | lens ~> act = use lens >>= act 23 | 24 | infixr 2 ~> 25 | 26 | -- | Compose a lens onto either side of a Kleisli arrow and run it on the 'State'. 27 | (<~>) :: Has (State s) sig m => Lens' s a -> (a -> m a) -> m () 28 | lens <~> act = lens <~ lens ~> act 29 | 30 | infixr 2 <~> 31 | 32 | 33 | -- | Compose a setter onto the output of a Kleisli arrow. 34 | -- 35 | -- By analogy with '<~': 36 | -- 37 | -- > lens '<~' act = 'get' >>= lens '<--' 'const' act '>>=' 'put' 38 | (<--) :: Functor m => ASetter s s a b -> (s -> m b) -> (s -> m s) 39 | (lens <-- act) s = ($ s) . set lens <$> act s 40 | 41 | infixr 2 <-- 42 | 43 | -- | Compose a getter onto the input of a Kleisli arrow. 44 | -- 45 | -- By analogy with '~>': 46 | -- 47 | -- > lens '~>' act = 'get' '>>=' lens '-->' act 48 | (-->) :: Getting a s a -> (a -> m b) -> (s -> m b) 49 | (lens --> act) s = act (s^.lens) 50 | 51 | infixr 2 --> 52 | 53 | -- | Compose a lens onto either side of a Kleisli arrow. 54 | -- 55 | -- By analogy with '<~>': 56 | -- 57 | -- > lens '<~>' act = 'get' '>>=' lens '<->' act '>>=' 'put' 58 | (<->) :: Functor m => Lens' s a -> (a -> m a) -> (s -> m s) 59 | lens <-> act = lens <-- lens --> act 60 | 61 | infixr 2 <-> 62 | 63 | 64 | locally :: Has (Reader s) sig m => ASetter s s a b -> (a -> b) -> m r -> m r 65 | locally l f = local (over l f) 66 | 67 | 68 | asserting :: HasCallStack => (a -> Bool) -> Iso' a a 69 | asserting pred = withFrozenCallStack $ iso id (assert . pred <*> id) 70 | -------------------------------------------------------------------------------- /src/Control/Effect/Thread.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | module Control.Effect.Thread 5 | ( -- * Thread effect 6 | fork 7 | , kill 8 | , yield 9 | , Thread(..) 10 | -- * Re-exports 11 | , Algebra 12 | , HasLabelled 13 | , run 14 | ) where 15 | 16 | import Control.Algebra 17 | import Control.Effect.Labelled 18 | 19 | fork :: HasLabelled Thread (Thread id) sig m => m () -> m id 20 | fork m = sendLabelled @Thread (Fork m) 21 | 22 | kill :: HasLabelled Thread (Thread id) sig m => id -> m () 23 | kill i = sendLabelled @Thread (Kill i) 24 | 25 | yield :: HasLabelled Thread (Thread id) sig m => m () 26 | yield = sendLabelled @Thread Yield 27 | 28 | data Thread id m k where 29 | Fork :: m a -> Thread id m id 30 | Kill :: id -> Thread id m () 31 | Yield :: Thread id m () 32 | -------------------------------------------------------------------------------- /src/Control/Exception/Lift.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | module Control.Exception.Lift 6 | ( E.Exception(..) 7 | , E.SomeException(..) 8 | , throwIO 9 | , catch 10 | , catches 11 | , Handler(..) 12 | , handle 13 | , try 14 | , mask 15 | , bracket 16 | , bracket_ 17 | , finally 18 | , onException 19 | ) where 20 | 21 | import Control.Effect.Lift 22 | import qualified Control.Exception as E 23 | 24 | -- | See @"Control.Exception".'E.throwIO'@. 25 | throwIO :: (E.Exception e, Has (Lift IO) sig m) => e -> m a 26 | throwIO = sendM . E.throwIO 27 | 28 | -- | See @"Control.Exception".'E.catch'@. 29 | catch :: (E.Exception e, Has (Lift IO) sig m) => m a -> (e -> m a) -> m a 30 | catch m h = liftWith $ \ hdl ctx -> hdl (m <$ ctx) `E.catch` (hdl . (<$ ctx) . h) 31 | 32 | -- | See @"Control.Exception".'E.catches'@. 33 | catches :: Has (Lift IO) sig m => m a -> [Handler m a] -> m a 34 | catches m hs = liftWith $ \ hdl ctx -> 35 | E.catches (hdl (m <$ ctx)) (map (\ (Handler h) -> E.Handler (hdl . (<$ ctx) . h)) hs) 36 | 37 | -- | See @"Control.Exception".'E.Handler'@. 38 | data Handler m a 39 | = forall e . E.Exception e => Handler (e -> m a) 40 | 41 | deriving instance Functor m => Functor (Handler m) 42 | 43 | -- | See @"Control.Exception".'E.handle'@. 44 | handle :: (E.Exception e, Has (Lift IO) sig m) => (e -> m a) -> m a -> m a 45 | handle h m = liftWith $ \ hdl ctx -> (hdl . (<$ ctx) . h) `E.handle` hdl (m <$ ctx) 46 | 47 | -- | See @"Control.Exception".'E.try'@. 48 | try :: (E.Exception e, Has (Lift IO) sig m) => m a -> m (Either e a) 49 | try = handle (pure . Left) . fmap Right 50 | 51 | -- | See @"Control.Exception".'E.mask'@. 52 | mask :: Has (Lift IO) sig m => ((forall a . m a -> m a) -> m b) -> m b 53 | mask with = liftWith $ \ hdl ctx -> E.mask $ \ restore -> 54 | hdl (with (\ m -> liftWith $ \ hdl' ctx' -> restore (hdl' (m <$ ctx'))) <$ ctx) 55 | 56 | -- | See @"Control.Exception".'E.bracket'@. 57 | bracket 58 | :: Has (Lift IO) sig m 59 | => m a 60 | -> (a -> m b) 61 | -> (a -> m c) 62 | -> m c 63 | bracket acquire release m = mask $ \ restore -> do 64 | a <- acquire 65 | r <- restore (m a) `onException` release a 66 | r <$ release a 67 | 68 | -- | See @"Control.Exception".'E.bracket_'@. 69 | bracket_ 70 | :: Has (Lift IO) sig m 71 | => m a 72 | -> m b 73 | -> m c 74 | -> m c 75 | bracket_ before after thing = bracket before (const after) (const thing) 76 | 77 | -- | See @"Control.Exception".'E.finally'@. 78 | finally 79 | :: Has (Lift IO) sig m 80 | => m a 81 | -> m b 82 | -> m a 83 | finally m sequel = mask $ \ restore -> (restore m `onException` sequel) <* sequel 84 | 85 | -- | See @"Control.Exception".'E.onException'@. 86 | onException :: Has (Lift IO) sig m => m a -> m b -> m a 87 | onException io what = io `catch` \e -> what >> throwIO (e :: E.SomeException) 88 | -------------------------------------------------------------------------------- /src/Control/Monad/IO/Class/Lift.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | module Control.Monad.IO.Class.Lift 5 | ( LiftIO(..) 6 | , module Control.Carrier.Lift 7 | , MonadIO(..) 8 | ) where 9 | 10 | import Control.Algebra 11 | import Control.Carrier.Lift 12 | import Control.Monad.IO.Class 13 | 14 | newtype LiftIO m a = LiftIO { runLiftIO :: m a } 15 | deriving (Algebra sig, Applicative, Functor, Monad, MonadFail) 16 | 17 | instance Has (Lift IO) sig m => MonadIO (LiftIO m) where 18 | liftIO = sendM 19 | -------------------------------------------------------------------------------- /src/Data/Flag.hs: -------------------------------------------------------------------------------- 1 | -- http://oleg.fi/gists/posts/2019-03-21-flag.html 2 | module Data.Flag 3 | ( Flag 4 | , toFlag 5 | , fromFlag 6 | ) where 7 | 8 | newtype Flag t = Flag { getFlag :: Bool } 9 | deriving (Eq, Ord, Show) 10 | 11 | toFlag :: t -> Bool -> Flag t 12 | toFlag _ = Flag 13 | 14 | fromFlag :: t -> Flag t -> Bool 15 | fromFlag _ = getFlag 16 | -------------------------------------------------------------------------------- /src/Data/Functor/C.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | module Data.Functor.C 4 | ( (:.:)(..) 5 | ) where 6 | 7 | import Control.Applicative 8 | 9 | newtype (f :.: g) a = C { getC :: f (g a) } 10 | deriving (Eq, Foldable, Functor, Ord, Show, Traversable) 11 | 12 | instance (Applicative f, Applicative g) => Applicative (f :.: g) where 13 | pure = C . pure . pure 14 | {-# INLINE pure #-} 15 | 16 | C f <*> C a = C $ liftA2 (<*>) f a 17 | {-# INLINE (<*>) #-} 18 | -------------------------------------------------------------------------------- /src/Data/Functor/I.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | -- | I got sick of writing 'Identity' out in full. 5 | -- 6 | -- This functor is commonly used to: 7 | -- 8 | -- * Represent the coordinates in 1-dimensional @"Data.Functor.Interval".'Data.Functor.Interval.Interval'@ used for e.g. vertex ranges. 9 | -- * Hold vertices’ values when copying into an array buffer. 10 | -- * Represent dimensionless units such as transcendental numbers, the arguments & results of trigonometric functions, angles, and ratios. 11 | -- * Represent the traditional dimension 1 of dimensionless units. 12 | module Data.Functor.I 13 | ( I(..) 14 | ) where 15 | 16 | import Data.Functor.Identity 17 | import Linear 18 | import Foreign.Storable 19 | import GL.Type as GL 20 | import GL.Uniform 21 | import System.Random (Random) 22 | 23 | newtype I a = I { getI :: a } 24 | deriving (Column, Conjugate, Epsilon, Enum, Eq, Foldable, Floating, Fractional, Functor, Integral, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 25 | deriving (Additive, Applicative, Metric, Monad) via Identity 26 | -------------------------------------------------------------------------------- /src/Data/Functor/Interval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | module Data.Functor.Interval 8 | ( Interval(..) 9 | , (...) 10 | , point 11 | , pointwise 12 | , size 13 | , toUnit 14 | , fromUnit 15 | , range 16 | , wrap 17 | , inf_ 18 | , sup_ 19 | , imap 20 | , member 21 | , isSubintervalOf 22 | , isProperSubintervalOf 23 | , uniformI 24 | , Union(..) 25 | , union 26 | , Intersection(..) 27 | , intersection 28 | ) where 29 | 30 | import Control.Applicative (liftA2) 31 | import Control.Effect.Random 32 | import Control.Lens hiding (imap, (...)) 33 | import Control.Monad (join) 34 | import Control.Monad.Trans.Class 35 | import Data.Coerce (coerce) 36 | import Data.Fixed (mod') 37 | import Data.Functor.I 38 | import Data.Generics.Product.Fields 39 | import GHC.Generics (Generic) 40 | import qualified System.Random as R 41 | 42 | data Interval f a = Interval 43 | { inf :: !(f a) 44 | , sup :: !(f a) 45 | } 46 | deriving (Eq, Foldable, Functor, Generic, Ord, Show, Traversable) 47 | 48 | instance Applicative f => Applicative (Interval f) where 49 | pure = point . pure 50 | f <*> a = Interval (inf f <*> inf a) (sup f <*> sup a) 51 | 52 | instance Monad f => Monad (Interval f) where 53 | m >>= f = Interval (inf m >>= inf . f) (sup m >>= sup . f) 54 | 55 | instance MonadTrans Interval where 56 | lift = point 57 | 58 | instance (Applicative f, Num a) => Num (Interval f a) where 59 | (+) = liftA2 (+) 60 | {-# INLINE (+) #-} 61 | (*) = liftA2 (*) 62 | {-# INLINE (*) #-} 63 | (-) = liftA2 (-) 64 | {-# INLINE (-) #-} 65 | abs = fmap abs 66 | {-# INLINE abs #-} 67 | signum = fmap signum 68 | {-# INLINE signum #-} 69 | negate = fmap negate 70 | {-# INLINE negate #-} 71 | fromInteger = pure . fromInteger 72 | {-# INLINE fromInteger #-} 73 | 74 | instance (Applicative f, Fractional a) => Fractional (Interval f a) where 75 | recip = fmap recip 76 | {-# INLINE recip #-} 77 | (/) = liftA2 (/) 78 | {-# INLINE (/) #-} 79 | fromRational = pure . fromRational 80 | {-# INLINE fromRational #-} 81 | 82 | instance (Applicative f, Floating a) => Floating (Interval f a) where 83 | pi = pure pi 84 | {-# INLINE pi #-} 85 | exp = fmap exp 86 | {-# INLINE exp #-} 87 | sqrt = fmap sqrt 88 | {-# INLINE sqrt #-} 89 | log = fmap log 90 | {-# INLINE log #-} 91 | (**) = liftA2 (**) 92 | {-# INLINE (**) #-} 93 | logBase = liftA2 logBase 94 | {-# INLINE logBase #-} 95 | sin = fmap sin 96 | {-# INLINE sin #-} 97 | tan = fmap tan 98 | {-# INLINE tan #-} 99 | cos = fmap cos 100 | {-# INLINE cos #-} 101 | asin = fmap asin 102 | {-# INLINE asin #-} 103 | atan = fmap atan 104 | {-# INLINE atan #-} 105 | acos = fmap acos 106 | {-# INLINE acos #-} 107 | sinh = fmap sinh 108 | {-# INLINE sinh #-} 109 | tanh = fmap tanh 110 | {-# INLINE tanh #-} 111 | cosh = fmap cosh 112 | {-# INLINE cosh #-} 113 | asinh = fmap asinh 114 | {-# INLINE asinh #-} 115 | atanh = fmap atanh 116 | {-# INLINE atanh #-} 117 | acosh = fmap acosh 118 | {-# INLINE acosh #-} 119 | 120 | 121 | (...) :: Applicative f => a -> a -> Interval f a 122 | inf...sup = Interval (pure inf) (pure sup) 123 | 124 | infix 3 ... 125 | 126 | point :: f a -> Interval f a 127 | point = join Interval 128 | 129 | pointwise :: Applicative f => (Interval I a -> b) -> Interval f a -> f b 130 | pointwise f i = fmap f . (...) <$> inf i <*> sup i 131 | 132 | size :: (Applicative f, Num a) => Interval f a -> f a 133 | size = liftA2 (-) . sup <*> inf 134 | 135 | toUnit, fromUnit :: (Applicative f, Fractional a) => Interval f a -> f a -> f a 136 | toUnit i x = pointwise (\ i x -> getI ((I x - inf i) / size i)) i <*> x 137 | fromUnit i x = pointwise (\ i x -> getI (I x * size i + inf i)) i <*> x 138 | 139 | 140 | range :: Enum (f a) => Interval f a -> [f a] 141 | range = enumFromTo . inf <*> sup 142 | 143 | 144 | wrap :: (Applicative f, Real a) => Interval f a -> f a -> f a 145 | wrap i x = pointwise (\ i x -> getI (((I x + sup i) `mod'` size i) + inf i)) i <*> x 146 | 147 | 148 | inf_ :: Lens' (Interval f a) (f a) 149 | inf_ = field @"inf" 150 | 151 | sup_ :: Lens' (Interval f a) (f a) 152 | sup_ = field @"sup" 153 | 154 | 155 | imap :: (f a -> g b) -> Interval f a -> Interval g b 156 | imap f = Interval <$> f . inf <*> f . sup 157 | 158 | 159 | member :: (Applicative f, Foldable f, Ord a) => f a -> Interval f a -> Bool 160 | member = isSubintervalOf . point 161 | 162 | 163 | isSubintervalOf :: (Applicative f, Foldable f, Ord a) => Interval f a -> Interval f a -> Bool 164 | isSubintervalOf a b = and ((>=) <$> inf a <*> inf b) && and ((<=) <$> sup a <*> sup b) 165 | 166 | isProperSubintervalOf :: (Applicative f, Foldable f, Ord a) => Interval f a -> Interval f a -> Bool 167 | isProperSubintervalOf a b = and ((>) <$> inf a <*> inf b) && and ((<) <$> sup a <*> sup b) 168 | 169 | 170 | uniformI :: (R.Random a, Applicative f, Traversable f, Has Random sig m) => Interval f a -> m (f a) 171 | uniformI i = traverse uniformR ((,) <$> inf i <*> sup i) 172 | 173 | 174 | newtype Union f a = Union { getUnion :: Interval f a } 175 | deriving (Applicative, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) 176 | 177 | instance (Applicative f, Ord a) => Semigroup (Union f a) where 178 | Union i1 <> Union i2 = Union ((min...max) <*> i1 <*> i2) 179 | 180 | union :: forall f a . (Applicative f, Ord a) => Interval f a -> Interval f a -> Interval f a 181 | union = coerce ((<>) :: Union f a -> Union f a -> Union f a) 182 | 183 | 184 | newtype Intersection f a = Intersection { getIntersection :: Interval f a } 185 | deriving (Applicative, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) 186 | 187 | instance (Applicative f, Ord a) => Semigroup (Intersection f a) where 188 | Intersection i1 <> Intersection i2 = Intersection ((max...min) <*> i1 <*> i2) 189 | 190 | intersection :: forall f a . (Applicative f, Ord a) => Interval f a -> Interval f a -> Interval f a 191 | intersection = coerce ((<>) :: Intersection f a -> Intersection f a -> Intersection f a) 192 | -------------------------------------------------------------------------------- /src/Data/Functor/K.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | -- | I got sick of writing 'Const' out in full. 5 | module Data.Functor.K 6 | ( K(..) 7 | ) where 8 | 9 | import Data.Functor.Const 10 | import Foreign.Storable 11 | import Linear 12 | import System.Random (Random) 13 | 14 | newtype K a b = K { getK :: a } 15 | deriving (Conjugate, Epsilon, Enum, Eq, Foldable, Floating, Fractional, Functor, Integral, Num, Ord, Random, Real, RealFloat, RealFrac, Show, Storable, Traversable) 16 | deriving (Applicative) via Const a 17 | -------------------------------------------------------------------------------- /src/Foreign/C/String/Lift.hs: -------------------------------------------------------------------------------- 1 | module Foreign.C.String.Lift 2 | ( withCString 3 | ) where 4 | 5 | import Control.Carrier.Lift 6 | import qualified Foreign.C.String as C 7 | 8 | withCString :: Has (Lift IO) sig m => String -> (C.CString -> m a) -> m a 9 | withCString s with = liftWith $ \ hdl ctx -> C.withCString s (hdl . (<$ ctx) . with) 10 | -------------------------------------------------------------------------------- /src/Foreign/Marshal/Alloc/Lift.hs: -------------------------------------------------------------------------------- 1 | module Foreign.Marshal.Alloc.Lift 2 | ( alloca 3 | , allocaBytes 4 | ) where 5 | 6 | import Control.Carrier.Lift 7 | import qualified Foreign.Marshal.Alloc as A 8 | import Foreign.Ptr 9 | import Foreign.Storable 10 | 11 | alloca :: (Has (Lift IO) sig m, Storable a) => (Ptr a -> m b) -> m b 12 | alloca with = liftWith $ \ hdl ctx -> A.alloca (hdl . (<$ ctx) . with) 13 | 14 | allocaBytes :: Has (Lift IO) sig m => Int -> (Ptr a -> m b) -> m b 15 | allocaBytes n with = liftWith $ \ hdl ctx -> A.allocaBytes n (hdl . (<$ ctx) . with) 16 | -------------------------------------------------------------------------------- /src/Foreign/Marshal/Array/Lift.hs: -------------------------------------------------------------------------------- 1 | module Foreign.Marshal.Array.Lift 2 | ( allocaArray 3 | , peekArray 4 | , pokeArray 5 | , withArray 6 | , withArrayLen 7 | ) where 8 | 9 | import Control.Carrier.Lift 10 | import qualified Foreign.Marshal.Array as A 11 | import Foreign.Ptr 12 | import Foreign.Storable 13 | 14 | allocaArray :: (Has (Lift IO) sig m, Storable a) => Int -> (Ptr a -> m b) -> m b 15 | allocaArray n with = liftWith $ \ hdl ctx -> A.allocaArray n (hdl . (<$ ctx) . with) 16 | 17 | peekArray :: (Has (Lift IO) sig m, Storable a) => Int -> Ptr a -> m [a] 18 | peekArray n = sendM . A.peekArray n 19 | 20 | pokeArray :: (Has (Lift IO) sig m, Storable a) => Ptr a -> [a] -> m () 21 | pokeArray p = sendM . A.pokeArray p 22 | 23 | withArray :: (Has (Lift IO) sig m, Storable a) => [a] -> (Ptr a -> m b) -> m b 24 | withArray as with = liftWith $ \ hdl ctx -> A.withArray as (hdl . (<$ ctx) . with) 25 | 26 | withArrayLen :: (Has (Lift IO) sig m, Storable a) => [a] -> (Int -> Ptr a -> m b) -> m b 27 | withArrayLen as with = liftWith $ \ hdl ctx -> A.withArrayLen as (\ n -> hdl . (<$ ctx) . with n) 28 | -------------------------------------------------------------------------------- /src/Foreign/Marshal/Utils/Lift.hs: -------------------------------------------------------------------------------- 1 | module Foreign.Marshal.Utils.Lift 2 | ( with 3 | ) where 4 | 5 | import Control.Carrier.Lift 6 | import qualified Foreign.Marshal.Utils as U 7 | import Foreign.Ptr 8 | import Foreign.Storable 9 | 10 | with :: (Has (Lift IO) sig m, Storable a) => a -> (Ptr a -> m b) -> m b 11 | with a action = liftWith $ \ hdl ctx -> U.with a (hdl . (<$ ctx) . action) 12 | -------------------------------------------------------------------------------- /src/GL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | module GL 10 | ( Capability(..) 11 | , Capabilities(..) 12 | , enabled_ 13 | , runGLC 14 | , GLC(..) 15 | ) where 16 | 17 | import Control.Algebra 18 | import Control.Effect.State 19 | import Control.Lens (Lens', lens) 20 | import Control.Monad.IO.Class.Lift 21 | import Data.Foldable (for_) 22 | import qualified Data.Map as Map 23 | import Data.Maybe (fromMaybe) 24 | import GL.Enum as GL 25 | import Graphics.GL.Core41 26 | 27 | data Capability 28 | = Blend -- ^ GL_BLEND 29 | -- ColourLogicOp -- ^ GL_COLOR_LOGIC_OP 30 | -- CullFace -- ^ GL_CULL_FACE 31 | | DepthClamp -- ^ GL_DEPTH_CLAMP 32 | -- DepthTest -- ^ GL_DEPTH_TEST 33 | -- Dither -- ^ GL_DITHER 34 | -- FramebufferSRGB -- ^ GL_FRAMEBUFFER_SRGB 35 | | LineSmooth -- ^ GL_LINE_SMOOTH 36 | -- Multisample -- ^ GL_MULTISAMPLE 37 | -- PolygonOffsetFill -- ^ GL_POLYGON_OFFSET_FILL 38 | -- PolygonOffsetLine -- ^ GL_POLYGON_OFFSET_LINE 39 | -- PolygonOffsetPoint -- ^ GL_POLYGON_OFFSET_POINT 40 | -- PolygonSmooth -- ^ GL_POLYGON_SMOOTH 41 | -- PrimitiveRestart -- ^ GL_PRIMITIVE_RESTART 42 | -- RasterizerDiscard -- ^ GL_RASTERIZER_DISCARD 43 | -- SampleAlphaToCoverage -- ^ GL_SAMPLE_ALPHA_TO_COVERAGE 44 | -- SampleAlphaToOne -- ^ GL_SAMPLE_ALPHA_TO_ONE 45 | -- SampleCoverage -- ^ GL_SAMPLE_COVERAGE 46 | -- SampleShading -- ^ GL_SAMPLE_SHADING 47 | -- SampleMask -- ^ GL_SAMPLE_MASK 48 | | ScissorTest -- ^ GL_SCISSOR_TEST 49 | -- StencilTest -- ^ GL_STENCIL_TEST 50 | -- TextureCubeMapSeamless -- ^ GL_TEXTURE_CUBE_MAP_SEAMLESS 51 | | ProgramPointSize -- ^ GL_PROGRAM_POINT_SIZE 52 | deriving (Eq, Ord, Show) 53 | 54 | instance GL.Enum Capability where 55 | glEnum = \case 56 | Blend -> GL_BLEND 57 | -- ColourLogicOp -> GL_COLOR_LOGIC_OP 58 | -- CullFace -> GL_CULL_FACE 59 | DepthClamp -> GL_DEPTH_CLAMP 60 | -- DepthTest -> GL_DEPTH_TEST 61 | -- Dither -> GL_DITHER 62 | -- FramebufferSRGB -> GL_FRAMEBUFFER_SRGB 63 | LineSmooth -> GL_LINE_SMOOTH 64 | -- Multisample -> GL_MULTISAMPLE 65 | -- PolygonOffsetFill -> GL_POLYGON_OFFSET_FILL 66 | -- PolygonOffsetLine -> GL_POLYGON_OFFSET_LINE 67 | -- PolygonOffsetPoint -> GL_POLYGON_OFFSET_POINT 68 | -- PolygonSmooth -> GL_POLYGON_SMOOTH 69 | -- PrimitiveRestart -> GL_PRIMITIVE_RESTART 70 | -- RasterizerDiscard -> GL_RASTERIZER_DISCARD 71 | -- SampleAlphaToCoverage -> GL_SAMPLE_ALPHA_TO_COVERAGE 72 | -- SampleAlphaToOne -> GL_SAMPLE_ALPHA_TO_ONE 73 | -- SampleCoverage -> GL_SAMPLE_COVERAGE 74 | -- SampleShading -> GL_SAMPLE_SHADING 75 | -- SampleMask -> GL_SAMPLE_MASK 76 | ScissorTest -> GL_SCISSOR_TEST 77 | -- StencilTest -> GL_STENCIL_TEST 78 | -- TextureCubeMapSeamless -> GL_TEXTURE_CUBE_MAP_SEAMLESS 79 | ProgramPointSize -> GL_PROGRAM_POINT_SIZE 80 | 81 | 82 | newtype Capabilities = Capabilities { getCapabilities :: Map.Map Capability Bool } 83 | 84 | enabled_ :: Capability -> Lens' Capabilities Bool 85 | enabled_ cap = lens (get cap) (set cap) where 86 | get cap = fromMaybe False . Map.lookup cap . getCapabilities 87 | set cap (Capabilities caps) v = Capabilities (Map.insert cap v caps) 88 | 89 | 90 | runGLC :: GLC m a -> m a 91 | runGLC (GLC m) = m 92 | 93 | newtype GLC m a = GLC (m a) 94 | deriving (Applicative, Functor, Monad, MonadFail, MonadIO) 95 | 96 | instance Has (Lift IO) sig m => Algebra (State Capabilities :+: sig) (GLC m) where 97 | alg hdl sig ctx = case sig of 98 | L Get -> pure (Capabilities mempty <$ ctx) 99 | L (Put s) -> do 100 | for_ (Map.toList (getCapabilities s)) $ \ (cap, b) -> 101 | runLiftIO $ (if b then glEnable else glDisable) (glEnum cap) 102 | pure ctx 103 | R other -> GLC (alg (runGLC . hdl) other ctx) 104 | -------------------------------------------------------------------------------- /src/GL/Buffer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | module GL.Buffer 10 | ( Buffer(..) 11 | , realloc 12 | , copy 13 | , Type(..) 14 | , KnownType(..) 15 | , Update(..) 16 | , Usage(..) 17 | , bindBuffer 18 | , askBuffer 19 | ) where 20 | 21 | import Control.Carrier.Reader 22 | import Control.Effect.Labelled 23 | import Control.Monad.IO.Class.Lift 24 | import Data.Functor.I 25 | import Data.Functor.Interval 26 | import qualified Foreign.Marshal.Array.Lift as A 27 | import Foreign.Ptr (castPtr, nullPtr) 28 | import Foreign.Storable as S 29 | import GL.Effect.Check 30 | import GL.Enum as GL 31 | import GL.Object 32 | import Graphics.GL.Core41 33 | import Graphics.GL.Types 34 | import Linear.Vector 35 | 36 | newtype Buffer (ty :: Type) v = Buffer { unBuffer :: GLuint } 37 | 38 | instance Object (Buffer ty v) where 39 | gen = defaultGenWith glGenBuffers Buffer 40 | delete = defaultDeleteWith glDeleteBuffers unBuffer 41 | 42 | instance KnownType ty => Bind (Buffer ty v) where 43 | bind = checking . runLiftIO . glBindBuffer (glEnum (typeVal @ty)) . maybe 0 unBuffer 44 | 45 | -- FIXME: Store the current size and don’t reallocate when larger. 46 | realloc :: forall ty v m sig . (HasLabelled (Buffer ty) (Reader (Buffer ty v)) sig m, KnownType ty, S.Storable v, Has (Lift IO) sig m) => Int -> Update -> Usage -> m () 47 | realloc n update usage = askBuffer @ty >> runLiftIO (glBufferData (glEnum (typeVal @ty)) (fromIntegral (n * S.sizeOf @v undefined)) nullPtr (glEnum (Hint update usage))) 48 | 49 | copy :: forall ty v m sig . (HasLabelled (Buffer ty) (Reader (Buffer ty v)) sig m, KnownType ty, S.Storable v, Has Check sig m, Has (Lift IO) sig m) => Int -> [v] -> m () 50 | copy offset vertices = askBuffer @ty >> A.withArray vertices 51 | (checking . runLiftIO . glBufferSubData (glEnum (typeVal @ty)) (fromIntegral (inf i)) (fromIntegral (size i)) . castPtr) where 52 | i = ((0...length vertices) + point (I offset)) ^* S.sizeOf @v undefined 53 | 54 | 55 | data Type 56 | = Array 57 | | ElementArray 58 | deriving (Eq, Ord, Show) 59 | 60 | class KnownType (ty :: Type) where 61 | typeVal :: Type 62 | 63 | instance KnownType 'Array where 64 | typeVal = Array 65 | 66 | instance KnownType 'ElementArray where 67 | typeVal = ElementArray 68 | 69 | instance GL.Enum Type where 70 | glEnum = \case 71 | Array -> GL_ARRAY_BUFFER 72 | ElementArray -> GL_ELEMENT_ARRAY_BUFFER 73 | 74 | 75 | data Update 76 | = Static 77 | | Dynamic 78 | | Stream 79 | deriving (Eq, Ord, Show) 80 | 81 | data Usage 82 | = Draw 83 | | Read 84 | | Copy 85 | deriving (Eq, Ord, Show) 86 | 87 | data Hint = Hint Update Usage 88 | 89 | instance GL.Enum Hint where 90 | glEnum = \case 91 | Hint Static Draw -> GL_STATIC_DRAW 92 | Hint Static Read -> GL_STATIC_READ 93 | Hint Static Copy -> GL_STATIC_COPY 94 | Hint Dynamic Draw -> GL_DYNAMIC_DRAW 95 | Hint Dynamic Read -> GL_DYNAMIC_READ 96 | Hint Dynamic Copy -> GL_DYNAMIC_COPY 97 | Hint Stream Draw -> GL_STREAM_DRAW 98 | Hint Stream Read -> GL_STREAM_READ 99 | Hint Stream Copy -> GL_STREAM_COPY 100 | 101 | 102 | bindBuffer :: (KnownType ty, Has Check sig m, Has (Lift IO) sig m) => Buffer ty v -> BufferC ty v m a -> m a 103 | bindBuffer buffer m = do 104 | bind (Just buffer) 105 | a <- runReader buffer (runLabelled m) 106 | a <$ bind (Nothing `asTypeOf` Just buffer) 107 | 108 | askBuffer :: forall ty v m sig . HasLabelled (Buffer ty) (Reader (Buffer ty v)) sig m => m (Buffer ty v) 109 | askBuffer = runUnderLabel @(Buffer ty) ask 110 | 111 | type BufferC ty v = Labelled (Buffer ty) (ReaderC (Buffer ty v)) 112 | -------------------------------------------------------------------------------- /src/GL/Carrier/Bind.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | module GL.Carrier.Bind 8 | ( -- * Bind carrier 9 | runBind 10 | , BindC(BindC) 11 | -- * Bind effect 12 | , module GL.Effect.Bind 13 | ) where 14 | 15 | import Control.Algebra 16 | import Control.Carrier.Reader 17 | import Control.Effect.Lift 18 | import Control.Monad.IO.Class 19 | import GL.Effect.Bind 20 | import GL.Effect.Check 21 | import qualified GL.Object as GL 22 | 23 | runBind :: BindC t m a -> m a 24 | runBind = runReader Nothing . runBindC 25 | 26 | newtype BindC t m a = BindC { runBindC :: ReaderC (Maybe t) m a } 27 | deriving (Applicative, Functor, Monad, MonadIO) 28 | 29 | instance (Has Check sig m, Has (Lift IO) sig m, GL.Bind t) => Algebra (Bind t :+: sig) (BindC t m) where 30 | alg hdl sig ctx = case sig of 31 | L (Bind t m) -> do 32 | prev <- BindC ask 33 | GL.bind (Just t) 34 | a <- BindC (local (const (Just t)) (runBindC (hdl (m <$ ctx)))) 35 | a <$ GL.bind (prev `asTypeOf` Just t) 36 | R other -> BindC (alg (runBindC . hdl) (R other) ctx) 37 | -------------------------------------------------------------------------------- /src/GL/Carrier/Check/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE ImplicitParams #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | module GL.Carrier.Check.IO 10 | ( -- * Check carrier 11 | runCheck 12 | , CheckC(CheckC) 13 | -- * Check effect 14 | , module GL.Effect.Check 15 | ) where 16 | 17 | import Control.Algebra 18 | import Control.Monad.Fix 19 | import Control.Monad.IO.Class.Lift 20 | import Data.Foldable (toList) 21 | import GHC.Stack 22 | import GL.Effect.Check 23 | import GL.Error 24 | import Graphics.GL.Core41 25 | 26 | newtype CheckC m a = CheckC { runCheck :: m a } 27 | deriving (Applicative, Functor, Monad, MonadFail, MonadFix, MonadIO) 28 | 29 | instance Has (Lift IO) sig m => Algebra (Check :+: sig) (CheckC m) where 30 | alg hdl sig ctx = case sig of 31 | L (Check loc) -> do 32 | err <- runLiftIO glGetError 33 | ctx <$ case err of 34 | GL_NO_ERROR -> pure () 35 | other -> withCallStack (fromCallSiteList (toList loc)) (withFrozenCallStack (throwGLError other)) 36 | R other -> CheckC (alg (runCheck . hdl) other ctx) 37 | 38 | withCallStack :: CallStack -> (HasCallStack => a) -> a 39 | withCallStack callStack a = let ?callStack = callStack in a 40 | -------------------------------------------------------------------------------- /src/GL/Carrier/Check/Identity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | module GL.Carrier.Check.Identity 9 | ( -- * Check carrier 10 | runCheck 11 | , CheckC(CheckC) 12 | -- * Check effect 13 | , module GL.Effect.Check 14 | ) where 15 | 16 | import Control.Algebra 17 | import Control.Monad.Fix 18 | import Control.Monad.IO.Class 19 | import GL.Effect.Check 20 | 21 | newtype CheckC m a = CheckC { runCheck :: m a } 22 | deriving (Applicative, Functor, Monad, MonadFail, MonadFix, MonadIO) 23 | 24 | instance Algebra sig m => Algebra (Check :+: sig) (CheckC m) where 25 | alg hdl = \case 26 | L (Check _) -> pure 27 | R other -> CheckC . alg (runCheck . hdl) other 28 | -------------------------------------------------------------------------------- /src/GL/Effect/Bind.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | module GL.Effect.Bind 3 | ( -- * Bind effect 4 | bind 5 | , Bind(..) 6 | -- * Re-exports 7 | , Algebra 8 | , Has 9 | , run 10 | ) where 11 | 12 | import Control.Algebra 13 | 14 | bind :: Has (Bind t) sig m => t -> m a -> m a 15 | bind t m = send (Bind t m) 16 | 17 | data Bind t m k where 18 | Bind :: t -> m a -> Bind t m a 19 | -------------------------------------------------------------------------------- /src/GL/Effect/Check.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | module GL.Effect.Check 4 | ( -- * Check effect 5 | check 6 | , checking 7 | , Check(..) 8 | -- * Re-export 9 | , Algebra 10 | , Has 11 | , run 12 | ) where 13 | 14 | import Control.Algebra 15 | import Data.Kind (Type) 16 | import Data.Maybe (listToMaybe) 17 | import GHC.Stack 18 | 19 | check :: (Has Check sig m, HasCallStack) => m () 20 | check = send (Check (listToMaybe (getCallStack callStack))) 21 | 22 | checking :: (Has Check sig m, HasCallStack) => m a -> m a 23 | checking action = withFrozenCallStack $ action <* check 24 | 25 | data Check (m :: Type -> Type) k where 26 | Check :: Maybe (String, SrcLoc) -> Check m () 27 | -------------------------------------------------------------------------------- /src/GL/Enum.hs: -------------------------------------------------------------------------------- 1 | module GL.Enum 2 | ( Enum(..) 3 | ) where 4 | 5 | import Graphics.GL.Types 6 | import Prelude hiding (Enum) 7 | 8 | class Enum t where 9 | glEnum :: t -> GLenum 10 | -------------------------------------------------------------------------------- /src/GL/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module GL.Error 3 | ( GLError(..) 4 | , GLException(..) 5 | , checkStatus 6 | , throwGLError 7 | ) where 8 | 9 | import qualified Control.Exception.Lift as E 10 | import Control.Monad 11 | import Control.Monad.IO.Class.Lift 12 | import qualified Foreign.C.String as C 13 | import qualified Foreign.Marshal.Alloc.Lift as A 14 | import Foreign.Ptr 15 | import qualified Foreign.Storable as S 16 | import GHC.Stack 17 | import Graphics.GL.Core41 18 | import Graphics.GL.Types 19 | 20 | data GLError 21 | = InvalidEnum 22 | | InvalidValue 23 | | InvalidOperation 24 | | InvalidFramebufferOperation 25 | | OutOfMemory 26 | | FramebufferIncompleteAttachment 27 | -- | FramebufferIncompleteDimensions 28 | | FramebufferIncompleteMissingAttachment 29 | | FramebufferUnsupported 30 | | Source String String 31 | | Other String 32 | 33 | instance Show GLError where 34 | showsPrec _ = \case 35 | InvalidEnum -> showString "GL_INVALID_ENUM" 36 | InvalidValue -> showString "GL_INVALID_VALUE" 37 | InvalidOperation -> showString "GL_INVALID_OPERATION" 38 | InvalidFramebufferOperation -> showString "GL_INVALID_FRAMEBUFFER_OPERATION" 39 | OutOfMemory -> showString "GL_OUT_OF_MEMORY" 40 | FramebufferIncompleteAttachment -> showString "GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT" 41 | -- FramebufferIncompleteDimensions -> showString "GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS" 42 | FramebufferIncompleteMissingAttachment -> showString "GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT" 43 | FramebufferUnsupported -> showString "GL_FRAMEBUFFER_UNSUPPORTED" 44 | Source s t -> showString s . showChar '\n' . showString t 45 | Other s -> showString s 46 | 47 | 48 | data GLException = GLException GLError CallStack 49 | 50 | instance Show GLException where 51 | showsPrec p (GLException e s) = showString "GLException " . showsPrec p e . showChar '\n' . showString (prettyCallStack s) 52 | 53 | instance E.Exception GLException 54 | 55 | 56 | checkStatus :: (Has (Lift IO) sig m, HasCallStack) 57 | => (GLenum -> GLuint -> Ptr GLint -> m ()) 58 | -> (GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> m ()) 59 | -> (String -> GLError) 60 | -> GLenum 61 | -> GLuint 62 | -> m () 63 | checkStatus get getLog error status object = withFrozenCallStack $ do 64 | success <- A.alloca $ \ p -> do 65 | get object status p 66 | sendM (S.peek p) 67 | when (success == GL_FALSE) $ do 68 | l <- A.alloca $ \ p -> do 69 | get object GL_INFO_LOG_LENGTH p 70 | sendM (S.peek p) 71 | log <- A.allocaBytes (fromIntegral l) $ \ bytes -> do 72 | getLog object l nullPtr bytes 73 | sendM (C.peekCString bytes) 74 | E.throwIO $ GLException (error log) callStack 75 | 76 | throwGLError :: (Has (Lift IO) sig m, HasCallStack) => GLenum -> m () 77 | throwGLError = \case 78 | GL_NO_ERROR -> pure () 79 | GL_INVALID_ENUM -> E.throwIO $ GLException InvalidEnum callStack 80 | GL_INVALID_VALUE -> E.throwIO $ GLException InvalidValue callStack 81 | GL_INVALID_OPERATION -> E.throwIO $ GLException InvalidOperation callStack 82 | GL_INVALID_FRAMEBUFFER_OPERATION -> E.throwIO $ GLException InvalidFramebufferOperation callStack 83 | GL_OUT_OF_MEMORY -> E.throwIO $ GLException OutOfMemory callStack 84 | GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT -> E.throwIO $ GLException FramebufferIncompleteAttachment callStack 85 | -- GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS -> E.throwIO $ GLException FramebufferIncompleteDimensions callStack 86 | GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT -> E.throwIO $ GLException FramebufferIncompleteMissingAttachment callStack 87 | GL_FRAMEBUFFER_UNSUPPORTED -> E.throwIO $ GLException FramebufferUnsupported callStack 88 | _ -> E.throwIO $ GLException (Other "Unknown") callStack 89 | -------------------------------------------------------------------------------- /src/GL/Framebuffer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module GL.Framebuffer 4 | ( Framebuffer(..) 5 | , Attachment(..) 6 | , attachTexture 7 | , Bind(..) 8 | ) where 9 | 10 | import Control.Monad (unless) 11 | import Control.Monad.IO.Class.Lift 12 | import Data.Proxy 13 | import GHC.Stack 14 | import GL.Effect.Check 15 | import GL.Enum as GL 16 | import GL.Error 17 | import GL.Object 18 | import qualified GL.Texture as GL 19 | import Graphics.GL.Core41 20 | import Graphics.GL.Types 21 | 22 | newtype Framebuffer = Framebuffer { unFramebuffer :: GLuint } 23 | 24 | instance Object Framebuffer where 25 | gen = defaultGenWith glGenFramebuffers Framebuffer 26 | delete = defaultDeleteWith glDeleteFramebuffers unFramebuffer 27 | 28 | instance Bind Framebuffer where 29 | bind = checking . runLiftIO . glBindFramebuffer GL_FRAMEBUFFER . maybe 0 unFramebuffer 30 | 31 | 32 | newtype Attachment 33 | = Colour Int 34 | 35 | instance GL.Enum Attachment where 36 | glEnum = \case 37 | Colour n -> GL_COLOR_ATTACHMENT0 + fromIntegral n 38 | 39 | 40 | attachTexture :: forall ty sig m . (HasCallStack, Has Check sig m, Has (Lift IO) sig m) => GL.KnownType ty => Attachment -> GL.Texture ty -> m () 41 | attachTexture attachment (GL.Texture texture) = runLiftIO $ do 42 | checking $ glFramebufferTexture2D GL_FRAMEBUFFER (glEnum attachment) (glEnum (GL.typeVal (Proxy :: Proxy ty))) texture 0 43 | status <- glCheckFramebufferStatus GL_FRAMEBUFFER 44 | unless (status == GL_FRAMEBUFFER_COMPLETE) (throwGLError status) 45 | -------------------------------------------------------------------------------- /src/GL/Object.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module GL.Object 3 | ( Object(..) 4 | , Bind(..) 5 | , genN 6 | , gen1 7 | , defaultGenWith 8 | , defaultDeleteWith 9 | ) where 10 | 11 | import Control.Carrier.Lift 12 | import Control.Effect.Finally 13 | import qualified Foreign.Marshal.Array.Lift as A 14 | import Foreign.Ptr 15 | import GHC.Stack 16 | import GL.Effect.Check 17 | import Graphics.GL.Types 18 | 19 | class Object t where 20 | gen :: (Has (Lift IO) sig m, HasCallStack) => Int -> Ptr GLuint -> m [t] 21 | delete :: (Has (Lift IO) sig m, HasCallStack) => [t] -> Ptr GLuint -> m () 22 | 23 | class Bind t where 24 | bind :: (Has Check sig m, Has (Lift IO) sig m, HasCallStack) => Maybe t -> m () 25 | 26 | genN :: (Object t, Has Finally sig m, Has (Lift IO) sig m) => Int -> m [t] 27 | genN n = do 28 | ts <- acquire 29 | ts <$ onExit (release ts) where 30 | acquire = A.allocaArray n $ gen n 31 | release ts = A.allocaArray n $ delete ts 32 | 33 | gen1 :: (Object t, Has Finally sig m, Has (Lift IO) sig m) => m t 34 | gen1 = head <$> genN 1 35 | 36 | 37 | defaultGenWith :: Has (Lift IO) sig m => (GLsizei -> Ptr GLuint -> IO ()) -> (GLuint -> t) -> Int -> Ptr GLuint -> m [t] 38 | defaultGenWith with make n ptr = sendM (with (fromIntegral n) ptr) >> map make <$> A.peekArray n ptr 39 | 40 | defaultDeleteWith :: Has (Lift IO) sig m => (GLsizei -> Ptr GLuint -> IO ()) -> (t -> GLuint) -> [t] -> Ptr GLuint -> m () 41 | defaultDeleteWith with get bs ptr = A.pokeArray ptr (map get bs) >> sendM (with (fromIntegral (length bs)) ptr) 42 | -------------------------------------------------------------------------------- /src/GL/Primitive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module GL.Primitive 3 | ( Type(..) 4 | ) where 5 | 6 | import GL.Enum as GL 7 | import Graphics.GL.Core41 8 | 9 | data Type 10 | = Points 11 | | Lines 12 | | LineStrip 13 | | LineLoop 14 | | TriangleStrip 15 | | Triangles 16 | deriving (Eq, Show) 17 | 18 | instance GL.Enum Type where 19 | glEnum = \case 20 | Points -> GL_POINTS 21 | Lines -> GL_LINES 22 | LineStrip -> GL_LINE_STRIP 23 | LineLoop -> GL_LINE_LOOP 24 | TriangleStrip -> GL_TRIANGLE_STRIP 25 | Triangles -> GL_TRIANGLES 26 | -------------------------------------------------------------------------------- /src/GL/Program.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE NamedFieldPuns #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | module GL.Program 13 | ( Program(..) 14 | , build 15 | , use 16 | , askProgram 17 | , ProgramC(..) 18 | ) where 19 | 20 | import Control.Carrier.Reader 21 | import Control.Carrier.State.Church 22 | import Control.Effect.Finally 23 | import Control.Effect.Labelled 24 | import Control.Effect.Sum 25 | import Control.Monad.IO.Class.Lift 26 | import Control.Monad.Trans.Class 27 | import Data.Foldable (for_) 28 | import Data.Kind (Type) 29 | import qualified Data.IntMap as IntMap 30 | import Data.Traversable (for) 31 | import qualified Foreign.C.String.Lift as C 32 | import GHC.Stack 33 | import GL.Effect.Check 34 | import GL.Error 35 | import GL.Shader 36 | import qualified GL.Shader.DSL as DSL 37 | import GL.Shader.Vars 38 | import GL.Uniform 39 | import Graphics.GL.Core41 40 | import Graphics.GL.Types 41 | 42 | data Program (u :: (Type -> Type) -> Type) (i :: (Type -> Type) -> Type) (o :: (Type -> Type) -> Type) = Program 43 | { locations :: IntMap.IntMap GLint 44 | , unProgram :: GLuint 45 | } 46 | 47 | 48 | build :: forall u v o m sig . (HasCallStack, Has Check sig m, Has Finally sig m, Has (Lift IO) sig m, Vars u, Vars v) => DSL.RShader u v o -> m (Program u v o) 49 | build p = runLiftIO $ do 50 | program <- glCreateProgram 51 | onExit (glDeleteProgram program) 52 | foldVarsM @v (\ Field { name, location } -> checking $ 53 | C.withCString name (glBindAttribLocation program (fromIntegral location))) defaultVars 54 | shaders <- for (DSL.shaderSources p) $ \ (type', source) -> do 55 | shader <- createShader type' 56 | shader <$ compile source shader 57 | 58 | for_ shaders (glAttachShader program . unShader) 59 | glLinkProgram program 60 | for_ shaders (glDetachShader program . unShader) 61 | 62 | checkStatus glGetProgramiv glGetProgramInfoLog Other GL_LINK_STATUS program 63 | 64 | ls <- foldVarsM @u (\ Field{ name, location } -> do 65 | loc <- checking $ C.withCString name (glGetUniformLocation program) 66 | pure (IntMap.singleton location loc)) defaultVars 67 | 68 | pure (Program ls program) 69 | 70 | use :: Has (Lift IO) sig m => Program u v o -> ProgramC u v o m a -> m a 71 | use (Program ls p) m = do 72 | sendIO (glUseProgram p) 73 | runReader (Program ls p) (runProgramC m) 74 | 75 | 76 | askProgram :: HasLabelled Program (Reader (Program u v o)) sig m => m (Program u v o) 77 | askProgram = runUnderLabel @Program ask 78 | 79 | 80 | newtype ProgramC (u :: (Type -> Type) -> Type) (v :: (Type -> Type) -> Type) (o :: (Type -> Type) -> Type) m a = ProgramC { runProgramC :: ReaderC (Program u v o) m a } 81 | deriving (Applicative, Functor, Monad, MonadFail, MonadIO, MonadTrans) 82 | 83 | instance (Has Check sig m, Has (Lift IO) sig m, Vars u) => Algebra (State (u Maybe) :+: Labelled Program (Reader (Program u v o)) :+: sig) (ProgramC u v o m) where 84 | alg hdl sig ctx = case sig of 85 | L Get -> pure (makeVars (const Nothing) <$ ctx) 86 | L (Put s) -> do 87 | Program ls prog <- askProgram 88 | foldVarsM (\ Field{ location, value } -> 89 | maybe (pure ()) (checking . uniform prog (ls IntMap.! location)) value) s 90 | pure ctx 91 | R (L other) -> ProgramC (alg (runProgramC . hdl) (inj (runLabelled other)) ctx) 92 | R (R other) -> ProgramC (alg (runProgramC . hdl) (R other) ctx) 93 | -------------------------------------------------------------------------------- /src/GL/Shader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | module GL.Shader 6 | ( Shader(..) 7 | , Stage(..) 8 | , KnownStage(..) 9 | , createShader 10 | , compile 11 | , checkShader 12 | ) where 13 | 14 | import Control.Effect.Finally 15 | import Control.Monad.IO.Class.Lift 16 | import qualified Foreign.C.String.Lift as C 17 | import qualified Foreign.Marshal.Utils.Lift as U 18 | import Foreign.Ptr 19 | import GHC.Stack 20 | import qualified GL.Enum as GL 21 | import GL.Error 22 | import Graphics.GL.Core41 23 | import Graphics.GL.Types 24 | 25 | newtype Shader = Shader { unShader :: GLuint } 26 | 27 | data Stage 28 | = Vertex 29 | | Geometry 30 | | Fragment 31 | deriving (Eq, Ord, Show) 32 | 33 | instance GL.Enum Stage where 34 | glEnum = \case 35 | Vertex -> GL_VERTEX_SHADER 36 | Geometry -> GL_GEOMETRY_SHADER 37 | Fragment -> GL_FRAGMENT_SHADER 38 | 39 | 40 | class KnownStage (k :: Stage) where 41 | typeVal :: proxy k -> Stage 42 | 43 | instance KnownStage 'Vertex where 44 | typeVal _ = Vertex 45 | 46 | instance KnownStage 'Fragment where 47 | typeVal _ = Fragment 48 | 49 | 50 | createShader :: (Has Finally sig m, Has (Lift IO) sig m) => Stage -> m Shader 51 | createShader type' = do 52 | shader <- runLiftIO (glCreateShader (GL.glEnum type')) 53 | Shader shader <$ onExit (runLiftIO (glDeleteShader shader)) 54 | 55 | compile :: (Has (Lift IO) sig m, HasCallStack) => String -> Shader -> m () 56 | compile source (Shader shader) = runLiftIO $ do 57 | C.withCString source $ \ source -> 58 | U.with source $ \ p -> 59 | glShaderSource shader 1 p nullPtr 60 | glCompileShader shader 61 | checkShader source (Shader shader) 62 | 63 | checkShader :: (Has (Lift IO) sig m, HasCallStack) => String -> Shader -> m () 64 | checkShader source = withFrozenCallStack $ runLiftIO . checkStatus glGetShaderiv glGetShaderInfoLog (Source source) GL_COMPILE_STATUS . unShader 65 | -------------------------------------------------------------------------------- /src/GL/Texture.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | module GL.Texture 7 | ( Texture(..) 8 | , Type(..) 9 | , KnownType(..) 10 | , InternalFormat(..) 11 | , PixelFormat(..) 12 | , PixelType(..) 13 | , setImageFormat 14 | , FilterType(..) 15 | , Filter(..) 16 | , WrapCoord(..) 17 | , Wrap(..) 18 | , setParameter 19 | , Parameter 20 | ) where 21 | 22 | import Control.Monad.IO.Class.Lift 23 | import Data.Proxy 24 | import Foreign.Ptr (nullPtr) 25 | import GHC.Stack 26 | import GL.Enum as GL 27 | import GL.Effect.Check 28 | import GL.Object 29 | import Graphics.GL.Core41 30 | import Graphics.GL.Types 31 | import Linear.V2 32 | 33 | newtype Texture (ty :: Type) = Texture { unTexture :: GLuint } 34 | 35 | instance Object (Texture ty) where 36 | gen = defaultGenWith glGenTextures Texture 37 | delete = defaultDeleteWith glDeleteTextures unTexture 38 | 39 | instance KnownType ty => Bind (Texture ty) where 40 | bind = checking . runLiftIO . glBindTexture (glEnum (typeVal (Proxy :: Proxy ty))) . maybe 0 unTexture 41 | 42 | 43 | data Type 44 | = Texture2D 45 | deriving (Eq, Ord, Show) 46 | 47 | class KnownType (ty :: Type) where 48 | typeVal :: proxy ty -> Type 49 | 50 | instance KnownType 'Texture2D where 51 | typeVal _ = Texture2D 52 | 53 | instance GL.Enum Type where 54 | glEnum = \case 55 | Texture2D -> GL_TEXTURE_2D 56 | 57 | 58 | data InternalFormat 59 | = RGBA8 60 | 61 | instance GL.Enum InternalFormat where 62 | glEnum = \case 63 | RGBA8 -> GL_RGBA8 64 | 65 | data PixelFormat 66 | = RGBA 67 | 68 | instance GL.Enum PixelFormat where 69 | glEnum = \case 70 | RGBA -> GL_RGBA 71 | 72 | newtype PixelType 73 | = Packed8888 Bool 74 | 75 | instance GL.Enum PixelType where 76 | glEnum = \case 77 | Packed8888 False -> GL_UNSIGNED_INT_8_8_8_8 78 | Packed8888 True -> GL_UNSIGNED_INT_8_8_8_8_REV 79 | 80 | setImageFormat :: (Integral a, HasCallStack, Has Check sig m, Has (Lift IO) sig m) => Type -> InternalFormat -> V2 a -> PixelFormat -> PixelType -> m () 81 | setImageFormat target internalFormat (V2 width height) pixelFormat pixelType = checking . runLiftIO $ glTexImage2D (glEnum target) 0 (fromIntegral (glEnum internalFormat)) (fromIntegral width) (fromIntegral height) 0 (glEnum pixelFormat) (glEnum pixelType) nullPtr 82 | 83 | 84 | data FilterType = MinFilter | MagFilter 85 | 86 | instance GL.Enum FilterType where 87 | glEnum = \case 88 | MinFilter -> GL_TEXTURE_MIN_FILTER 89 | MagFilter -> GL_TEXTURE_MAG_FILTER 90 | 91 | 92 | data Filter = Nearest | Linear 93 | 94 | instance GL.Enum Filter where 95 | glEnum = \case 96 | Nearest -> GL_NEAREST 97 | Linear -> GL_LINEAR 98 | 99 | 100 | data WrapCoord = WrapR | WrapS | WrapT 101 | 102 | instance GL.Enum WrapCoord where 103 | glEnum = \case 104 | WrapR -> GL_TEXTURE_WRAP_R 105 | WrapS -> GL_TEXTURE_WRAP_S 106 | WrapT -> GL_TEXTURE_WRAP_T 107 | 108 | 109 | data Wrap 110 | = Repeat 111 | | MirroredRepeat 112 | | ClampToEdge 113 | | ClampToBorder 114 | 115 | instance GL.Enum Wrap where 116 | glEnum = \case 117 | Repeat -> GL_REPEAT 118 | MirroredRepeat -> GL_MIRRORED_REPEAT 119 | ClampToEdge -> GL_CLAMP_TO_EDGE 120 | ClampToBorder -> GL_CLAMP_TO_BORDER 121 | 122 | 123 | setParameter :: (Parameter val param, Has Check sig m, Has (Lift IO) sig m) => Type -> param -> val -> m () 124 | setParameter target param = checking . runLiftIO . glTexParameteri (glEnum target) (glEnum param) . fromIntegral . glEnum 125 | 126 | class (GL.Enum param, GL.Enum val) => Parameter val param | param -> val 127 | 128 | instance Parameter Filter FilterType 129 | instance Parameter Wrap WrapCoord 130 | -------------------------------------------------------------------------------- /src/GL/TextureUnit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module GL.TextureUnit 3 | ( TextureUnit(..) 4 | , setActiveTexture 5 | ) where 6 | 7 | import Control.Monad.IO.Class.Lift 8 | import Foreign.Storable 9 | import GL.Type as GL 10 | import GL.Uniform 11 | import Graphics.GL.Core41 12 | import Graphics.GL.Types 13 | 14 | newtype TextureUnit = TextureUnit { unTextureUnit :: GLint } 15 | deriving (Storable) 16 | 17 | instance GL.Type TextureUnit where 18 | glType = GL_INT 19 | 20 | instance Uniform TextureUnit where 21 | glslType = "sampler2D" 22 | uniform prog loc = runLiftIO . glProgramUniform1i prog loc . unTextureUnit 23 | 24 | 25 | setActiveTexture :: Has (Lift IO) sig m => TextureUnit -> m () 26 | setActiveTexture (TextureUnit i) = runLiftIO $ glActiveTexture (fromIntegral (GL_TEXTURE0 + i)) 27 | -------------------------------------------------------------------------------- /src/GL/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | module GL.Type 4 | ( Type(..) 5 | ) where 6 | 7 | import Data.Int 8 | import Data.Functor.Const 9 | import Data.Functor.Identity 10 | import Data.Functor.K 11 | import qualified Foreign.Storable as S 12 | import Graphics.GL.Core41 13 | import Graphics.GL.Types 14 | import Linear.Affine 15 | import Linear.V1 16 | import Linear.V2 17 | import Linear.V3 18 | import Linear.V4 19 | 20 | class S.Storable n => Type n where 21 | glType :: K GLenum n 22 | 23 | glDims :: K GLint n 24 | glDims = 1 25 | 26 | instance Type Bool where 27 | glType = GL_BOOL 28 | 29 | instance Type Float where 30 | glType = GL_FLOAT 31 | 32 | instance Type Double where 33 | glType = GL_DOUBLE 34 | 35 | instance Type Int where 36 | glType = GL_INT 37 | 38 | instance Type Int32 where 39 | glType = GL_INT 40 | 41 | instance Type a => Type (V1 a) where 42 | glType = pure <$> glType 43 | 44 | glDims = pure <$> glDims 45 | 46 | instance Type a => Type (V2 a) where 47 | glType = pure <$> glType 48 | 49 | glDims = pure <$> 2 * glDims 50 | 51 | instance Type a => Type (V3 a) where 52 | glType = pure <$> glType 53 | 54 | glDims = pure <$> 3 * glDims 55 | 56 | instance Type a => Type (V4 a) where 57 | glType = pure <$> glType 58 | 59 | glDims = pure <$> 4 * glDims 60 | 61 | instance Type (f a) => Type (Point f a) where 62 | glType = P <$> glType 63 | 64 | glDims = P <$> glDims 65 | 66 | deriving instance Type a => Type (Const a b) 67 | deriving instance Type a => Type (Identity a) 68 | deriving instance Type a => Type (K a b) 69 | -------------------------------------------------------------------------------- /src/GL/Viewport.hs: -------------------------------------------------------------------------------- 1 | module GL.Viewport 2 | ( viewport 3 | , scissor 4 | ) where 5 | 6 | import Control.Monad.IO.Class.Lift 7 | import Data.Functor.Interval 8 | import Graphics.GL.Core41 9 | import Linear.V2 10 | 11 | viewport :: (Integral a, Has (Lift IO) sig m) => Interval V2 a -> m () 12 | viewport i = runLiftIO (glViewport x y w h) where 13 | V2 x y = fromIntegral <$> inf i 14 | V2 w h = fromIntegral <$> size i 15 | 16 | scissor :: (Integral a, Has (Lift IO) sig m) => Interval V2 a -> m () 17 | scissor i = runLiftIO (glScissor x y w h) where 18 | V2 x y = fromIntegral <$> inf i 19 | V2 w h = fromIntegral <$> size i 20 | -------------------------------------------------------------------------------- /src/Geometry/Circle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | module Geometry.Circle 5 | ( circle 6 | , intersects 7 | , intersections 8 | , circumference 9 | , area 10 | , surfaceArea 11 | , volume 12 | ) where 13 | 14 | import Control.Monad (guard) 15 | import Data.Maybe (isJust) 16 | import Linear.Exts 17 | import Unit 18 | import Unit.Algebra 19 | import Unit.Length 20 | 21 | -- | Construct vertices for a circle. 22 | circle 23 | :: (Floating a, Unit d u) 24 | => u a -- ^ The radius. 25 | -> Int -- ^ The number of vertices to produce. 26 | -> [V2 (u a)] -- ^ The vertices for the circle. 27 | circle radius n = 28 | [ cartesian2 theta radius 29 | | i <- [0..pred n] 30 | , let theta = 2 * pi * fromIntegral i / fromIntegral n 31 | ] 32 | 33 | 34 | intersects 35 | :: (Floating a, Metric v, Unit d l, Ord a) 36 | => v (l a) -- ^ Sphere centre. 37 | -> l a -- ^ Sphere radius. 38 | -> v (l a) -- ^ Ray origin. 39 | -> v (l a) -- ^ Ray direction (unit vector). 40 | -> Bool 41 | intersects c r o l = isJust $ do 42 | (d1, d2) <- intersections c r o l 43 | guard (d1 >= 0 || d2 >= 0) 44 | 45 | intersections 46 | :: (Floating a, Metric v, Unit d l, Ord a) 47 | => v (l a) -- ^ Sphere centre. 48 | -> l a -- ^ Sphere radius. 49 | -> v (l a) -- ^ Ray origin. 50 | -> v (l a) -- ^ Ray direction (unit vector). 51 | -> Maybe (l a, l a) 52 | intersections c r o l = (d1, d2) <$ guard (discriminant >= 0) where 53 | o_c = o ^-^ c 54 | discriminant = b ** 2 - (quadrance o_c - r ** 2) 55 | b = l `dot` o_c 56 | root = sqrt discriminant 57 | (d1, d2) = (-b) ± root 58 | a ± b = (a + b, a - b) 59 | 60 | 61 | circumference :: (Unit Length length, Floating a) => length a -> length a 62 | circumference r = 2 * pi * r 63 | 64 | area :: (Unit Length length, Floating a) => length a -> (length :^: 2) a 65 | area r = I pi .*. sqU r 66 | 67 | surfaceArea :: (Unit Length length, Floating a) => length a -> (length :^: 2) a 68 | surfaceArea r = I (4 * pi) .*. sqU r 69 | 70 | volume :: (Unit Length length, Floating a) => length a -> (length :^: 3) a 71 | volume r = I (4 / 3 * pi) .*. cuU r 72 | -------------------------------------------------------------------------------- /src/Geometry/Transform.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitForAll #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# OPTIONS_GHC -Wno-redundant-constraints #-} 8 | module Geometry.Transform 9 | ( Transform(..) 10 | , mkTranslation 11 | , mkScale 12 | , mkRotation 13 | , apply 14 | , tmap 15 | , (>>>) 16 | , (<<<) 17 | , (<*<) 18 | , (>*>) 19 | , (>*) 20 | ) where 21 | 22 | import Control.Category 23 | import Control.Lens ((&), (.~)) 24 | import Data.Coerce 25 | import Data.Functor.I 26 | import Data.Functor.Rep 27 | import Data.Kind (Type) 28 | import Foreign.Storable 29 | import qualified GL.Type as GL 30 | import GL.Uniform 31 | import Linear.Exts 32 | import Prelude hiding ((.)) 33 | import Unit 34 | import Unit.Algebra 35 | 36 | newtype Transform m c (a :: Type -> Type) (b :: Type -> Type) = Transform { getTransform :: m (m c) } 37 | 38 | deriving instance Show (m (m c)) => Show (Transform m c a b) 39 | deriving instance Storable (m (m c)) => Storable (Transform m c a b) 40 | deriving instance GL.Type (m (m c)) => GL.Type (Transform m c a b) 41 | deriving instance Uniform (m (m c)) => Uniform (Transform m c a b) 42 | 43 | instance (Num c, Additive m, Applicative m, Traversable m) => Category (Transform m c) where 44 | id = Transform identity 45 | Transform a . Transform b = Transform (a !*! b) 46 | 47 | mkTranslation :: (Num c, Unit d u, Applicative m, R4 m, Representable m, Traversable m) => V3 (u c) -> Transform m c u u 48 | mkTranslation v = Transform (identity & translation .~ fmap prj v) 49 | 50 | mkScale :: forall u v c du dv d' . (Num c, Unit du u, Unit dv v, Unit d' (Div u v)) => V3 (Div u v c) -> Transform V4 c v u 51 | mkScale v = Transform (scaled (point (prj <$> v))) 52 | 53 | mkRotation :: Num c => Quaternion (I c) -> Transform V4 c a a 54 | mkRotation q = Transform (identity !*! mkTransformation (coerce q) 0) 55 | 56 | apply :: (Num c, Unit d a, Unit d b, Additive m, Foldable m) => Transform m c a b -> m (a c) -> m (b c) 57 | apply (Transform m) v = pure <$> (m !* fmap prj v) 58 | 59 | tmap :: Functor m => (c -> c') -> Transform m c a b -> Transform m c' a b 60 | tmap f = Transform . fmap (fmap f) . getTransform 61 | 62 | (<*<) :: (Num a, Additive m, Applicative m, Traversable m) => Transform m a v w -> Transform m a u v -> Transform m a u w 63 | (<*<) = (<<<) 64 | 65 | (>*>) :: (Num a, Additive m, Applicative m, Traversable m) => Transform m a u v -> Transform m a v w -> Transform m a u w 66 | (>*>) = (>>>) 67 | 68 | (>*) :: (Num a, Unit d u, Unit d v, Additive m, Foldable m) => Transform m a u v -> m (u a) -> m (v a) 69 | (>*) = apply 70 | 71 | infixl 7 <*<, >*>, >* 72 | -------------------------------------------------------------------------------- /src/Geometry/Triangle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | module Geometry.Triangle 3 | ( Triangle(..) 4 | , Kind(..) 5 | , triangleVertices 6 | ) where 7 | 8 | import Linear.V2 9 | import Linear.V4 10 | 11 | data Triangle n = Triangle 12 | {-# UNPACK #-} !(V2 n) 13 | {-# UNPACK #-} !(V2 n) 14 | {-# UNPACK #-} !(V2 n) 15 | deriving (Eq, Functor, Show) 16 | 17 | data Kind = Solid | Curve 18 | deriving (Eq, Show) 19 | 20 | 21 | triangleVertices :: Num a => Triangle a -> Kind -> [V4 a] 22 | triangleVertices (Triangle (V2 ax ay) (V2 bx by) (V2 cx cy)) Solid = [ V4 ax ay 0 2, V4 bx by 0 2, V4 cx cy 0 2 ] 23 | triangleVertices (Triangle (V2 ax ay) (V2 bx by) (V2 cx cy)) Curve = [ V4 ax ay 0 0, V4 bx by 1 0, V4 cx cy 2 2 ] 24 | -------------------------------------------------------------------------------- /src/Linear/Exts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | module Linear.Exts 5 | ( translated 6 | , orient 7 | , face 8 | , easeInOutCubic 9 | , reject 10 | , direction 11 | , angleOf 12 | , angleTo 13 | , facingRel 14 | , toAxisAngle 15 | , cartesian2 16 | , Ext(..) 17 | , extended 18 | , module Linear.Epsilon 19 | , module Linear.Matrix 20 | , module Linear.Metric 21 | , module Linear.Quaternion 22 | , module Linear.V1 23 | , module Linear.V2 24 | , module Linear.V3 25 | , module Linear.V4 26 | , module Linear.Vector 27 | ) where 28 | 29 | import Control.Lens (Iso, iso, (^.)) 30 | import Data.Functor.I 31 | import Data.Functor.Interval 32 | import Linear.Epsilon 33 | import Linear.Matrix hiding (Trace(..)) 34 | import Linear.Metric 35 | import Linear.Quaternion 36 | import Linear.V1 37 | import Linear.V2 hiding (angle) 38 | import Linear.V3 39 | import Linear.V4 40 | import Linear.Vector 41 | import Unit 42 | import Unit.Algebra 43 | 44 | translated :: Num a => V2 a -> M33 a 45 | translated (V2 tx ty) = V3 46 | (V3 1 0 tx) 47 | (V3 0 1 ty) 48 | (V3 0 0 1) 49 | 50 | 51 | orient :: (Epsilon a, RealFloat a) => a -> a -> a -> Quaternion a 52 | orient alpha beta gamma 53 | = axisAngle (unit _z) alpha 54 | * axisAngle (unit _x) beta 55 | * axisAngle (unit _z) gamma 56 | 57 | 58 | -- | Compute a rotation turning to face a desired angle with a given maximum angular thrust. 59 | face 60 | :: (Epsilon a, RealFloat a) 61 | => I a -- ^ Angular thrust. (Speed of rotation.) 62 | -> I a -- ^ Desired angle. 63 | -> Quaternion (I a) -- ^ Current rotation. 64 | -> Quaternion (I a) -- ^ Resulting rotation. 65 | face angular angle rotation 66 | | nearZero delta = proposed 67 | | otherwise = slerp rotation proposed (min 1 (angular / delta)) where 68 | proposed = axisAngle (unit _z) angle 69 | delta = facingRel rotation angle 70 | 71 | 72 | easeInOutCubic :: Double -> Double 73 | easeInOutCubic t 74 | | t < 0.5 = 4 * t ** 3 75 | | otherwise = (t - 1) * (2 * t - 2) ** 2 + 1 76 | 77 | 78 | reject :: (Metric v, Fractional a) => v a -> v a -> v a 79 | reject a b = a ^-^ project a b 80 | 81 | 82 | -- | The unit vector in the direction of another vector. 83 | direction :: (Metric v, Epsilon a, Floating a, Unit du u) => v (u a) -> v (u a) -> v (I a) 84 | direction a b = normalizeU (a ^-^ b) 85 | 86 | 87 | -- | The angle of a vector. 88 | angleOf :: (RealFloat a, Unit du u) => V2 (u a) -> I a 89 | angleOf v = I (atan2 y x) where 90 | V2 x y = prj <$> v 91 | 92 | -- | The angle from the first vector to the second. 93 | angleTo :: (RealFloat a, Unit du u) => V2 (u a) -> V2 (u a) -> I a 94 | angleTo v1 v2 = angleOf (v2 - v1) 95 | 96 | 97 | -- | Compute the angle between a rotation and a proposed angle. 98 | -- 99 | -- The result lies in the interval [-pi, pi]. 100 | facingRel :: (Real a, Floating a) => Quaternion (I a) -> I a -> I a 101 | facingRel rotation target = abs (wrap (-pi...pi) (snd (toAxisAngle rotation) - target)) 102 | 103 | 104 | -- | Compute the axis/angle of a rotation represented as a unit quaternion. 105 | -- 106 | -- NB: Assumes unit magnitude. The axis is undefined for 0-rotations. 107 | toAxisAngle :: (Floating a, Ord a) => Quaternion (I a) -> (V3 (I a), I a) 108 | toAxisAngle (Quaternion qw qv) = (v, phi) where 109 | v = sign *^ qv ^/ sqrt (1 - qw ^ (2 :: Int)) 110 | phi = sign * 2 * acos qw 111 | sign | qv >= 0 = 1 112 | | otherwise = -1 113 | 114 | 115 | cartesian2 :: (Floating a, Unit du u) => I a -> u a -> V2 (u a) 116 | cartesian2 phi r = V2 (r .*. cos phi) (r .*. sin phi) 117 | 118 | 119 | -- | Extensions of a vector with an extra dimension. 120 | class Ext v v' | v -> v', v' -> v where 121 | ext :: v a -> a -> v' a 122 | unext :: v' a -> v a 123 | 124 | instance Ext V1 V2 where 125 | ext (V1 x) = V2 x 126 | unext = V1 . (^._x) 127 | 128 | instance Ext V2 V3 where 129 | ext (V2 x y) = V3 x y 130 | unext = (^._xy) 131 | 132 | instance Ext V3 V4 where 133 | ext (V3 x y z) = V4 x y z 134 | unext = (^._xyz) 135 | 136 | -- | Subject to the invariant that w=1. 137 | extended :: Ext v v' => a -> Iso (v a) (v b) (v' a) (v' b) 138 | extended a = iso (`ext` a) unext 139 | -------------------------------------------------------------------------------- /src/Starlight/AI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DisambiguateRecordFields #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | module Starlight.AI 5 | ( ai 6 | ) where 7 | 8 | import Control.Effect.Reader 9 | import Control.Lens ((&), (.~), (^.)) 10 | import qualified Data.Set as Set 11 | import Linear.Exts 12 | import Starlight.Actor as Actor 13 | import Starlight.Body as Body 14 | import Starlight.Character 15 | import Starlight.System as System 16 | 17 | ai 18 | :: Has (Reader (System StateVectors)) sig m 19 | => Character 20 | -> m Character 21 | ai c@Character{ actor = Actor{ position = here, rotation }, target } = do 22 | system <- ask @(System StateVectors) 23 | pure $! c & actions_ .~ case target >>= (system !?) of 24 | -- FIXME: different kinds of behaviours: aggressive, patrolling, mining, trading, etc. 25 | -- FIXME: don’t just fly directly at the target at full throttle, dumbass 26 | -- FIXME: factor in the target’s velocity & distance 27 | -- FIXME: allow other behaviours relating to targets, e.g. following 28 | Just (Left sv) -> Set.fromList 29 | ( Face Target 30 | : [ Thrust | facingRel rotation (angleTo' (sv^.position_)) < pi/4 ] 31 | ) 32 | Just (Right c) -> Set.fromList $ concat 33 | [ [ Face Target ] 34 | , [ Thrust | facingRel rotation (angleTo' (c^.position_)) < pi/4 ] 35 | , [ Fire Main | facingRel rotation (angleTo' (c^.position_)) < pi/128 ] 36 | ] 37 | -- FIXME: wander 38 | -- FIXME: pick a new target 39 | _ -> mempty 40 | where 41 | angleTo' there = angleTo (here^._xy) (there^._xy) 42 | -------------------------------------------------------------------------------- /src/Starlight/Actor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | -- | An 'Actor' has 'position', 'velocity', 'rotation', 'mass', and 'magnitude', and can be acted on by the physics simulation. 7 | module Starlight.Actor 8 | ( Actor(..) 9 | , transformToActor 10 | , applyImpulse 11 | , HasActor(..) 12 | , momentum_ 13 | , projected 14 | ) where 15 | 16 | import Control.Effect.Lens.Exts (asserting) 17 | import Control.Lens (Lens', lens, mapping, none, (&), (+~), (.~), (^.)) 18 | import Data.Generics.Product.Fields 19 | import Geometry.Transform 20 | import GHC.Generics (Generic) 21 | import GHC.Stack (HasCallStack) 22 | import Linear.Exts 23 | import Starlight.Physics 24 | import Unit.Algebra 25 | import Unit.Force 26 | import Unit.Length 27 | import Unit.Mass 28 | import Unit.Time 29 | 30 | data Actor = Actor 31 | { position :: !(V2 (Distance Double)) 32 | , velocity :: !(V2 ((Distance :/: Seconds) Double)) 33 | , rotation :: !(Quaternion (I Double)) 34 | , mass :: !(Kilo Grams Double) 35 | , magnitude :: !(Distance Double) -- approx. equivalent to diameter; should bound the actor’s geometry 36 | } 37 | deriving (Generic, Show) 38 | 39 | transformToActor :: Actor -> Transform V4 Double Distance Distance 40 | transformToActor Actor{ position, rotation } = mkTranslation (ext position 0) <<< mkRotation rotation 41 | 42 | applyImpulse :: HasCallStack => V2 (Newtons Double) -> Seconds Double -> Actor -> Actor 43 | applyImpulse force dt a = a & momentum_ +~ force ^*. dt 44 | 45 | 46 | class HasActor t where 47 | actor_ :: Lens' t Actor 48 | 49 | position_ :: HasCallStack => Lens' t (V2 (Distance Double)) 50 | position_ = actor_.field @"position".asserting (none isNaN) 51 | 52 | velocity_ :: HasCallStack => Lens' t (V2 ((Distance :/: Seconds) Double)) 53 | velocity_ = actor_.field @"velocity".asserting (none isNaN) 54 | 55 | rotation_ :: HasCallStack => Lens' t (Quaternion (I Double)) 56 | rotation_ = actor_.field @"rotation".asserting (none isNaN) 57 | 58 | mass_ :: HasCallStack => Lens' t (Kilo Grams Double) 59 | mass_ = actor_.field @"mass".asserting (not.isNaN) 60 | 61 | magnitude_ :: HasCallStack => Lens' t (Distance Double) 62 | magnitude_ = actor_.field @"magnitude".asserting (not.isNaN) 63 | 64 | {-# MINIMAL actor_ #-} 65 | 66 | instance HasActor Actor where 67 | actor_ = id 68 | 69 | momentum_ :: (HasCallStack, HasActor t) => Lens' t (V2 ((Kilo Grams :*: Metres :/: Seconds) Double)) 70 | momentum_ = lens get set where 71 | get :: HasActor t => t -> V2 ((Kilo Grams :*: Metres :/: Seconds) Double) 72 | get t = (t^.mass_ .*^ t^.velocity_)^.mapping converting 73 | set :: HasActor t => t -> V2 ((Kilo Grams :*: Metres :/: Seconds) Double) -> t 74 | set t p = t & velocity_.mapping converting .~ p ^/. t^.mass_ 75 | 76 | projected :: (HasCallStack, HasActor t) => Seconds Double -> t -> V2 (Distance Double) 77 | projected dt a = a^.position_ + a^.velocity_ ^*. dt 78 | -------------------------------------------------------------------------------- /src/Starlight/CLI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | module Starlight.CLI 5 | ( Options(..) 6 | , ShouldProfile(..) 7 | , ShouldTrace(..) 8 | , ShouldCheck(..) 9 | , defaultOptions 10 | , profile_ 11 | , trace_ 12 | , check_ 13 | , argumentsParser 14 | -- * Re-exports 15 | , execParser 16 | ) where 17 | 18 | import Control.Lens 19 | import Data.Flag 20 | import Data.Foldable (foldl') 21 | import Data.Generics.Product.Fields 22 | import Data.Version (showVersion) 23 | import GHC.Generics (Generic) 24 | import Options.Applicative 25 | import qualified Paths_starlight as Library (version) 26 | 27 | data Options = Options 28 | { profile :: Flag ShouldProfile 29 | , trace :: Flag ShouldTrace 30 | , check :: Flag ShouldCheck 31 | } 32 | deriving (Generic, Show) 33 | 34 | data ShouldProfile = ShouldProfile 35 | data ShouldTrace = ShouldTrace 36 | data ShouldCheck = ShouldCheck 37 | 38 | defaultOptions :: Options 39 | defaultOptions = Options 40 | { profile = toFlag ShouldProfile False 41 | , trace = toFlag ShouldTrace False 42 | , check = toFlag ShouldCheck False 43 | } 44 | 45 | profile_ :: Lens' Options (Flag ShouldProfile) 46 | profile_ = field @"profile" 47 | 48 | trace_ :: Lens' Options (Flag ShouldTrace) 49 | trace_ = field @"trace" 50 | 51 | check_ :: Lens' Options (Flag ShouldCheck) 52 | check_ = field @"check" 53 | 54 | 55 | argumentsParser :: ParserInfo Options 56 | argumentsParser = info 57 | (version <*> helper <*> options) 58 | ( fullDesc 59 | <> progDesc "Starlight is a game about spaceships in space." 60 | <> header "Starlight - spaceships in space") 61 | 62 | options :: Parser Options 63 | options = foldl' (&) defaultOptions <$> sequenceA 64 | [ flag id (profile_ .~ toFlag ShouldProfile True) (long "profile" <> help "run with profiling enabled") 65 | , flag id (trace_ .~ toFlag ShouldTrace True) (long "trace" <> help "run with tracing enabled") 66 | , flag id (check_ .~ toFlag ShouldCheck True) (long "check" <> help "run with error checking enabled") 67 | ] 68 | 69 | 70 | versionString :: String 71 | versionString = "starlight version " <> showVersion Library.version 72 | 73 | version :: Parser (a -> a) 74 | version = infoOption versionString (long "version" <> short 'V' <> help "Output version info.") 75 | -------------------------------------------------------------------------------- /src/Starlight/Character.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | -- | Characters are player or non-player characters. 5 | module Starlight.Character 6 | ( Character(..) 7 | , name_ 8 | , target_ 9 | , actions_ 10 | , ship_ 11 | , HasActor(..) 12 | , Action(..) 13 | , Turn(..) 14 | , Face(..) 15 | , Change(..) 16 | , Weapon(..) 17 | ) where 18 | 19 | import Control.Lens (Lens') 20 | import Data.Generics.Product.Fields 21 | import Data.Set (Set) 22 | import Data.Text (Text) 23 | import GHC.Generics (Generic) 24 | import Starlight.Actor (Actor, HasActor(..)) 25 | import Starlight.Identifier 26 | import Starlight.Ship 27 | import UI.Colour 28 | 29 | data Character = Character 30 | { name :: !Text 31 | , actor :: !Actor 32 | , target :: !(Maybe Identifier) 33 | , actions :: !(Set Action) 34 | , ship :: !Ship 35 | } 36 | deriving (Generic, Show) 37 | 38 | instance HasActor Character where 39 | actor_ = field @"actor" 40 | 41 | instance HasColour Character where 42 | colour_ = ship_.colour_ 43 | 44 | name_ :: Lens' Character Text 45 | name_ = field @"name" 46 | 47 | target_ :: Lens' Character (Maybe Identifier) 48 | target_ = field @"target" 49 | 50 | actions_ :: Lens' Character (Set Action) 51 | actions_ = field @"actions" 52 | 53 | ship_ :: Lens' Character Ship 54 | ship_ = field @"ship" 55 | 56 | 57 | data Action 58 | = Thrust -- ^ Fire thrusters at current heading. 59 | | Match -- ^ Face away from heading and thrust until stopped. 60 | | Turn Turn -- ^ Turn left or right. 61 | | Face Face -- ^ Face toward/away from heading/target. 62 | | Fire Weapon -- ^ Fire the indicated weapon. 63 | | ChangeTarget (Maybe Change) -- ^ Change or cancel the target. 64 | | Jump -- ^ Make a long-range jump to the target. 65 | deriving (Eq, Ord, Show) 66 | 67 | data Turn 68 | = L 69 | | R 70 | deriving (Eq, Ord, Show) 71 | 72 | data Face 73 | = Backwards 74 | | Forwards 75 | | Target 76 | deriving (Eq, Ord, Show) 77 | 78 | data Change 79 | = Prev 80 | | Next 81 | deriving (Eq, Ord, Show) 82 | 83 | data Weapon 84 | = Main 85 | deriving (Eq, Ord, Show) 86 | -------------------------------------------------------------------------------- /src/Starlight/Controls.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | module Starlight.Controls 3 | ( controls 4 | , controlRelations 5 | ) where 6 | 7 | import Control.Applicative (Alternative(..)) 8 | import Control.Carrier.Reader.Relation 9 | import Control.Effect.Lift 10 | import Control.Effect.State 11 | import Data.Functor (($>)) 12 | import Data.Maybe (mapMaybe) 13 | import qualified Data.Set as Set 14 | import Data.Traversable (for) 15 | import qualified SDL 16 | import Starlight.Character 17 | import Starlight.Input 18 | 19 | controls 20 | :: Has (State Input) sig m 21 | => m (Set.Set Action) 22 | controls = do 23 | input <- get 24 | let actions = mapMaybe (runRelation input) controlRelations 25 | Set.unions <$> for actions (\ (input, actions) -> 26 | actions <$ modify (\\ input)) 27 | 28 | -- FIXME: make this user-configurable 29 | controlRelations :: [Relation Input (Input, Set.Set Action)] 30 | controlRelations = 31 | [ expect (pressed_ SDL.KeycodeUp) $> (mempty, Set.singleton Thrust) 32 | , expect (pressed_ SDL.KeycodeDown) $> (mempty, Set.singleton (Face Backwards)) 33 | , expect (pressed_ SDL.KeycodeLeft) $> (mempty, Set.singleton (Turn L)) 34 | , expect (pressed_ SDL.KeycodeRight) $> (mempty, Set.singleton (Turn R)) 35 | , expect (pressed_ SDL.KeycodeSpace) $> (mempty, Set.singleton (Fire Main)) 36 | , expect (pressed_ SDL.KeycodeB) $> (mempty, Set.singleton Match) 37 | , expect (pressed_ SDL.KeycodeF) $> (mempty, Set.singleton (Face Forwards)) 38 | , expect (pressed_ SDL.KeycodeT) $> (mempty, Set.singleton (Face Target)) 39 | , expect (pressed_ SDL.KeycodeJ) $> (mempty, Set.singleton Jump) 40 | , (singleton SDL.KeycodeTab,) . Set.singleton . ChangeTarget . Just 41 | <$ expect (pressed_ SDL.KeycodeTab) 42 | <*> (Prev <$ shift <|> pure Next) 43 | <|> expect (pressed_ SDL.KeycodeEscape) $> (singleton SDL.KeycodeEscape, Set.singleton (ChangeTarget Nothing)) 44 | ] 45 | where 46 | shift = expect (pressed_ SDL.KeycodeLShift) <|> expect (pressed_ SDL.KeycodeRShift) 47 | -------------------------------------------------------------------------------- /src/Starlight/Draw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DisambiguateRecordFields #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | module Starlight.Draw 7 | ( runFrame 8 | , frame 9 | ) where 10 | 11 | import Control.Carrier.Empty.Church 12 | import Control.Carrier.Reader 13 | import Control.Carrier.State.Church 14 | import Control.Effect.Finally 15 | import Control.Effect.Lift 16 | import Control.Effect.Profile 17 | import Control.Effect.Trace 18 | import Control.Lens (choosing, filtered, forOf_, traversed, (^.)) 19 | import Control.Monad.IO.Class.Lift 20 | import Data.Foldable (for_) 21 | import Data.Maybe (fromMaybe) 22 | import Data.Time.Clock 23 | import GL.Effect.Check 24 | import GL.Framebuffer 25 | import Graphics.GL.Core41 26 | import Linear.Exts 27 | import Starlight.Actor 28 | import Starlight.Body as Body 29 | import Starlight.Character as Character 30 | import Starlight.Draw.Body as Body 31 | import Starlight.Draw.Radar as Radar 32 | import Starlight.Draw.Ship as Ship 33 | import Starlight.Draw.Starfield as Starfield 34 | import Starlight.Draw.Weapon.Laser as Laser 35 | import Starlight.Identifier 36 | import Starlight.Input 37 | import Starlight.System 38 | import Starlight.Time 39 | import Starlight.UI 40 | import Starlight.View 41 | import UI.Colour 42 | import UI.Label 43 | import UI.Typeface 44 | import UI.Window as Window 45 | import Unit.Algebra 46 | import Unit.Count 47 | import Unit.Length 48 | 49 | runFrame 50 | :: ( Has Check sig m 51 | , Has Finally sig m 52 | , Has (Lift IO) sig m 53 | , Has Trace sig m 54 | ) 55 | => ReaderC Body.Drawable (ReaderC Laser.Drawable (ReaderC Radar.Drawable (ReaderC Ship.Drawable (ReaderC Starfield.Drawable (StateC UTCTime (EmptyC m)))))) a 56 | -> m () 57 | runFrame = evalEmpty . (\ m -> now >>= \ start -> evalState start m) . Starfield.run . Ship.run . Radar.run . Laser.run . Body.run 58 | 59 | frame 60 | :: ( Has Check sig m 61 | , Has Empty sig m 62 | , Has (Lift IO) sig m 63 | , Has Profile sig m 64 | , Has (Reader Body.Drawable) sig m 65 | , Has (Reader Laser.Drawable) sig m 66 | , Has (Reader Radar.Drawable) sig m 67 | , Has (Reader Ship.Drawable) sig m 68 | , Has (Reader Starfield.Drawable) sig m 69 | , Has (Reader Epoch) sig m 70 | , Has (Reader UI) sig m 71 | , Has (Reader Window.Window) sig m 72 | , Has (State Input) sig m 73 | , Has (State (System Body)) sig m 74 | ) 75 | => m () 76 | frame = runSystem $ do 77 | measure "input" Starlight.Input.input 78 | withView . local (neighbourhoodOfPlayer @StateVectors) . measure "draw" . runLiftIO $ do 79 | UI{ target, face } <- ask 80 | let font = Font face 18 81 | bind @Framebuffer Nothing 82 | 83 | v@View{ size } <- ask 84 | system <- ask @(System StateVectors) 85 | 86 | let hypotenuse = norm (fromIntegral <$> size) * 0.5 87 | onScreen a = lengthToWindowPixels v .*. (distance (a^.position_) (system^.player_.position_) - a^.magnitude_ * 0.5) < hypotenuse 88 | 89 | clipTo v 90 | 91 | glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA 92 | 93 | measure "starfield" Starfield.draw 94 | 95 | measure "ship" $ forOf_ (characters_.traversed.filtered onScreen) system Ship.draw 96 | 97 | measure "laser" $ for_ (beams system) Laser.draw 98 | 99 | measure "body" $ forOf_ (bodies_.traversed.filtered onScreen) system Body.draw 100 | 101 | measure "radar" Radar.draw 102 | 103 | measure "setLabel" . setLabel target font . fromMaybe "" $ do 104 | identifier <- system^.player_.target_ 105 | pos <- (^.choosing position_ position_) <$> system !? identifier 106 | pure $! describeIdentifier identifier ++ ": " ++ formatExpR (Just 1) (convert @_ @(Kilo Metres) (distance pos (system^.player_.position_))) 107 | measure "drawLabel" $ drawLabel target 10 white Nothing 108 | -------------------------------------------------------------------------------- /src/Starlight/Draw/Body.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE DisambiguateRecordFields #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE NamedFieldPuns #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | module Starlight.Draw.Body 11 | ( Starlight.Draw.Body.run 12 | , Drawable 13 | , draw 14 | ) where 15 | 16 | import Control.Carrier.Reader 17 | import Control.Effect.Finally 18 | import Control.Effect.Lens ((?=)) 19 | import Control.Effect.Lift 20 | import Control.Effect.Trace 21 | import Control.Lens (Lens') 22 | import Data.Coerce 23 | import Data.Functor.I 24 | import Data.Functor.Interval hiding (range) 25 | import Data.Generics.Product.Fields 26 | import Foreign.Storable 27 | import Geometry.Circle 28 | import GHC.Generics (Generic) 29 | import GL.Array 30 | import GL.Effect.Check 31 | import GL.Shader.DSL hiding (norm, (!*), (!*!)) 32 | import qualified GL.Shader.DSL as D 33 | import Prelude hiding (break) 34 | import qualified Starlight.Body as Body 35 | import Starlight.View 36 | import qualified UI.Drawable as UI 37 | 38 | run 39 | :: ( Has Check sig m 40 | , Has Finally sig m 41 | , Has (Lift IO) sig m 42 | , Has Trace sig m 43 | ) 44 | => ReaderC Drawable m a 45 | -> m a 46 | run = UI.loadingDrawable Drawable shader vertices 47 | 48 | 49 | draw 50 | :: ( Has Check sig m 51 | , Has (Lift IO) sig m 52 | , Has (Reader Drawable) sig m 53 | , Has (Reader View) sig m 54 | ) 55 | => Body.StateVectors 56 | -> m () 57 | draw v@Body.StateVectors{ body = Body.Body{ colour } } = UI.using getDrawable $ do 58 | view <- ask 59 | matrix_ ?= 60 | ( transformToSystem view 61 | <<< Body.transform v 62 | <<< Body.toBodySpace v) 63 | colour_ ?= colour 64 | 65 | drawArraysInstanced LineLoop range 3 66 | 67 | 68 | newtype Drawable = Drawable { getDrawable :: UI.Drawable U V Frag } 69 | 70 | 71 | vertices :: [V I] 72 | vertices = coerce @[V2 (I Double)] $ circle 1 128 73 | 74 | range :: Interval I Int 75 | range = 0...length vertices 76 | 77 | 78 | shader :: D.Shader shader => shader U V Frag 79 | shader 80 | = vertex (\ U{ matrix } V{ pos } D.None -> main $ do 81 | let cos90 = 6.123233995736766e-17 82 | m <- var "m" matrix 83 | switch gl_InstanceID 84 | [ (Just 1, do 85 | m *= D.mkRotation (m4 86 | 1 0 0 0 87 | 0 cos90 (-1) 0 88 | 0 1 cos90 0 89 | 0 0 0 1) 90 | break) 91 | , (Just 2, do 92 | m *= D.mkRotation (m4 93 | cos90 0 1 0 94 | 0 1 0 0 95 | (-1) 0 cos90 0 96 | 0 0 0 1) 97 | break) 98 | ] 99 | gl_Position .= cast @_ @(V4 (ClipUnits Float)) (get m D.>* dext4 (dext3 pos 0) 1)) 100 | 101 | >>> fragment (\ U{ colour } D.None Frag{ fragColour } -> main $ 102 | fragColour .= colour) 103 | 104 | 105 | data U v = U 106 | { matrix :: v (Transform V4 Double Body.BodyUnits ClipUnits) 107 | , colour :: v (Colour Float) 108 | } 109 | deriving (Generic) 110 | 111 | instance D.Vars U 112 | 113 | matrix_ :: Lens' (U v) (v (Transform V4 Double Body.BodyUnits ClipUnits)) 114 | matrix_ = field @"matrix" 115 | 116 | colour_ :: Lens' (U v) (v (Colour Float)) 117 | colour_ = field @"colour" 118 | 119 | 120 | newtype V v = V { pos :: v (V2 (Body.BodyUnits Double)) } 121 | deriving (Generic) 122 | 123 | instance D.Vars V 124 | 125 | deriving via Fields V instance Storable (V I) 126 | -------------------------------------------------------------------------------- /src/Starlight/Draw/Ship.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE DisambiguateRecordFields #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE NamedFieldPuns #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | module Starlight.Draw.Ship 13 | ( draw 14 | , Starlight.Draw.Ship.run 15 | , Drawable 16 | ) where 17 | 18 | import Control.Carrier.Reader 19 | import Control.Effect.Finally 20 | import Control.Effect.Lens ((?=)) 21 | import Control.Effect.Lift 22 | import Control.Effect.Trace 23 | import Control.Lens (Lens', to, (&), (+~), (-~), (.~), (^.)) 24 | import Data.Coerce (coerce) 25 | import Data.Functor.I 26 | import Data.Functor.Interval hiding (range) 27 | import Data.Generics.Product.Fields 28 | import qualified Data.Set as Set 29 | import Foreign.Storable (Storable) 30 | import GHC.Generics (Generic) 31 | import GL.Array 32 | import GL.Effect.Check 33 | import GL.Shader.DSL hiding ((!*), (!*!), (./.), (^.), (^/), _a) 34 | import qualified GL.Shader.DSL as D 35 | import Linear.Exts 36 | import Starlight.Actor 37 | import Starlight.Character 38 | import Starlight.Physics 39 | import qualified Starlight.Ship as S 40 | import Starlight.View 41 | import qualified UI.Colour as UI 42 | import qualified UI.Drawable as UI 43 | import Unit.Algebra 44 | import Unit.Length 45 | 46 | draw 47 | :: ( Has Check sig m 48 | , Has (Lift IO) sig m 49 | , Has (Reader Drawable) sig m 50 | , Has (Reader View) sig m 51 | ) 52 | => Character 53 | -> m () 54 | draw Character{ actor, ship = S.Ship{ colour, armour }, actions } = UI.using getDrawable $ do 55 | view@View{ shipScale } <- ask 56 | matrix_ ?= tmap realToFrac 57 | ( transformToSystem view 58 | <<< transformToActor actor 59 | <<< mkScale @_ @Distance (pure shipScale) 60 | <<< mkScale (pure (actor^.magnitude_ ./. (1 :: Distance Double)))) 61 | colour_ ?= (colour 62 | & (if Thrust `Set.member` actions then (\ v -> v ^/ v^.UI._r) . (UI._r +~ 0.5) . (UI._b -~ 0.25) else id) 63 | & UI._a .~ realToFrac (armour^.inf_.to getI / armour^.sup_.to getI)) 64 | drawArrays LineLoop range 65 | 66 | 67 | run 68 | :: ( Has Check sig m 69 | , Has Finally sig m 70 | , Has (Lift IO) sig m 71 | , Has Trace sig m 72 | ) 73 | => ReaderC Drawable m a 74 | -> m a 75 | run = UI.loadingDrawable Drawable shader vertices 76 | 77 | 78 | newtype Drawable = Drawable { getDrawable :: UI.Drawable U V Frag } 79 | 80 | 81 | vertices :: [V I] 82 | vertices = coerce @[V2 (Distance Float)] 83 | [ V2 1 0 84 | , V2 0 (-0.5) 85 | , V2 (-0.5) 0 86 | , V2 0 0.5 87 | ] 88 | 89 | range :: Interval I Int 90 | range = 0...4 91 | 92 | 93 | shader :: D.Shader shader => shader U V Frag 94 | shader 95 | = vertex (\ U{ matrix } V{ pos } None -> main $ 96 | gl_Position .= matrix D.>* ext4 (ext3 pos 1) 1) 97 | 98 | >>> fragment (\ U{ colour } None Frag{ fragColour } -> main $ 99 | fragColour .= colour) 100 | 101 | 102 | data U v = U 103 | { matrix :: v (Transform V4 Float Distance ClipUnits) 104 | , colour :: v (UI.Colour Float) 105 | } 106 | deriving (Generic) 107 | 108 | instance D.Vars U 109 | 110 | matrix_ :: Lens' (U v) (v (Transform V4 Float Distance ClipUnits)) 111 | matrix_ = field @"matrix" 112 | 113 | colour_ :: Lens' (U v) (v (UI.Colour Float)) 114 | colour_ = field @"colour" 115 | 116 | 117 | newtype V v = V { pos :: v (V2 (Distance Float)) } 118 | deriving (Generic) 119 | 120 | instance D.Vars V 121 | 122 | deriving via Fields V instance Storable (V I) 123 | -------------------------------------------------------------------------------- /src/Starlight/Draw/Starfield.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE DisambiguateRecordFields #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE NamedFieldPuns #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | module Starlight.Draw.Starfield 12 | ( draw 13 | , Starlight.Draw.Starfield.run 14 | , Drawable 15 | ) where 16 | 17 | import Control.Carrier.Reader 18 | import Control.Effect.Finally 19 | import Control.Effect.Lens ((?=)) 20 | import Control.Effect.Lift 21 | import Control.Effect.Trace 22 | import Control.Lens (Lens') 23 | import Data.Coerce (coerce) 24 | import Data.Functor.I 25 | import Data.Functor.Interval hiding (range) 26 | import Data.Generics.Product.Fields 27 | import Foreign.Storable (Storable) 28 | import GHC.Generics (Generic) 29 | import GL.Array 30 | import GL.Effect.Check 31 | import GL.Shader.DSL hiding ((!*!), (^*)) 32 | import qualified GL.Shader.DSL as D 33 | import Starlight.View 34 | import qualified UI.Drawable as UI 35 | import qualified UI.Window as Window 36 | import Unit.Length 37 | 38 | draw 39 | :: ( Has Check sig m 40 | , Has (Lift IO) sig m 41 | , Has (Reader Drawable) sig m 42 | , Has (Reader View) sig m 43 | ) 44 | => m () 45 | draw = UI.using getDrawable $ do 46 | view@View{ zoom, focus } <- ask 47 | 48 | resolution_ ?= (fromIntegral <$> contextSize view) 49 | focus_ ?= focus 50 | zoom_ ?= realToFrac (1/zoom) 51 | 52 | drawArrays TriangleStrip range 53 | 54 | 55 | run 56 | :: ( Has Check sig m 57 | , Has Finally sig m 58 | , Has (Lift IO) sig m 59 | , Has Trace sig m 60 | ) 61 | => ReaderC Drawable m a 62 | -> m a 63 | run = UI.loadingDrawable Drawable shader vertices 64 | 65 | 66 | newtype Drawable = Drawable { getDrawable :: UI.Drawable U V Frag } 67 | 68 | 69 | vertices :: [V I] 70 | vertices = coerce @[V2 Float] 71 | [ V2 (-1) (-1) 72 | , V2 1 (-1) 73 | , V2 (-1) 1 74 | , V2 1 1 75 | ] 76 | 77 | range :: Interval I Int 78 | range = 0...length vertices 79 | 80 | 81 | -- based on Star Nest by Pablo Roman Andrioli: https://www.shadertoy.com/view/XlfGRj 82 | 83 | shader :: Shader shader => shader U V Frag 84 | shader 85 | = vertex (\ _ V{ pos } None -> main $ 86 | gl_Position .= coerce (ext4 (ext3 pos 0) 1)) 87 | 88 | >>> fragment (\ U{ resolution, focus, zoom } None Frag{ fragColour } -> main $ do 89 | resolution <- let' @_ @_ @_ @(V2 Float) "resolution" (coerce resolution) 90 | uv <- let' "uv" $ (gl_FragCoord^._xy / resolution^._xy - 0.5) * xy 1 (resolution^._y / resolution^._x) 91 | dir <- var "dir" $ ext3 (uv D.^* zoom) 1 D.^* 0.5 92 | focus <- var "focus" $ dext3 (coerce focus) 1 93 | let wrap x = ((x + pi) `mod'` (pi * 2)) - pi 94 | nf <- let' "nf" (float (0.01 / norm (get focus))) 95 | a1 <- let' "a1" (wrap (0.3 + nf)) 96 | cos_a1 <- let' "cos_a1" (cos a1) 97 | sin_a1 <- let' "sin_a1" (sin a1) 98 | rot1 <- let' "rot1" $ m2 99 | cos_a1 sin_a1 100 | (-sin_a1) cos_a1 101 | a2 <- let' "a2" (wrap (0.2 + nf)) 102 | cos_a2 <- let' "cos_a2" (cos a2) 103 | sin_a2 <- let' "sin_a2" (sin a2) 104 | rot2 <- let' "rot2" $ m2 105 | cos_a2 sin_a2 106 | (-sin_a2) cos_a2 107 | dir^^._xz *!= rot1 108 | dir^^._xy *!= rot2 109 | focus^^._xz *!= cast @_ @(M22 Double) rot1 110 | focus^^._xy *!= cast @_ @(M22 Double) rot2 111 | focus <- let' "focus2" $ cast @_ @(V3 Float) (get focus `mod'` v3 (pure (tile * 2))) * 10 112 | v <- var "v" $ v3 0 113 | r <- var @_ @_ @_ @Int "r" 2 114 | while (get r `lt` volsteps) $ do 115 | s <- let' "s" (0.1 + 0.125 * float (get r)) 116 | p <- var "p" $ focus + get dir D.^* s 117 | p .= abs (v3 (pure tile) - (get p `mod'` v3 (pure (tile * 2)))) 118 | pa <- var "pa" 0 119 | a <- var "a" 0 120 | i <- var @_ @_ @_ @Int "i" 0 121 | while (get i `lt` iterations) $ do 122 | p .= abs (get p) ^/ dot (get p) (get p) - formuparam 123 | prev <- let' "prev" (get pa) 124 | pa .= norm (get p) 125 | a += abs (get pa - prev) 126 | i += 1 127 | a .= get a ** 3 128 | v += xyz s (s ** 2) (s ** 2) D.^* get a D.^* brightness D.^* (0.5 * distfading ** float (get r)) 129 | r += 1 130 | mag <- let' "mag" (norm (get v)) 131 | v .= lerp saturation (v3 (pure mag)) (get v) 132 | fragColour .= ext4 (get v D.^* 0.01) 1) 133 | where 134 | iterations :: Num a => a 135 | iterations = 17 136 | formuparam :: Fractional a => a 137 | formuparam = 0.53 138 | volsteps :: Num a => a 139 | volsteps = 8 140 | tile :: Fractional a => a 141 | tile = 1/1.61803398875 142 | brightness :: Fractional a => a 143 | brightness = 0.0015 144 | distfading :: Fractional a => a 145 | distfading = 0.65 146 | saturation :: Fractional a => a 147 | saturation = 0.65 148 | 149 | 150 | data U v = U 151 | { resolution :: v (V2 (Window.Coords Float)) 152 | , focus :: v (V2 (Giga Metres Double)) 153 | , zoom :: v Float 154 | } 155 | deriving (Generic) 156 | 157 | instance Vars U 158 | 159 | resolution_ :: Lens' (U v) (v (V2 (Window.Coords Float))) 160 | resolution_ = field @"resolution" 161 | 162 | focus_ :: Lens' (U v) (v (V2 (Giga Metres Double))) 163 | focus_ = field @"focus" 164 | 165 | zoom_ :: Lens' (U v) (v Float) 166 | zoom_ = field @"zoom" 167 | 168 | newtype V v = V { pos :: v (V2 Float) } 169 | deriving (Generic) 170 | 171 | instance Vars V 172 | 173 | deriving via Fields V instance Storable (V I) 174 | -------------------------------------------------------------------------------- /src/Starlight/Draw/Weapon/Laser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE DisambiguateRecordFields #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE NamedFieldPuns #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | module Starlight.Draw.Weapon.Laser 10 | ( Starlight.Draw.Weapon.Laser.run 11 | , draw 12 | , Drawable 13 | ) where 14 | 15 | import Control.Carrier.Reader 16 | import Control.Effect.Finally 17 | import Control.Effect.Lens ((?=)) 18 | import Control.Effect.Lift 19 | import Control.Effect.Trace 20 | import Control.Lens (Lens', (^.)) 21 | import Data.Coerce (coerce) 22 | import Data.Functor.I 23 | import Data.Functor.Interval hiding (range) 24 | import Data.Generics.Product.Fields 25 | import Foreign.Storable (Storable) 26 | import GHC.Generics (Generic) 27 | import GL.Array 28 | import GL.Effect.Check 29 | import GL.Shader.DSL hiding ((!*), (!*!), (^.), _z) 30 | import qualified GL.Shader.DSL as D 31 | import Starlight.Actor 32 | import Starlight.Physics 33 | import Starlight.View 34 | import qualified Starlight.Weapon.Laser as S 35 | import qualified UI.Drawable as UI 36 | 37 | run 38 | :: ( Has Check sig m 39 | , Has Finally sig m 40 | , Has (Lift IO) sig m 41 | , Has Trace sig m 42 | ) 43 | => ReaderC Drawable m a 44 | -> m a 45 | run = UI.loadingDrawable Drawable shader vertices 46 | 47 | 48 | draw 49 | :: ( Has Check sig m 50 | , Has (Lift IO) sig m 51 | , Has (Reader Drawable) sig m 52 | , Has (Reader View) sig m 53 | ) 54 | => S.Beam 55 | -> m () 56 | draw beam@S.Beam{ colour } = UI.using getDrawable $ do 57 | view <- ask 58 | matrix_ ?= tmap realToFrac 59 | ( transformToSystem view 60 | <<< transformToActor (beam^.actor_) 61 | <<< mkScale (pure 1000)) 62 | colour_ ?= colour 63 | 64 | drawArrays Lines range 65 | 66 | 67 | newtype Drawable = Drawable { getDrawable :: UI.Drawable U V Frag } 68 | 69 | 70 | vertices :: [V I] 71 | vertices = coerce @[Distance Float] [0, 1] 72 | 73 | range :: Interval I Int 74 | range = 0...length vertices 75 | 76 | 77 | shader :: Shader shader => shader U V Frag 78 | shader 79 | = vertex (\ U{ matrix } V{ r } None -> main $ 80 | gl_Position .= matrix D.>* xyzw r 0 0 1) 81 | >>> fragment (\ U{ colour } None Frag{ fragColour } -> main $ 82 | fragColour .= colour) 83 | 84 | 85 | data U v = U 86 | { matrix :: v (Transform V4 Float Distance ClipUnits) 87 | , colour :: v (Colour Float) 88 | } 89 | deriving (Generic) 90 | 91 | instance Vars U 92 | 93 | matrix_ :: Lens' (U v) (v (Transform V4 Float Distance ClipUnits)) 94 | matrix_ = field @"matrix" 95 | 96 | colour_ :: Lens' (U v) (v (Colour Float)) 97 | colour_ = field @"colour" 98 | 99 | 100 | newtype V v = V { r :: v (Distance Float) } 101 | deriving (Generic) 102 | 103 | instance Vars V 104 | 105 | deriving via Fields V instance Storable (V I) 106 | -------------------------------------------------------------------------------- /src/Starlight/Faction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | module Starlight.Faction 7 | ( Factions 8 | , factions_ 9 | , factions 10 | , getFactions 11 | , Faction(..) 12 | , name_ 13 | , relationships_ 14 | ) where 15 | 16 | import Control.Lens 17 | import Data.Generics.Product.Fields 18 | import Data.IntMap as IntMap 19 | import Data.Text (Text) 20 | import GHC.Generics (Generic) 21 | import UI.Colour 22 | 23 | newtype Factions = Factions (forall v . [v] -> [Faction v]) 24 | 25 | factions_ :: Iso' Factions (IntMap (Faction Int)) 26 | factions_ = iso getFactions factions 27 | 28 | factions :: IntMap (Faction Int) -> Factions 29 | factions fs = Factions (\ vs -> go vs <$> IntMap.elems fs) where 30 | go vs f = f & relationships_.traversed._1 %~ (vs !!) 31 | 32 | getFactions :: Factions -> IntMap (Faction Int) 33 | getFactions (Factions fs) = IntMap.fromDistinctAscList (zip [0..] (fs [0..])) 34 | 35 | 36 | data Faction a = Faction 37 | { name :: Text 38 | , colour :: Colour Float 39 | , relationships :: [(a, Double)] 40 | } 41 | deriving (Eq, Foldable, Functor, Generic, Ord, Show, Traversable) 42 | 43 | instance HasColour (Faction a) 44 | 45 | name_ :: Lens' (Faction a) Text 46 | name_ = field @"name" 47 | 48 | relationships_ :: Lens (Faction a) (Faction b) [(a, Double)] [(b, Double)] 49 | relationships_ = field @"relationships" 50 | -------------------------------------------------------------------------------- /src/Starlight/Game.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DisambiguateRecordFields #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE NumericUnderscores #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | module Starlight.Game 10 | ( game 11 | ) where 12 | 13 | import Control.Algebra 14 | import Control.Carrier.Finally 15 | import Control.Carrier.Profile.Tree 16 | import Control.Carrier.Random.Gen 17 | import Control.Carrier.Reader 18 | import qualified Control.Carrier.State.STM.TVar as TVar 19 | import Control.Carrier.State.Church 20 | import Control.Effect.Lens.Exts as Lens 21 | import Control.Effect.Thread 22 | import Control.Effect.Trace 23 | import Control.Exception.Lift 24 | import Control.Monad.Fix 25 | import Control.Monad.IO.Class.Lift 26 | import qualified Data.Map as Map 27 | import GL 28 | import GL.Effect.Check 29 | import Linear.Exts 30 | import qualified SDL 31 | import Starlight.Actor 32 | import Starlight.Body 33 | import Starlight.Character 34 | import Starlight.Draw 35 | import Starlight.Identifier 36 | import Starlight.Input 37 | import Starlight.Integration 38 | import Starlight.Physics 39 | import Starlight.Radar 40 | import Starlight.Ship hiding (Component(..)) 41 | import qualified Starlight.Sol as Sol 42 | import Starlight.System as System 43 | import Starlight.Time 44 | import Starlight.UI 45 | import Stochastic.Sample.Markov 46 | import System.FilePath 47 | import System.Random.SplitMix (SMGen, newSMGen) 48 | import UI.Colour 49 | import UI.Context 50 | import UI.Label as Label 51 | import UI.Typeface (cacheCharactersForDrawing, readTypeface) 52 | import qualified UI.Window as Window 53 | import Unit.Count 54 | import Unit.Length 55 | 56 | runGame 57 | :: ( Has (Lift IO) sig m 58 | , MonadFail m 59 | ) 60 | => Map.Map BodyIdentifier Body 61 | -> ReaderC Epoch 62 | (StateC (Chain (V2 (Distance Double))) 63 | (TVar.StateC (System Body) 64 | (TVar.StateC Input 65 | (RandomC SMGen 66 | (LiftIO 67 | (FinallyC 68 | (GLC 69 | (ReaderC Context 70 | (ReaderC Window.Window m))))))))) a 71 | -> m a 72 | runGame bodies 73 | = Window.runSDL 74 | . Window.runWindow "Starlight" (V2 1024 768) 75 | . runContext 76 | . runGLC 77 | . runFinally 78 | . runLiftIO 79 | . (\ m -> sendM newSMGen >>= flip evalRandom m) 80 | . TVar.evalState @Input mempty 81 | . TVar.evalState System 82 | { bodies 83 | , players = Map.fromList 84 | [ ((0, "you"), Character 85 | { name = "you" 86 | , actor = Actor 87 | { position = convert <$> start 88 | , velocity = 0 89 | , rotation = axisAngle (unit _z) (pi/2) 90 | , mass = 1000 91 | , magnitude = convert magnitude 92 | } 93 | , target = Nothing 94 | , actions = mempty 95 | , ship = Ship{ colour = white, armour = 1_000, radar } 96 | }) 97 | ] 98 | , npcs = mempty 99 | } 100 | . evalState (Chain (0 :: V2 (Distance Double))) 101 | . runJ2000 102 | where 103 | magnitude :: Metres Double 104 | magnitude = 500 105 | -- stem-to-stern length; currently interpreted as “diameter” for hit testing 106 | -- compare: USS Gerald R. Ford is 337m long 107 | start :: V2 (Mega Metres Double) 108 | start = V2 2_500 0 109 | radar = Radar 1000 -- GW radar 110 | 111 | game 112 | :: ( Has Check sig m 113 | , Has (Lift IO) sig m 114 | , Has Profile sig m 115 | , HasLabelled Thread (Thread id) sig m 116 | , Has Trace sig m 117 | , MonadFail m 118 | , MonadFix m 119 | ) 120 | => m () 121 | game = Sol.runData Sol.loadBodies >>= \ bodies -> runGame bodies $ do 122 | SDL.cursorVisible SDL.$= False 123 | trace "loading typeface" 124 | face <- measure "readTypeface" $ readTypeface ("fonts" "DejaVuSans.ttf") 125 | measure "cacheCharactersForDrawing" . cacheCharactersForDrawing face $ ['0'..'9'] <> ['a'..'z'] <> ['A'..'Z'] <> ",.’/:-⁻⁰¹²³⁴⁵⁶⁷⁸⁹·" -- characters to preload 126 | 127 | target <- measure "label" Label.label 128 | 129 | start <- now 130 | integration <- fork . (>>= throwIO) . evalState start . fix $ \ loop -> do 131 | err <- try @SomeException (id <~> integration) 132 | case err of 133 | Left err -> pure err 134 | Right () -> yield >> loop 135 | 136 | enabled_ Blend .= True 137 | enabled_ DepthClamp .= True 138 | enabled_ LineSmooth .= True 139 | enabled_ ProgramPointSize .= True 140 | enabled_ ScissorTest .= True 141 | 142 | (runFrame . runReader UI{ target, face } . fix $ \ loop -> do 143 | measure "frame" frame 144 | measure "swap" Window.swap 145 | loop) 146 | `finally` kill integration 147 | -------------------------------------------------------------------------------- /src/Starlight/Identifier.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Starlight.Identifier 3 | ( Code 4 | , Name 5 | , Identifier(..) 6 | , describeIdentifier 7 | , CharacterIdentifier(..) 8 | , BodyIdentifier(..) 9 | , parent 10 | , rootLeaf 11 | , toList 12 | , getLeaf 13 | ) where 14 | 15 | import Data.Function (on) 16 | import Data.List.NonEmpty (NonEmpty(..)) 17 | import Data.Text 18 | 19 | type Code = Int 20 | 21 | type Name = Text 22 | 23 | data Identifier 24 | = B BodyIdentifier 25 | | C CharacterIdentifier 26 | deriving (Eq, Ord, Show) 27 | 28 | describeIdentifier :: Identifier -> String 29 | describeIdentifier = \case 30 | B i -> showLeaf (getLeaf i) where 31 | showLeaf (code, name) = show code <> " " <> unpack name 32 | C (NPC i) -> unpack (snd i) 33 | C (Player i) -> "player " <> unpack (snd i) 34 | 35 | data CharacterIdentifier 36 | = Player (Code, Name) 37 | | NPC (Code, Name) 38 | deriving (Eq, Ord, Show) 39 | 40 | data BodyIdentifier 41 | = Star (Code, Name) 42 | | BodyIdentifier :/ (Code, Name) 43 | deriving (Eq, Show) 44 | 45 | infixl 5 :/ 46 | 47 | instance Ord BodyIdentifier where compare = compare `on` toList 48 | 49 | parent :: BodyIdentifier -> Maybe BodyIdentifier 50 | parent = \case 51 | parent :/ _ -> Just parent 52 | _ -> Nothing 53 | 54 | rootLeaf :: BodyIdentifier -> (Code, Name) 55 | rootLeaf = \case 56 | parent :/ _ -> rootLeaf parent 57 | root -> getLeaf root 58 | 59 | toList :: BodyIdentifier -> NonEmpty (Code, Name) 60 | toList i = go i [] where 61 | go = \case 62 | Star leaf -> (leaf:|) 63 | i :/ leaf -> go i . (leaf:) 64 | 65 | getLeaf :: BodyIdentifier -> (Code, Name) 66 | getLeaf = \case 67 | Star leaf -> leaf 68 | _ :/ leaf -> leaf 69 | -------------------------------------------------------------------------------- /src/Starlight/Input.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | module Starlight.Input 5 | ( input 6 | , Input(..) 7 | , singleton 8 | , fromList 9 | , (\\) 10 | , key 11 | , pressed_ 12 | ) where 13 | 14 | import Control.Effect.Empty 15 | import Control.Effect.Lens ((.=)) 16 | import Control.Effect.Lift 17 | import Control.Effect.State 18 | import Control.Lens (Iso', Lens', coerced, lens) 19 | import qualified Data.IntSet as IntSet 20 | import qualified SDL 21 | import qualified UI.Window as Window 22 | 23 | input 24 | :: ( Has Empty sig m 25 | , Has (Lift IO) sig m 26 | , Has (State Input) sig m 27 | ) 28 | => m () 29 | input = Window.input go where 30 | go (SDL.Event _ p) = case p of 31 | SDL.QuitEvent -> empty 32 | SDL.KeyboardEvent (SDL.KeyboardEventData _ p _ ks) -> key p ks 33 | _ -> pure () 34 | 35 | 36 | newtype Input = Input { unInput :: IntSet.IntSet } 37 | deriving (Monoid, Semigroup) 38 | 39 | singleton :: SDL.Keycode -> Input 40 | singleton = Input . IntSet.singleton . fromIntegral . SDL.unwrapKeycode 41 | 42 | fromList :: [SDL.Keycode] -> Input 43 | fromList = Input . IntSet.fromList . map (fromIntegral . SDL.unwrapKeycode) 44 | 45 | input_ :: Iso' Input IntSet.IntSet 46 | input_ = coerced 47 | 48 | (\\) :: Input -> Input -> Input 49 | Input a \\ Input b = Input (a IntSet.\\ b) 50 | 51 | infixl 9 \\ 52 | 53 | 54 | key :: Has (State Input) sig m => SDL.InputMotion -> SDL.Keysym -> m () 55 | key m ks = pressed_ (SDL.keysymKeycode ks) .= case m of 56 | SDL.Pressed -> True 57 | SDL.Released -> False 58 | 59 | 60 | pressed_ :: SDL.Keycode -> Lens' Input Bool 61 | pressed_ code = input_ . lens 62 | (IntSet.member (fromIntegral (SDL.unwrapKeycode code))) 63 | (\ s pressed -> (if pressed then IntSet.insert else IntSet.delete) (fromIntegral (SDL.unwrapKeycode code)) s) 64 | -------------------------------------------------------------------------------- /src/Starlight/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE QuantifiedConstraints #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | module Starlight.Main 8 | ( main 9 | , Lifts 10 | ) where 11 | 12 | import Control.Algebra 13 | import qualified Control.Carrier.Profile.Identity as NoProfile 14 | import qualified Control.Carrier.Profile.Tree as Profile 15 | import Control.Carrier.Thread.IO 16 | import qualified Control.Carrier.Trace.Ignoring as NoTrace 17 | import qualified Control.Carrier.Trace.Lift as Trace 18 | import Control.Effect.Profile 19 | import Control.Effect.Trace 20 | import Control.Monad.Fix 21 | import Control.Monad.IO.Class.Lift 22 | import Data.Flag 23 | import Data.Kind (Constraint, Type) 24 | import qualified GL.Carrier.Check.Identity as NoCheck 25 | import qualified GL.Carrier.Check.IO as Check 26 | import GL.Effect.Check 27 | import qualified Starlight.CLI as CLI 28 | import Starlight.Game 29 | 30 | main :: IO () 31 | main = do 32 | options <- CLI.execParser CLI.argumentsParser 33 | runThread (runCheck (CLI.check options) (runProfile (CLI.profile options) (runTrace (CLI.trace options) game))) 34 | 35 | runProfile 36 | :: Has (Lift IO) sig m 37 | => Flag CLI.ShouldProfile 38 | -> (forall t . (Lifts MonadFail t, Lifts MonadFix t, Lifts MonadIO t, Algebra (Profile :+: sig) (t m)) => t m a) 39 | -> m a 40 | runProfile flag 41 | | fromFlag CLI.ShouldProfile flag = Profile.reportProfile 42 | | otherwise = NoProfile.runProfile 43 | 44 | runTrace 45 | :: Has (Lift IO) sig m 46 | => Flag CLI.ShouldTrace 47 | -> (forall t . (Lifts MonadFail t, Lifts MonadFix t, Lifts MonadIO t, Algebra (Trace :+: sig) (t m)) => t m a) 48 | -> m a 49 | runTrace flag 50 | | fromFlag CLI.ShouldTrace flag = Trace.runTrace 51 | | otherwise = NoTrace.runTrace 52 | 53 | runCheck 54 | :: Has (Lift IO) sig m 55 | => Flag CLI.ShouldCheck 56 | -> (forall t . (Lifts MonadFail t, Lifts MonadFix t, Lifts MonadIO t, Algebra (Check :+: sig) (t m)) => t m a) 57 | -> m a 58 | runCheck flag 59 | | fromFlag CLI.ShouldCheck flag = Check.runCheck 60 | | otherwise = NoCheck.runCheck 61 | 62 | type Lifts (c :: (Type -> Type) -> Constraint) t = ((forall m' . c m' => c (t m')) :: Constraint) 63 | -------------------------------------------------------------------------------- /src/Starlight/Physics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | module Starlight.Physics 4 | ( Distance 5 | , gravC 6 | , gravitation 7 | , radarRange 8 | ) where 9 | 10 | import Linear.Exts 11 | import Unit.Algebra 12 | import Unit.Force 13 | import Unit.Length 14 | import Unit.Mass 15 | import Unit.Power 16 | import Unit.Time 17 | 18 | type Distance = Giga Metres 19 | 20 | gravC :: Fractional a => (Metres :^: 3 :/: Kilo Grams :/: Seconds :^: 2) a 21 | gravC = 6.67430e-11 22 | 23 | gravitation :: (Metric v, Epsilon a, Floating a, Ord a) => Kilo Grams a -> Kilo Grams a -> v (Metres a) -> v (Metres a) -> Metres a -> v (Newtons a) 24 | gravitation m1 m2 p1 p2 r = ((m1 .*. m2 ./. max (sqU r) (p1 `qdU` p2)) .*. gravC) .*^ direction p2 p1 25 | -- FIXME: gravity seems extremely weak, measures as a factor of approximately 46 26 | 27 | radarRange :: Metric v => Watts Double -> I Double -> (Metres :^: 2) Double -> (Metres :^: 2) Double -> I Double -> v (Metres Double) -> v (Metres Double) -> Watts Double 28 | radarRange pt gain aperture crossSection patternPropagationFactor p1 p2 29 | = (pt .*. gain .*. aperture .*. crossSection .*. patternPropagationFactor ** 4) 30 | ./. (I ((4 * pi) ** 2) .*. r .*. r) 31 | where 32 | r = p1 `qdU` p2 33 | -------------------------------------------------------------------------------- /src/Starlight/Radar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | module Starlight.Radar 5 | ( Radar(..) 6 | , power_ 7 | ) where 8 | 9 | import Control.Lens 10 | import Data.Generics.Product.Fields 11 | import GHC.Generics (Generic) 12 | import Unit.Power 13 | 14 | -- FIXME: transmitter gain 15 | -- FIXME: effective aperture 16 | newtype Radar = Radar 17 | { power :: Mega Watts Double 18 | } 19 | deriving (Generic, Show) 20 | 21 | power_ :: Lens' Radar (Mega Watts Double) 22 | power_ = field @"power" 23 | -------------------------------------------------------------------------------- /src/Starlight/Ship.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | module Starlight.Ship 5 | ( Ship(..) 6 | , colour_ 7 | , armour_ 8 | , radar_ 9 | , Component(..) 10 | ) where 11 | 12 | import Control.Lens (Lens', Prism') 13 | import Data.Functor.I 14 | import Data.Functor.Interval 15 | import Data.Generics.Product.Fields 16 | import Data.Generics.Sum.Constructors 17 | import GHC.Generics (Generic) 18 | import Starlight.Radar 19 | import UI.Colour 20 | 21 | data Ship = Ship 22 | { colour :: Colour Float 23 | , armour :: Interval I Double 24 | , radar :: Radar 25 | } 26 | deriving (Generic, Show) 27 | 28 | instance HasColour Ship 29 | 30 | armour_ :: Lens' Ship (Interval I Double) 31 | armour_ = field @"armour" 32 | 33 | radar_ :: Lens' Ship Radar 34 | radar_ = field @"radar" 35 | 36 | 37 | data Component 38 | = Cargo 39 | | Engine 40 | | Fuel 41 | | Heatsink 42 | | Radar Radar 43 | | Weapon 44 | deriving (Generic, Show) 45 | 46 | _Radar :: Prism' Component Radar 47 | _Radar = _Ctor @"Radar" 48 | -------------------------------------------------------------------------------- /src/Starlight/Sol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DisambiguateRecordFields #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | -- | A familiar star system. 7 | module Starlight.Sol 8 | ( runData 9 | , loadBodies 10 | , loadFactions 11 | ) where 12 | 13 | import Control.Carrier.Database.SQLite 14 | import Control.Effect.Lift 15 | import Control.Lens (review) 16 | import Control.Monad.Fix 17 | import qualified Data.IntMap as IntMap 18 | import qualified Data.Map as Map 19 | import Database.SQLite3 (SQLData(..)) 20 | import Linear.Exts 21 | import Paths_starlight 22 | import Starlight.Body 23 | import Starlight.Faction 24 | import Starlight.Identifier 25 | import UI.Colour 26 | import Unit.Angle 27 | import Unit.Length 28 | import Unit.Mass 29 | import Unit.Time 30 | 31 | runData :: Has (Lift IO) sig m => DatabaseC m a -> m a 32 | runData m = sendM (getDataFileName "data/data.db") >>= \ file -> runDatabase file m 33 | 34 | loadBodies :: (HasLabelled Database (Database stmt) sig m, MonadFail m, MonadFix m) => m (Map.Map BodyIdentifier Body) 35 | loadBodies = execute "select rowid, * from bodies" $ \ stmt -> do 36 | entries <- mfix $ \ ephemerides -> fix (\ loop elems -> do 37 | res <- step stmt 38 | case res of 39 | Nothing -> pure elems 40 | Just [ SQLInteger rowid, parentId, SQLInteger code, SQLText name, SQLInteger population, SQLFloat radius, SQLFloat mass, SQLFloat tilt, SQLFloat rotationalPeriod, SQLInteger colour, SQLFloat eccentricity, SQLFloat semimajor, SQLFloat longitudeOfAscendingNode, SQLFloat inclination, SQLFloat argumentOfPerifocus, SQLFloat orbitalPeriod, SQLFloat timeOfPeriapsis ] -> do 41 | let leaf = (fromIntegral code, name) 42 | identifier = maybe (Star leaf) (:/ leaf) (lookupParent ephemerides parentId) 43 | entry = Body 44 | { population = fromIntegral population 45 | , radius = pure @(Kilo Metres) radius 46 | , mass = pure @(Kilo Grams) mass 47 | , rotation = Revolution 48 | { orientation = axisAngle (unit _x) (convert @Degrees (pure tilt)) 49 | , period = convert @Days @Seconds (pure rotationalPeriod) 50 | } 51 | , eccentricity = I eccentricity 52 | , semimajor = pure @(Kilo Metres) semimajor 53 | , revolution = Revolution 54 | { orientation = orient 55 | (convert @Degrees (pure longitudeOfAscendingNode)) 56 | (convert @Degrees (pure inclination)) 57 | (convert @Degrees (pure argumentOfPerifocus)) 58 | , period = pure @Seconds orbitalPeriod 59 | } 60 | , timeOfPeriapsis = pure @Seconds timeOfPeriapsis 61 | , colour = review packed (fromIntegral colour) 62 | } 63 | loop (IntMap.insert (fromIntegral rowid) (identifier, entry) elems) 64 | row -> fail $ "loadBodies.bodies: bad row: " <> show row) IntMap.empty 65 | pure $! Map.fromList (IntMap.elems entries) 66 | where 67 | lookupParent ephemerides = \case 68 | SQLInteger i -> fst <$> IntMap.lookup (fromIntegral i) ephemerides 69 | _ -> Nothing 70 | 71 | loadFactions :: (HasLabelled Database (Database stmt) sig m, MonadFail m) => m Factions 72 | loadFactions = do 73 | rs <- execute "select * from relationships" $ \ stmt -> fix (\ loop elems -> do 74 | res <- step stmt 75 | case res of 76 | Nothing -> pure elems 77 | Just [ SQLInteger faction1Id, SQLInteger faction2Id, SQLFloat rel ] -> 78 | loop (IntMap.insertWith (<>) (fromIntegral faction1Id) (IntMap.singleton (fromIntegral faction2Id) rel) elems) 79 | Just row -> fail $ "loadFactions.relationships: bad row: " <> show row) IntMap.empty 80 | 81 | fs <- execute "select rowid, * from factions" $ \ stmt -> fix (\ loop elems -> do 82 | res <- step stmt 83 | case res of 84 | Nothing -> pure elems 85 | Just [ SQLInteger rowid, SQLText name, SQLInteger colour ] -> 86 | loop (IntMap.insert (fromIntegral rowid) (Faction name (review packed (fromIntegral colour)) (IntMap.toList (rs IntMap.! fromIntegral rowid))) elems) 87 | Just row -> fail $ "loadFactions.factions: bad row: " <> show row) IntMap.empty 88 | pure $ factions fs 89 | -------------------------------------------------------------------------------- /src/Starlight/System.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DisambiguateRecordFields #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | module Starlight.System 10 | ( System(..) 11 | , bodies_ 12 | , player_ 13 | , players_ 14 | , npcs_ 15 | , characters_ 16 | , beams 17 | , identifiers 18 | , (!?) 19 | , neighbourhoodOf 20 | , neighbourhoodOfPlayer 21 | ) where 22 | 23 | import Control.Effect.Lens.Exts (asserting) 24 | import Control.Lens 25 | import Data.Either (partitionEithers) 26 | import Data.Generics.Product.Fields 27 | import qualified Data.Map.Strict as Map 28 | import Data.Maybe (fromMaybe) 29 | import GHC.Generics (Generic) 30 | import GHC.Stack (HasCallStack) 31 | import Linear.Exts (toAxisAngle) 32 | import Starlight.Actor 33 | import Starlight.Character 34 | import Starlight.Identifier 35 | import Starlight.Physics 36 | import Starlight.Radar 37 | import Starlight.Ship (radar_) 38 | import Starlight.Weapon.Laser 39 | import UI.Colour 40 | import Unit.Algebra 41 | import Unit.Length 42 | import Unit.Power 43 | 44 | data System a = System 45 | { bodies :: !(Map.Map BodyIdentifier a) 46 | , players :: !(Map.Map (Code, Name) Character) 47 | , npcs :: !(Map.Map (Code, Name) Character) 48 | } 49 | deriving (Generic, Show) 50 | 51 | bodies_ :: Lens (System a) (System b) (Map.Map BodyIdentifier a) (Map.Map BodyIdentifier b) 52 | bodies_ = field @"bodies" 53 | 54 | player_ :: HasCallStack => Lens' (System a) Character 55 | player_ = characters_.at (Player (0, "you")).iso (fromMaybe (error "player missing")) Just 56 | 57 | players_ :: Lens' (System a) (Map.Map (Code, Name) Character) 58 | players_ = field @"players" 59 | 60 | npcs_ :: Lens' (System a) (Map.Map (Code, Name) Character) 61 | npcs_ = field @"npcs" 62 | 63 | characters_ :: HasCallStack => Lens' (System a) (Map.Map CharacterIdentifier Character) 64 | characters_ = lens get set.asserting (Map.member (Player (0, "you"))) where 65 | get System{ players, npcs } = Map.mapKeys Player players <> Map.mapKeys NPC npcs 66 | set s cs = s{ players = Map.fromList p, npcs = Map.fromList n } where 67 | (p, n) = partitionEithers (map (\case{ (Player k, v) -> Left (k, v) ; (NPC k, v) -> Right (k, v) }) (Map.toList cs)) 68 | 69 | beams :: System a -> [Beam] 70 | beams = toListOf (characters_.itraversed.filtered (view (actions_.contains (Fire Main))).withIndex.to beam) where 71 | beam (i, c) = Beam{ position = c^.position_, angle = snd (toAxisAngle (c^.rotation_)), colour = green, firedBy = i } 72 | 73 | 74 | identifiers :: System a -> [Identifier] 75 | identifiers System{ bodies, players, npcs } = map (C . Player) (Map.keys players) <> map (C . NPC) (Map.keys npcs) <> map B (Map.keys bodies) 76 | 77 | (!?) :: System a -> Identifier -> Maybe (Either a Character) 78 | (!?) s = \case 79 | B i -> Left <$> s^?bodies_ .ix i 80 | C i -> Right <$> s^?characters_.ix i 81 | 82 | 83 | neighbourhoodOf :: HasActor a => Character -> System a -> System a 84 | neighbourhoodOf c sys@System{ bodies, players, npcs } = sys 85 | { bodies = Map.filterWithKey (visible . B) bodies 86 | , players = Map.filterWithKey (visible . C . Player) players 87 | , npcs = Map.filterWithKey (visible . C . NPC) npcs 88 | } where 89 | -- FIXME: occlusion 90 | -- FIXME: jamming 91 | -- FIXME: ghosts 92 | -- FIXME: doppler effect 93 | -- FIXME: radar cross-section, rather than just size 94 | -- FIXME: radar reflections 95 | -- FIXME: sharing radar with allies 96 | visible i a = case i of 97 | B (Star _) -> True 98 | _ -> received .>. threshold 99 | where 100 | received = radarRange (c^.ship_.radar_.power_.converting) gain (convert aperture) (convert crossSection) patternPropagationFactor (convert <$> a^.position_) (convert <$> c^.position_) 101 | crossSection = a^.magnitude_ .*. a^.magnitude_ 102 | aperture :: (Mega Metres :^: 2) Double 103 | aperture = 10 104 | gain = 1 105 | patternPropagationFactor = 1 106 | threshold :: Pico Watts Double 107 | threshold = 1 108 | 109 | neighbourhoodOfPlayer :: HasActor a => System a -> System a 110 | neighbourhoodOfPlayer sys = neighbourhoodOf (sys^.player_) sys 111 | -------------------------------------------------------------------------------- /src/Starlight/Time.hs: -------------------------------------------------------------------------------- 1 | module Starlight.Time 2 | ( now 3 | , since 4 | , timed 5 | ) where 6 | 7 | import Control.Carrier.Reader 8 | import Control.Effect.Lift 9 | import Control.Effect.State 10 | import Data.Time.Clock 11 | import Unit.Time 12 | 13 | now :: Has (Lift IO) sig m => m UTCTime 14 | now = sendM getCurrentTime 15 | 16 | since :: Has (Lift IO) sig m => UTCTime -> m NominalDiffTime 17 | since t = flip diffUTCTime t <$> now 18 | 19 | timed 20 | :: ( Has (Lift IO) sig m 21 | , Has (State UTCTime) sig m 22 | ) 23 | => ReaderC (Seconds Double) m a 24 | -> m a 25 | timed m = do 26 | dt <- fmap realToFrac . since =<< get 27 | put =<< now 28 | runReader dt m 29 | -------------------------------------------------------------------------------- /src/Starlight/UI.hs: -------------------------------------------------------------------------------- 1 | module Starlight.UI 2 | ( UI(..) 3 | ) where 4 | 5 | import UI.Label 6 | import UI.Typeface 7 | 8 | data UI = UI 9 | { target :: Label 10 | , face :: Typeface 11 | } 12 | -------------------------------------------------------------------------------- /src/Starlight/View.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE DisambiguateRecordFields #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE NumericUnderscores #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | module Starlight.View 10 | ( View(..) 11 | , contextSize 12 | , lengthToWindowPixels 13 | , zoomForSpeed 14 | , withView 15 | -- * Transforms 16 | , transformToWindow 17 | , transformToZoomed 18 | , transformToSystem 19 | -- * Viewport 20 | , clipTo 21 | -- * Re-exports 22 | , module Geometry.Transform 23 | ) where 24 | 25 | import Control.Carrier.Reader 26 | import Control.Effect.Lens (view) 27 | import Control.Effect.Lift 28 | import Control.Lens ((&), (.~)) 29 | import Data.Coerce 30 | import Data.Functor.I 31 | import Data.Functor.Interval 32 | import Geometry.Transform 33 | import GL.Shader.DSL (ClipUnits(..)) 34 | import GL.Viewport 35 | import Linear.Exts 36 | import Starlight.Actor 37 | import Starlight.Body 38 | import Starlight.Physics 39 | import Starlight.System 40 | import UI.Context as Context 41 | import UI.Window as Window 42 | import Unit.Algebra 43 | import Unit.Length 44 | import Unit.Time 45 | 46 | data View = View 47 | { ratio :: I Int -- ^ Ratio of window pixels per context pixel. 48 | , size :: V2 (Window.Coords Int) 49 | , zoom :: I Double 50 | , scale :: (Window.Coords :/: Distance) Double 51 | , shipScale :: I Double 52 | , focus :: V2 (Distance Double) 53 | } 54 | 55 | contextSize :: View -> V2 (Context.Pixels Int) 56 | contextSize View{ ratio, size } = Context.Pixels . Window.getCoords <$> ratio .*^ size 57 | 58 | lengthToWindowPixels :: View -> (Window.Coords :/: Distance) Double 59 | lengthToWindowPixels View{ zoom, scale } = scale .*. zoom 60 | 61 | -- | Compute the zoom factor for the given velocity. 62 | -- 63 | -- Higher values correlate to more of the scene being visible. 64 | zoomForSpeed :: V2 (Window.Coords Int) -> (Distance :/: Seconds) Double -> I Double 65 | zoomForSpeed size x 66 | | distance < inf bounds = inf zoom 67 | | distance > sup bounds = sup zoom 68 | | otherwise = fromUnit zoom (coerce easeInOutCubic (toUnit bounds distance)) 69 | where 70 | hypotenuse = norm (fmap fromIntegral <$> size) 71 | distance = I (convert @Distance @(Mega Metres) (x .*. Seconds 1) ./. hypotenuse) -- how much of the screen will be traversed in a second 72 | zoom = 1...1/5 73 | bounds = (1...(20 :: Mega Metres Double)) ^/. hypotenuse 74 | 75 | withView 76 | :: ( Has (Lift IO) sig m 77 | , Has (Reader (System StateVectors)) sig m 78 | , Has (Reader Window.Window) sig m 79 | ) 80 | => ReaderC View m a 81 | -> m a 82 | withView m = do 83 | ratio <- Window.ratio 84 | size <- Window.size 85 | 86 | velocity <- view (player_ @StateVectors .velocity_) 87 | focus <- view (player_ @StateVectors .position_._xy) 88 | 89 | let zoom = zoomForSpeed size (norm velocity) 90 | -- how many pixels to draw something / the radius of the sun 91 | scale = Window.Coords 695_500 ./. convert @(Kilo Metres) @Distance 695_500 92 | -- FIXME: this is really stupid; there *has* to be a better way to say “I want a 500 m ship to be 30 px long” or w/e 93 | shipScale = 30 94 | 95 | runReader View{ ratio, size, zoom, scale, shipScale, focus } m 96 | 97 | 98 | transformToWindow :: View -> Transform V4 Double Window.Coords ClipUnits 99 | transformToWindow View{ size } 100 | -- NB: we *always* use 2/size, rather than ratio/size, because clip space always extends from -1...1, i.e. it always has diameter 2. this is true irrespective of the DPI ratio. 101 | = mkScale (pure 1 & _xy .~ ClipUnits 2 ./^ (fmap fromIntegral <$> size)) 102 | 103 | transformToZoomed :: View -> Transform V4 Double Window.Coords ClipUnits 104 | transformToZoomed view@View{ zoom } 105 | = transformToWindow view 106 | <<< mkScale (pure zoom) 107 | 108 | transformToSystem :: View -> Transform V4 Double Distance ClipUnits 109 | transformToSystem view@View{ scale, focus } 110 | = transformToZoomed view 111 | <<< mkScale (pure scale) 112 | <<< mkTranslation (ext (negated focus) 0) 113 | 114 | 115 | clipTo :: Has (Lift IO) sig m => View -> m () 116 | clipTo view = do 117 | let dsize = contextSize view 118 | viewport $ Interval 0 dsize 119 | scissor $ Interval 0 dsize 120 | -------------------------------------------------------------------------------- /src/Starlight/Weapon/Laser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DisambiguateRecordFields #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | module Starlight.Weapon.Laser 4 | ( Beam(..) 5 | ) where 6 | 7 | import Control.Lens 8 | import Data.Functor.I 9 | import Linear.Exts 10 | import qualified Starlight.Actor as Actor 11 | import Starlight.Identifier 12 | import Starlight.Physics 13 | import UI.Colour 14 | 15 | data Beam = Beam 16 | { position :: V2 (Distance Double) 17 | , angle :: I Double 18 | , colour :: Colour Float 19 | , firedBy :: CharacterIdentifier 20 | } 21 | deriving (Show) 22 | 23 | instance Actor.HasActor Beam where 24 | actor_ = lens get set where 25 | get Beam{ position, angle } = Actor.Actor{ position, velocity = 0, rotation = axisAngle (unit _z) angle, mass = 0, magnitude = 1 } 26 | set beam Actor.Actor{ position, rotation } = beam{ position, angle = snd (toAxisAngle rotation) } 27 | -------------------------------------------------------------------------------- /src/Stochastic/Distribution.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE MultiWayIf #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | module Stochastic.Distribution 5 | ( normalPDF 6 | , normal 7 | , standard 8 | , standardFrom 9 | ) where 10 | 11 | import Control.Effect.Random 12 | import Data.Bits 13 | import qualified Data.Vector.Unboxed as I 14 | import Data.Word 15 | import Stochastic.PDF 16 | import qualified System.Random as R 17 | 18 | normalPDF :: Floating a => a -> a -> PDF a a 19 | normalPDF mean stddev = PDF $ \ x -> 20 | (1 / (stddev * sqrt (2 * pi))) * exp (-0.5 * ((x - mean) / stddev) ** 2) 21 | 22 | 23 | -- Taken from mwc-random 24 | 25 | -- | Generate a normally distributed random variate with given mean 26 | -- and standard deviation. 27 | normal :: (Fractional a, Has Random sig m) 28 | => a -- ^ Mean 29 | -> a -- ^ Standard deviation 30 | -> m a 31 | normal m s = do 32 | x <- standard 33 | pure $! m + s * x 34 | {-# INLINE normal #-} 35 | 36 | -- | Generate a normally distributed random variate with zero mean and 37 | -- unit variance. 38 | -- 39 | -- The implementation uses Doornik's modified ziggurat algorithm. 40 | -- Compared to the ziggurat algorithm usually used, this is slower, 41 | -- but generates more independent variates that pass stringent tests 42 | -- of randomness. 43 | standard :: (Fractional a, Has Random sig m) => m a 44 | standard = standardFrom uniform 45 | {-# INLINE standard #-} 46 | 47 | standardFrom :: (Fractional a, Monad m) => (forall a . R.Random a => m a) -> m a 48 | standardFrom uniform = realToFrac <$> loop where 49 | loop = do 50 | u <- subtract 1 . (*2) <$> uniform 51 | ri <- uniform 52 | let i = fromIntegral ((ri :: Word32) .&. 127) 53 | bi = I.unsafeIndex blocks i 54 | bj = I.unsafeIndex blocks (i+1) 55 | if| abs u < I.unsafeIndex ratios i -> pure $! u * bi 56 | | i == 0 -> normalTail (u < 0) 57 | | otherwise -> do 58 | let x = u * bi 59 | xx = x * x 60 | d = exp (-0.5 * (bi * bi - xx)) 61 | e = exp (-0.5 * (bj * bj - xx)) 62 | c <- uniform 63 | if e + c * (d - e) < 1 then 64 | pure x 65 | else 66 | loop 67 | normalTail neg = tailing 68 | where 69 | tailing = do 70 | x <- (/rNorm) . log <$> uniform 71 | y <- log <$> uniform 72 | if y * (-2) < x * x then 73 | tailing 74 | else 75 | pure $! if neg then x - rNorm else rNorm - x 76 | {-# INLINE standardFrom #-} 77 | 78 | -- Constants used by standard/normal. They are floated to the top 79 | -- level to avoid performance regression (Bug #16) when blocks/ratios 80 | -- are recalculated on each call to standard/normal. It's also 81 | -- somewhat difficult to trigger reliably. 82 | blocks :: I.Vector Double 83 | blocks = (`I.snoc` 0) . I.cons (v/f) . I.cons rNorm . I.unfoldrN 126 go $! T rNorm f 84 | where 85 | go (T b g) 86 | | let !u = T h (exp (-0.5 * h * h)) 87 | h = sqrt (-2 * log (v / b + g)) 88 | = Just (h, u) 89 | v = 9.91256303526217e-3 90 | f = exp (-0.5 * rNorm * rNorm) 91 | {-# NOINLINE blocks #-} 92 | 93 | rNorm :: Double 94 | rNorm = 3.442619855899 95 | 96 | ratios :: I.Vector Double 97 | ratios = I.zipWith (/) (I.tail blocks) blocks 98 | {-# NOINLINE ratios #-} 99 | 100 | -- Unboxed 2-tuple 101 | data T = T {-# UNPACK #-} !Double {-# UNPACK #-} !Double 102 | -------------------------------------------------------------------------------- /src/Stochastic/Histogram.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | module Stochastic.Histogram 4 | ( histogram 5 | , histogram2 6 | , sparkify 7 | , sparkify2 8 | , printHistogram 9 | , printHistogram2 10 | ) where 11 | 12 | import Control.Effect.Lift 13 | import Control.Lens (ix, (&), (+~), (^.)) 14 | import Control.Monad (replicateM) 15 | import Data.Foldable (foldl') 16 | import Data.Functor.I 17 | import Data.Functor.Interval 18 | import qualified Data.Vector.Unboxed as U 19 | import qualified Data.Vector as V 20 | import Linear.V2 21 | import System.Console.Terminal.Size as Size 22 | 23 | histogram :: RealFrac a => Interval I a -> I Int -> [I a] -> U.Vector Int 24 | histogram interval n = foldl' bucket (U.replicate (getI n) 0) 25 | where 26 | which sample = floor (toUnit interval sample * fromIntegral n) 27 | bucket accum sample = accum & ix (which sample) +~ 1 28 | 29 | histogram2 :: RealFrac a => Interval V2 a -> V2 Int -> [V2 a] -> V.Vector (U.Vector Int) 30 | histogram2 interval n = foldl' bucket (V.replicate (n ^. _y) (U.replicate (n ^. _x) 0)) 31 | where 32 | which sample = fmap floor . (*) <$> toUnit interval sample <*> (fromIntegral <$> n) 33 | bucket accum sample = accum & ix x.ix y +~ 1 where 34 | V2 x y = which sample 35 | 36 | sparkify :: [Int] -> String 37 | sparkify bins = sparkifyRelativeTo (maximum bins) bins 38 | 39 | sparkify2 :: [[Int]] -> [String] 40 | sparkify2 bins = map (sparkifyRelativeTo max) bins 41 | where 42 | max = maximum (map maximum bins) 43 | 44 | sparkifyRelativeTo :: Int -> [Int] -> String 45 | sparkifyRelativeTo max bins 46 | | null bins = "" 47 | | otherwise = spark <$> bins 48 | where 49 | sparks = " ▁▂▃▄▅▆▇█" 50 | maxSpark = fromIntegral $ length sparks - 1 51 | spark n = sparks !! round ((fromIntegral n / fromIntegral max :: Double) * maxSpark) 52 | 53 | printHistogram :: (RealFrac a, Has (Lift IO) sig m) => Interval I a -> Int -> m a -> m () 54 | printHistogram interval n m = do 55 | s <- maybe 80 Size.width <$> sendM Size.size 56 | samples <- replicateM n (fmap I m) 57 | sendM (putStrLn (sparkify (U.toList (histogram interval s samples)))) 58 | 59 | printHistogram2 :: (RealFrac a, Has (Lift IO) sig m) => Interval V2 a -> Int -> m (V2 a) -> m () 60 | printHistogram2 interval n m = do 61 | s <- maybe 80 (pure . Size.width) <$> sendM Size.size 62 | samples <- replicateM n m 63 | sendM (putStrLn (unlines (sparkify2 (map U.toList (V.toList (histogram2 interval s samples)))))) 64 | -------------------------------------------------------------------------------- /src/Stochastic/PDF.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | module Stochastic.PDF 4 | ( PDF(..) 5 | ) where 6 | 7 | import Control.Applicative (liftA2) 8 | import Data.Semigroup (Sum(..)) 9 | 10 | newtype PDF a b = PDF { runPDF :: a -> b } 11 | deriving (Applicative, Functor, Monad) 12 | deriving (Monoid, Semigroup) via (a -> Sum b) 13 | 14 | instance Num b => Num (PDF a b) where 15 | (+) = liftA2 (+) 16 | (-) = liftA2 (-) 17 | (*) = liftA2 (*) 18 | negate = fmap negate 19 | abs = fmap abs 20 | signum = fmap signum 21 | fromInteger = pure . fromInteger 22 | 23 | instance Fractional b => Fractional (PDF a b) where 24 | (/) = liftA2 (/) 25 | recip = fmap recip 26 | fromRational = pure . fromRational 27 | 28 | instance Floating b => Floating (PDF a b) where 29 | pi = pure pi 30 | exp = fmap exp 31 | log = fmap log 32 | sqrt = fmap sqrt 33 | (**) = liftA2 (**) 34 | logBase = liftA2 logBase 35 | sin = fmap sin 36 | cos = fmap cos 37 | tan = fmap tan 38 | asin = fmap asin 39 | acos = fmap acos 40 | atan = fmap atan 41 | sinh = fmap sinh 42 | cosh = fmap cosh 43 | tanh = fmap tanh 44 | asinh = fmap asinh 45 | acosh = fmap acosh 46 | atanh = fmap atanh 47 | -------------------------------------------------------------------------------- /src/Stochastic/Sample/Markov.hs: -------------------------------------------------------------------------------- 1 | module Stochastic.Sample.Markov 2 | ( Chain(..) 3 | ) where 4 | 5 | newtype Chain a = Chain { getChain :: a } 6 | -------------------------------------------------------------------------------- /src/Stochastic/Sample/Metropolis.hs: -------------------------------------------------------------------------------- 1 | module Stochastic.Sample.Metropolis 2 | ( burnIn 3 | , sample 4 | ) where 5 | 6 | import Control.Effect.Random 7 | import Control.Effect.State 8 | import Control.Monad (replicateM_) 9 | import Stochastic.PDF 10 | import qualified System.Random as R 11 | 12 | burnIn :: (R.Random b, Fractional b, Ord b, Has Random sig m, Has (State a) sig m) => Int -> (a -> m a) -> PDF a b -> m () 13 | burnIn i proposal = replicateM_ i . sample proposal 14 | 15 | 16 | sample :: (R.Random b, Fractional b, Ord b, Has Random sig m, Has (State a) sig m) => (a -> m a) -> PDF a b -> m a 17 | sample proposal (PDF pdf) = do 18 | x <- get 19 | x' <- proposal x 20 | let alpha = min 1 (pdf x' / pdf x) 21 | u <- uniform 22 | if u <= alpha then 23 | x' <$ put x' 24 | else 25 | pure x 26 | -------------------------------------------------------------------------------- /src/Stochastic/Sample/Rejection.hs: -------------------------------------------------------------------------------- 1 | module Stochastic.Sample.Rejection 2 | ( sample 3 | ) where 4 | 5 | import Control.Effect.Random 6 | import Data.Function (fix) 7 | import Stochastic.PDF 8 | import qualified System.Random as R 9 | 10 | sample :: (R.Random b, Num b, Ord b, Has Random sig m) => m a -> b -> PDF a b -> m a 11 | sample sample maxPdf pdf = fix $ \ loop -> do 12 | x <- sample 13 | y <- uniformR (0, maxPdf) 14 | if y <= runPDF pdf x then 15 | pure x 16 | else 17 | loop 18 | -------------------------------------------------------------------------------- /src/Stochastic/Sample/Slice.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | module Stochastic.Sample.Slice 5 | ( sample 6 | ) where 7 | 8 | import Control.Applicative (liftA2) 9 | import Control.Carrier.Random.Gen 10 | import Control.Effect.State 11 | import Control.Lens (over, (&)) 12 | import Data.Functor.Interval 13 | import Stochastic.PDF 14 | import Stochastic.Sample.Markov 15 | import qualified System.Random as R 16 | 17 | sample 18 | :: ( Applicative f 19 | , Traversable f 20 | , Applicative g 21 | , Traversable g 22 | , R.Random a 23 | , R.Random b 24 | , Num a 25 | , Ord a 26 | , Num b 27 | , Ord (g b) 28 | , Has Random sig m 29 | , Has (State (Chain (f a))) sig m 30 | ) 31 | => Interval f a 32 | -> Interval f a 33 | -> PDF (f a) (g b) 34 | -> m (f a) 35 | sample w bounds (PDF pdf) = do 36 | x <- gets getChain 37 | x <- if x `member` bounds then 38 | pure x 39 | else 40 | uniformI bounds 41 | y <- uniformI (Interval (pure 0) (pdf x)) 42 | u <- uniformI w 43 | let step i 44 | -- if any coordinate of the interval’s min is in-bounds… 45 | | or (inf i ^>^ inf bounds) 46 | -- … & it still lies under the curve, step the min outwards 47 | , y < pdf (inf i) = step (i & over inf_ (^-^ size w)) 48 | -- if any coordinate of the interval’s max is in-bounds… 49 | | or (sup i ^<^ sup bounds) 50 | -- … & it still lies under the curve, step the max outwards 51 | , y < pdf (sup i) = step (i & over sup_ (^+^ size w)) 52 | | otherwise = i 53 | shrink i = uniformI i >>= \case 54 | x' | y < pdf x' -> x' <$ put (Chain x') 55 | | otherwise -> shrink ((mn...mx) <*> point x <*> point x' <*> i) 56 | mn x x' i = if x' < x then x' else i 57 | mx x x' i = if x' < x then i else x' 58 | (^-^) = liftA2 (-) 59 | (^+^) = liftA2 (+) 60 | (^<^) = liftA2 (<) 61 | (^>^) = liftA2 (>) 62 | 63 | shrink (intersection bounds (step (point (x ^-^ u) + w))) 64 | -------------------------------------------------------------------------------- /src/UI/Colour.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | module UI.Colour 8 | ( Colour 9 | , black 10 | , white 11 | , transparent 12 | , red 13 | , green 14 | , blue 15 | , uniformRGB 16 | , _r 17 | , _g 18 | , _b 19 | , _a 20 | , opaque 21 | , setClearColour 22 | , packed 23 | , HasColour(..) 24 | ) where 25 | 26 | import Control.Effect.Random 27 | import Control.Lens 28 | import Control.Monad.IO.Class.Lift 29 | import Data.Bits 30 | import Data.Generics.Product.Fields 31 | import Data.Word 32 | import Graphics.GL.Core41 33 | import Linear.V4 34 | 35 | type Colour = V4 36 | 37 | black :: Num a => Colour a 38 | black = V4 0 0 0 1 39 | 40 | white :: Num a => Colour a 41 | white = V4 1 1 1 1 42 | 43 | transparent :: Num a => Colour a 44 | transparent = V4 0 0 0 0 45 | 46 | 47 | red :: Num a => Colour a 48 | red = V4 1 0 0 1 49 | 50 | green :: Num a => Colour a 51 | green = V4 0 1 0 1 52 | 53 | blue :: Num a => Colour a 54 | blue = V4 0 0 1 1 55 | 56 | 57 | uniformRGB :: (RealFrac a, Has Random sig m) => m (Colour a) 58 | uniformRGB = review packed . (.|. 0xff) <$> uniform 59 | 60 | 61 | _r :: R1 t => Lens' (t a) a 62 | _r = _x 63 | 64 | _g :: R2 t => Lens' (t a) a 65 | _g = _y 66 | 67 | _b :: R3 t => Lens' (t a) a 68 | _b = _z 69 | 70 | _a :: R4 t => Lens' (t a) a 71 | _a = _w 72 | 73 | 74 | opaque :: Num a => Colour a -> Colour a 75 | opaque = set _a 1 76 | 77 | 78 | setClearColour :: (Real a, Has (Lift IO) sig m) => Colour a -> m () 79 | setClearColour (fmap realToFrac -> V4 r g b a) = runLiftIO $ glClearColor r g b a 80 | 81 | 82 | packed :: (RealFrac a, Fractional b) => Iso (Colour a) (Colour b) Word32 Word32 83 | packed = iso pack unpack 84 | where 85 | pack (fmap (round . (* 255)) -> V4 r g b a) = shiftL r 24 .|. shiftL g 16 .|. shiftL b 8 .|. a :: Word32 86 | unpack i = (/ 255) . fromIntegral <$> V4 (0xff .&. shiftR i 24) (0xff .&. shiftR i 16) (0xff .&. shiftR i 8) (0xff .&. i) 87 | 88 | 89 | class HasColour t where 90 | colour_ :: Lens' t (Colour Float) 91 | default colour_ :: HasField "colour" t t (Colour Float) (Colour Float) => Lens' t (Colour Float) 92 | colour_ = field @"colour" 93 | 94 | instance HasColour (V4 Float) where 95 | colour_ = id 96 | -------------------------------------------------------------------------------- /src/UI/Context.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | module UI.Context 7 | ( Context 8 | , Pixels(..) 9 | , runContext 10 | ) where 11 | 12 | import Control.Carrier.Reader 13 | import Control.Effect.Lift 14 | import qualified Control.Exception.Lift as E 15 | import Control.Monad.IO.Class.Lift 16 | import Data.Functor.I 17 | import Data.Functor.K 18 | import Foreign.Storable 19 | import GL.Type as GL 20 | import GL.Uniform 21 | import Graphics.GL.Core41 22 | import SDL 23 | import System.Random (Random) 24 | import Unit.Length 25 | 26 | type Context = GLContext 27 | 28 | newtype Pixels a = Pixels { getPixels :: a } 29 | deriving (Column, Conjugate, Enum, Epsilon, Eq, Foldable, Floating, Fractional, Functor, Integral, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 30 | deriving (Additive, Applicative, Metric, Monad) via I 31 | 32 | instance Unit Length Pixels where 33 | suffix = K ("px"++) 34 | 35 | runContext :: (Has (Lift IO) sig m, Has (Reader Window) sig m) => ReaderC Context m a -> m a 36 | runContext = E.bracket 37 | (ask >>= runLiftIO . glCreateContext) 38 | (\ c -> runLiftIO (glFinish >> glDeleteContext c)) 39 | . flip runReader 40 | -------------------------------------------------------------------------------- /src/UI/Drawable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | module UI.Drawable 3 | ( Drawable(..) 4 | , using 5 | , runDrawable 6 | , loadingDrawable 7 | ) where 8 | 9 | import Control.Carrier.Reader 10 | import Control.Effect.Finally 11 | import Control.Effect.Lift 12 | import Control.Effect.Trace 13 | import Data.Functor.I 14 | import Foreign.Storable (Storable) 15 | import GL.Array 16 | import GL.Effect.Check 17 | import GL.Program 18 | import GL.Shader.DSL (RShader, Vars) 19 | 20 | data Drawable u v o = Drawable 21 | { program :: Program u v o 22 | , array :: Array (v I) 23 | } 24 | 25 | using 26 | :: ( Has Check sig m 27 | , Has (Lift IO) sig m 28 | , Has (Reader a) sig m 29 | , Vars u 30 | ) 31 | => (a -> Drawable u v o) 32 | -> ArrayC v (ProgramC u v o m) b 33 | -> m b 34 | using getDrawable m = do 35 | Drawable { program, array } <- asks getDrawable 36 | use program $ bindArray array m 37 | 38 | 39 | runDrawable :: (Drawable u v o -> b) -> Drawable u v o -> ReaderC b m a -> m a 40 | runDrawable makeDrawable = runReader . makeDrawable 41 | 42 | loadingDrawable :: (Has Check sig m, Has Finally sig m, Has (Lift IO) sig m, Has Trace sig m, Storable (v I), Vars u, Vars v) => (Drawable u v o -> b) -> RShader u v o -> [v I] -> ReaderC b m a -> m a 43 | loadingDrawable drawable shader vertices m = do 44 | program <- build shader 45 | (_, array) <- load vertices 46 | runDrawable drawable Drawable{ program, array } m 47 | -------------------------------------------------------------------------------- /src/UI/Glyph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DisambiguateRecordFields #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | module UI.Glyph 6 | ( Glyph(..) 7 | , Instance(..) 8 | , layoutGlyphs 9 | , Run(..) 10 | , HasBounds(..) 11 | ) where 12 | 13 | import Data.Foldable (foldl') 14 | import Data.Functor.I 15 | import Data.Functor.Interval 16 | import qualified Data.Map as Map 17 | import Data.Maybe (fromMaybe) 18 | import Linear.V2 19 | import Linear.V4 (V4) 20 | 21 | data Glyph = Glyph 22 | { char :: {-# UNPACK #-} !Char 23 | , advanceWidth :: {-# UNPACK #-} !Int 24 | , geometry :: ![V4 Int] 25 | , bounds_ :: {-# UNPACK #-} !(Interval V2 Int) 26 | } 27 | 28 | 29 | data Instance = Instance 30 | { offset :: {-# UNPACK #-} !Int 31 | , range :: {-# UNPACK #-} !(Interval I Int) 32 | } 33 | 34 | 35 | layoutGlyphs :: Map.Map Char (Interval I Int) -> [Glyph] -> Run 36 | layoutGlyphs chars = (Run . ($ []) . result <*> bounds) . foldl' go (LayoutState 0 id Nothing) where 37 | go (LayoutState offset is prev) g@Glyph{ char, bounds_ } = LayoutState 38 | { offset = offset + advanceWidth g 39 | , result = is . (Instance offset (fromMaybe (point 0) (chars Map.!? char)) :) 40 | , bounds_ = prev <> Just (Union (point (V2 offset 0) + bounds_)) 41 | } 42 | 43 | data LayoutState = LayoutState 44 | { offset :: {-# UNPACK #-} !Int 45 | , result :: !([Instance] -> [Instance]) 46 | , bounds_ :: !(Maybe (Union V2 Int)) 47 | } 48 | 49 | data Run = Run 50 | { instances :: ![Instance] 51 | , bounds_ :: {-# UNPACK #-} !(Interval V2 Int) 52 | } 53 | 54 | 55 | class HasBounds t where 56 | bounds :: t -> Interval V2 Int 57 | 58 | instance HasBounds Glyph where 59 | bounds = bounds_ 60 | 61 | instance HasBounds LayoutState where 62 | bounds LayoutState{ bounds_ } = maybe (point 0) getUnion bounds_ 63 | 64 | instance HasBounds t => HasBounds [t] where 65 | bounds = maybe (point 0) getUnion . foldMap (Just . Union . bounds) 66 | 67 | instance HasBounds (V2 Int) where 68 | bounds = point 69 | 70 | instance HasBounds (V2 Float) where 71 | bounds = point . fmap round 72 | -------------------------------------------------------------------------------- /src/UI/Graph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DisambiguateRecordFields #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | module UI.Graph 7 | ( Graph 8 | , mkGraph 9 | , drawGraph 10 | ) where 11 | 12 | import Control.Carrier.Finally 13 | import Control.Effect.Lens ((?=)) 14 | import Control.Effect.Trace (Trace) 15 | import Control.Lens ((^.)) 16 | import Control.Monad.IO.Class.Lift 17 | import Data.Coerce 18 | import Data.Functor.I 19 | import Data.Functor.Interval 20 | import GL.Array 21 | import GL.Effect.Check 22 | import GL.Program 23 | import GL.Shader.DSL (ClipUnits(..)) 24 | import Graphics.GL.Core41 25 | import Linear.Exts 26 | import UI.Colour 27 | import qualified UI.Graph.Lines as Lines 28 | import qualified UI.Graph.Points as Points 29 | import UI.Graph.Vertex 30 | 31 | data Graph = Graph 32 | { matrix :: !(M33 (ClipUnits Float)) 33 | , colour :: !(V4 Float) 34 | , array :: !(Array (V I)) 35 | , points :: !(Program Points.U V Points.Frag) 36 | , lines :: !(Program Lines.U V Lines.Frag) 37 | , pointSize :: !Float 38 | , count :: !Int 39 | } 40 | 41 | mkGraph :: (Has Check sig m, Has Finally sig m, Has (Lift IO) sig m, Has Trace sig m) => (Float -> Float) -> Int -> Float -> Float -> m Graph 42 | mkGraph f n from to = do 43 | let vertex = V2 <*> f 44 | count = max n 0 + 2 45 | vertices = map (\ i -> vertex (from + (to - from) * fromIntegral i / fromIntegral (count - 1))) [0..n+1] 46 | minXY = V2 from (minimum (map (^. _y) vertices)) 47 | maxXY = V2 to (maximum (map (^. _y) vertices)) 48 | matrix 49 | = coerce 50 | $ translated (-1) 51 | !*! scaled (ext (2 / (maxXY - minXY)) 1) 52 | !*! translated (negated minXY) 53 | colour = white 54 | (_, array) <- load (coerce @[V2 Float] vertices) 55 | points <- build Points.shader 56 | lines <- build Lines.shader 57 | 58 | pure $! Graph { matrix, colour, array, points, lines, pointSize = 9, count } 59 | 60 | drawGraph :: (Has Check sig m, Has (Lift IO) sig m) => Graph -> m () 61 | drawGraph Graph { matrix, colour, array, points, lines, pointSize, count } = bindArray array $ do 62 | runLiftIO (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA) 63 | use points $ do 64 | Points.matrix_ ?= matrix 65 | Points.pointSize_ ?= pointSize 66 | Points.colour_ ?= colour 67 | drawArrays Points (0...count) 68 | use lines $ do 69 | Lines.matrix_ ?= matrix 70 | Lines.colour_ ?= colour 71 | drawArrays LineStrip (0...count) 72 | -------------------------------------------------------------------------------- /src/UI/Graph/Lines.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | module UI.Graph.Lines 6 | ( shader 7 | , U(..) 8 | , matrix_ 9 | , colour_ 10 | , V(..) 11 | , Frag(..) 12 | ) where 13 | 14 | import Control.Lens (Lens') 15 | import Data.Generics.Product.Fields 16 | import GHC.Generics (Generic) 17 | import GL.Shader.DSL 18 | import UI.Graph.Vertex 19 | 20 | shader :: Shader shader => shader U V Frag 21 | shader 22 | = vertex (\ U{ matrix } V{ pos } None -> main $ 23 | gl_Position .= ext4 (ext3 ((matrix !* ext3 pos 1) ^. _xy) 0) 1) 24 | 25 | >>> fragment (\ U{ colour } None Frag{ fragColour } -> main $ 26 | fragColour .= colour) 27 | 28 | 29 | data U v = U 30 | { matrix :: v (M33 (ClipUnits Float)) 31 | , colour :: v (Colour Float) 32 | } 33 | deriving (Generic) 34 | 35 | instance Vars U 36 | 37 | matrix_ :: Lens' (U v) (v (M33 (ClipUnits Float))) 38 | matrix_ = field @"matrix" 39 | 40 | colour_ :: Lens' (U v) (v (Colour Float)) 41 | colour_ = field @"colour" 42 | -------------------------------------------------------------------------------- /src/UI/Graph/Points.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | module UI.Graph.Points 6 | ( shader 7 | , U(..) 8 | , matrix_ 9 | , pointSize_ 10 | , colour_ 11 | , V(..) 12 | , Frag(..) 13 | ) where 14 | 15 | import Control.Lens (Lens') 16 | import Data.Generics.Product.Fields 17 | import GHC.Generics (Generic) 18 | import GL.Shader.DSL 19 | import UI.Graph.Vertex 20 | 21 | shader :: Shader shader => shader U V Frag 22 | shader 23 | = vertex (\ U{ matrix, pointSize } V{ pos } None -> main $ do 24 | gl_Position .= ext4 (ext3 ((matrix !* ext3 pos 1) ^. _xy) 0) 1 25 | gl_PointSize .= pointSize) 26 | 27 | >>> fragment (\ U{ colour } None Frag{ fragColour } -> main $ do 28 | p <- let' "p" (gl_PointCoord - v2 (pure 0.5)) 29 | iff (norm p `gt` 1) 30 | discard 31 | (do 32 | mag <- let' "mag" (norm p * 2) 33 | fragColour .= ext4 (colour ^. _xyz) (1 - mag ** 3 / 2))) 34 | 35 | 36 | data U v = U 37 | { matrix :: v (M33 (ClipUnits Float)) 38 | , pointSize :: v Float 39 | , colour :: v (Colour Float) 40 | } 41 | deriving (Generic) 42 | 43 | instance Vars U 44 | 45 | matrix_ :: Lens' (U v) (v (M33 (ClipUnits Float))) 46 | matrix_ = field @"matrix" 47 | 48 | pointSize_ :: Lens' (U v) (v Float) 49 | pointSize_ = field @"pointSize" 50 | 51 | colour_ :: Lens' (U v) (v (Colour Float)) 52 | colour_ = field @"colour" 53 | -------------------------------------------------------------------------------- /src/UI/Graph/Vertex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | module UI.Graph.Vertex 6 | ( V(..) 7 | ) where 8 | 9 | import Data.Functor.I 10 | import Foreign.Storable (Storable) 11 | import GHC.Generics (Generic) 12 | import GL.Shader.DSL 13 | 14 | newtype V v = V { pos :: v (V2 (ClipUnits Float)) } 15 | deriving (Generic) 16 | 17 | instance Vars V 18 | 19 | deriving via Fields V instance Storable (V I) 20 | -------------------------------------------------------------------------------- /src/UI/Label/Glyph.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | module UI.Label.Glyph 9 | ( shader 10 | , U(..) 11 | , matrix_ 12 | , ratio_ 13 | , fontScale_ 14 | , offset_ 15 | , V(..) 16 | , Frag(..) 17 | ) where 18 | 19 | import Control.Lens (Lens') 20 | import Data.Coerce 21 | import Data.Functor.I 22 | import Data.Generics.Product.Fields 23 | import Foreign.Storable (Storable) 24 | import GHC.Generics (Generic) 25 | import GL.Shader.DSL 26 | import Prelude hiding (break) 27 | 28 | shader :: Shader shader => shader U V Frag 29 | shader 30 | = vertex (\ U{ matrix, ratio, fontScale, offset } V{ pos } IF{ _coord2, colour } -> main $ do 31 | _coord2 .= pos^._zw ^* 0.5 32 | t <- var "t" (v2 0) 33 | r <- let' "r" (1/float ratio) 34 | switch gl_InstanceID 35 | [ (Just 0, do 36 | colour .= rgba 1 0 0 1 37 | t .= xy (-1/12.0) (-5/12.0) 38 | break) 39 | , (Just 1, do 40 | colour .= rgba 1 0 0 1 41 | t .= xy (1/12.0) (1/12.0) 42 | break) 43 | , (Just 2, do 44 | colour .= rgba 0 1 0 1 45 | t .= xy (3/12.0) (-1/12.0) 46 | break) 47 | , (Just 3, do 48 | colour .= rgba 0 1 0 1 49 | t .= xy (5/12.0) (5/12.0) 50 | break) 51 | , (Just 4, do 52 | colour .= rgba 0 0 1 1 53 | t .= xy (7/12.0) (-3/12.0) 54 | break) 55 | , (Just 5, do 56 | colour .= rgba 0 0 1 1 57 | t .= xy (9/12.0) (3/12.0) 58 | break) 59 | ] 60 | let t' p = get t ^. p * r 61 | m = matrix 62 | !*! m3 63 | 1 0 0 64 | 0 1 0 65 | (t' _x) (t' _y) 1 66 | !*! m3 67 | fontScale 0 0 68 | 0 fontScale 0 69 | 0 0 1 70 | !*! m3 71 | 1 0 0 72 | 0 1 0 73 | (float offset) 0 1 74 | gl_Position .= coerce (ext4 (m !* ext3 (pos^._xy) 1) 0^._xywz)) 75 | 76 | >>> fragment (\ _ IF{ _coord2, colour } Frag{ fragColour } -> main $ 77 | iff (_coord2^._x * _coord2^._x - _coord2^._y `gt` 0) 78 | discard 79 | (iff gl_FrontFacing 80 | -- Upper 4 bits: front faces 81 | -- Lower 4 bits: back faces 82 | (fragColour .= colour * 16 / 255) 83 | (fragColour .= colour / 255))) 84 | 85 | 86 | data U v = U 87 | { matrix :: v (M33 Float) 88 | , ratio :: v (I Int) 89 | , fontScale :: v Float 90 | , offset :: v Int 91 | } 92 | deriving (Generic) 93 | 94 | instance Vars U 95 | 96 | matrix_ :: Lens' (U v) (v (M33 Float)) 97 | matrix_ = field @"matrix" 98 | 99 | ratio_ :: Lens' (U v) (v (I Int)) 100 | ratio_ = field @"ratio" 101 | 102 | fontScale_ :: Lens' (U v) (v Float) 103 | fontScale_ = field @"fontScale" 104 | 105 | offset_ :: Lens' (U v) (v Int) 106 | offset_ = field @"offset" 107 | 108 | 109 | newtype V v = V { pos :: v (V4 Float) } 110 | deriving (Generic) 111 | 112 | instance Vars V 113 | 114 | deriving via Fields V instance Storable (V I) 115 | 116 | 117 | data IF v = IF 118 | { _coord2 :: v (V2 Float) 119 | , colour :: v (Colour Float) 120 | } 121 | deriving (Generic) 122 | 123 | instance Vars IF 124 | -------------------------------------------------------------------------------- /src/UI/Label/Text.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | module UI.Label.Text 9 | ( shader 10 | , U(..) 11 | , sampler_ 12 | , colour_ 13 | , V(..) 14 | , Frag(..) 15 | ) where 16 | 17 | import Control.Lens (Lens') 18 | import Data.Coerce 19 | import Data.Functor.I 20 | import Data.Generics.Product.Fields 21 | import Foreign.Storable (Storable) 22 | import GHC.Generics (Generic) 23 | import GL.Shader.DSL 24 | 25 | shader :: Shader shader => shader U V Frag 26 | shader 27 | = vertex (\ _ V{ pos } IF{ uv } -> main $ do 28 | uv .= (pos * xy 1 (-1)) * 0.5 + 0.5 29 | gl_Position .= coerce (ext4 (ext3 (pos * xy 1 (-1)) 0) 1)) 30 | 31 | >>> fragment (\ U{ sampler, colour } IF{ uv } Frag{ fragColour } -> main $ do 32 | -- Get samples for -2/3 and -1/3 33 | valueL <- let' "valueL" $ texture sampler (xy (uv^._x + dFdx (uv^._x)) (uv^._y))^._yz * 255 34 | lowerL <- let' "lowerL" $ mod' valueL 16 35 | upperL <- let' "upperL" $ (valueL - lowerL) / 16 36 | alphaL <- let' "alphaL" $ min' (abs (upperL - lowerL)) 2 37 | 38 | -- Get samples for 0, +1/3, and +2/3 39 | valueR <- let' "valueR" $ texture sampler uv ^. _xyz * 255 40 | lowerR <- let' "lowerR" $ mod' valueR 16 41 | upperR <- let' "upperR" $ (valueR - lowerR) / 16 42 | alphaR <- let' "alphaR" $ min' (abs (upperR - lowerR)) 2 43 | 44 | -- Average the energy over the pixels on either side 45 | rgba <- let' "rgba" $ xyzw 46 | ((alphaR ^. _x + alphaR ^. _y + alphaR ^. _z) / 6) 47 | ((alphaL ^. _y + alphaR ^. _x + alphaR ^. _y) / 6) 48 | ((alphaL ^. _x + alphaL ^. _y + alphaR ^. _x) / 6) 49 | 0 50 | 51 | iff (colour ^. _x `eq` 0) 52 | (fragColour .= 1 - rgba) 53 | (fragColour .= colour * rgba)) 54 | 55 | 56 | data U v = U 57 | { sampler :: v TextureUnit 58 | , colour :: v (Colour Float) 59 | } 60 | deriving (Generic) 61 | 62 | instance Vars U 63 | 64 | sampler_ :: Lens' (U v) (v TextureUnit) 65 | sampler_ = field @"sampler" 66 | 67 | colour_ :: Lens' (U v) (v (Colour Float)) 68 | colour_ = field @"colour" 69 | 70 | 71 | newtype V v = V { pos :: v (V2 Float) } 72 | deriving (Generic) 73 | 74 | instance Vars V 75 | 76 | deriving via Fields V instance Storable (V I) 77 | 78 | newtype IF v = IF { uv :: v (V2 Float) } 79 | deriving (Generic) 80 | 81 | instance Vars IF 82 | -------------------------------------------------------------------------------- /src/UI/Path.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | module UI.Path 5 | ( Component(..) 6 | , Path 7 | , pathTriangles 8 | ) where 9 | 10 | import Geometry.Triangle 11 | import Linear.V2 12 | 13 | data Component v n 14 | = M (v n) 15 | | L (v n) 16 | | Q (v n) (v n) 17 | deriving (Eq, Functor, Show) 18 | 19 | type Path v a = [Component v a] 20 | 21 | 22 | pathTriangles :: Num a => Path V2 a -> [(Triangle a, Kind)] 23 | pathTriangles = go False 0 0 where 24 | go notFirst first current = \case 25 | M v:rest -> go False v v rest 26 | L v:rest 27 | | notFirst -> (Triangle first current v, Solid) : go True first v rest 28 | | otherwise -> go True first v rest 29 | Q v1 v2:rest 30 | | notFirst -> (Triangle first current v2, Solid) : (Triangle current v1 v2, Curve) : go True first v2 rest 31 | | otherwise -> (Triangle current v1 v2, Curve) : go True first v2 rest 32 | [] -> [] 33 | -------------------------------------------------------------------------------- /src/UI/Window.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | module UI.Window 8 | ( Coords(..) 9 | , swap 10 | , poll 11 | , input 12 | , size 13 | , ratio 14 | , runSDL 15 | , runWindow 16 | , Window 17 | ) where 18 | 19 | import Control.Carrier.Lift 20 | import Control.Carrier.Reader 21 | import qualified Control.Concurrent.Lift as CC 22 | import qualified Control.Exception.Lift as E 23 | import Control.Lens ((^.)) 24 | import Control.Monad ((<=<)) 25 | import Control.Monad.IO.Class.Lift 26 | import Data.Fixed (div') 27 | import Data.Functor.I 28 | import Data.Functor.K 29 | import Data.Text (Text) 30 | import Foreign.Storable 31 | import GL.Type as GL 32 | import GL.Uniform 33 | import Graphics.GL.Core41 34 | import Linear.V2 as Linear 35 | import Linear.V4 as Linear 36 | import SDL 37 | import System.Random (Random) 38 | import Unit.Length 39 | 40 | -- FIXME: can we embed the ratio into this? maybe at the type level? 41 | newtype Coords a = Coords { getCoords :: a } 42 | deriving (Column, Conjugate, Enum, Epsilon, Eq, Foldable, Floating, Fractional, Functor, Integral, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 43 | deriving (Additive, Applicative, Metric, Monad) via I 44 | 45 | instance Unit Length Coords where 46 | suffix = K ('w':) 47 | 48 | 49 | swap :: (Has (Lift IO) sig m, Has (Reader Window) sig m) => m () 50 | swap = runLiftIO glFlush >> ask >>= runLiftIO . glSwapWindow 51 | 52 | poll :: Has (Lift IO) sig m => m (Maybe Event) 53 | poll = runLiftIO pollEvent 54 | 55 | input :: Has (Lift IO) sig m => (Event -> m ()) -> m () 56 | input h = go where 57 | go = poll >>= maybe (pure ()) (const go <=< h) 58 | 59 | size :: (Num a, Has (Lift IO) sig m, Has (Reader Window) sig m) => m (V2 (Coords a)) 60 | size = do 61 | size <- asks windowSize >>= runLiftIO . get 62 | pure (fromIntegral <$> size) 63 | 64 | ratio :: (Integral a, Has (Lift IO) sig m, Has (Reader Window) sig m) => m (I a) 65 | ratio = runLiftIO $ do 66 | window <- ask 67 | drawableSize <- glGetDrawableSize window 68 | windowSize <- get (windowSize window) 69 | pure $! (drawableSize^._y) `div'` (windowSize^._y) 70 | 71 | 72 | runSDL :: Has (Lift IO) sig m => m a -> m a 73 | runSDL = CC.runInBoundThread . E.bracket_ (runLiftIO initializeAll) (runLiftIO quit) 74 | 75 | runWindow :: Has (Lift IO) sig m => Text -> V2 (Coords Int) -> ReaderC Window m a -> m a 76 | runWindow name size = E.bracket 77 | (runLiftIO (createWindow name windowConfig)) 78 | (runLiftIO . destroyWindow) 79 | . flip runReader where 80 | windowConfig = defaultWindow 81 | { windowInitialSize = fromIntegral <$> size 82 | , windowResizable = True 83 | , windowPosition = Centered 84 | , windowGraphicsContext = OpenGLContext glConfig 85 | , windowHighDPI = True 86 | , windowMode = FullscreenDesktop 87 | , windowInputGrabbed = True 88 | } 89 | glConfig = defaultOpenGL 90 | { glProfile = Core Normal 4 1 91 | , glColorPrecision = V4 8 8 8 8 92 | } 93 | -------------------------------------------------------------------------------- /src/Unit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE MultiWayIf #-} 7 | {-# LANGUAGE QuantifiedConstraints #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# OPTIONS_GHC -Wno-redundant-constraints #-} 13 | module Unit 14 | ( -- * Units 15 | Unit(..) 16 | -- ** Conversion 17 | , convert 18 | , converting 19 | -- ** Comparison 20 | , (.==.) 21 | , compareU 22 | , (.<.) 23 | , (.>.) 24 | , (.<=.) 25 | , (.>=.) 26 | -- ** Formatting 27 | , formatWith 28 | , format 29 | , formatDec 30 | , formatExp 31 | , formatExpR 32 | , superscript 33 | ) where 34 | 35 | import Control.Lens.Iso 36 | import Data.Char 37 | import Data.Coerce 38 | import Data.Foldable (foldl') 39 | import Data.Functor.I 40 | import Data.Functor.Identity 41 | import Data.Functor.K 42 | import Data.Kind (Type) 43 | import Numeric 44 | 45 | -- * Units 46 | 47 | class ( Applicative u 48 | , forall a b . Coercible a b => Coercible (u a) (u b) 49 | , forall a . Eq a => Eq (u a) 50 | , forall a . Floating a => Floating (u a) 51 | , forall a . Fractional a => Fractional (u a) 52 | , forall a . Num a => Num (u a) 53 | , forall a . Ord a => Ord (u a) 54 | , forall a . Real a => Real (u a) 55 | ) 56 | => Unit (dim :: Type -> Type) u | u -> dim where 57 | prj :: u a -> a 58 | default prj :: Coercible (u a) a => u a -> a 59 | prj = coerce 60 | 61 | factor :: Floating a => K a (u a) 62 | factor = 1 63 | 64 | suffix :: K ShowS (u a) 65 | 66 | instance Unit I I where 67 | suffix = K (showChar '1') 68 | 69 | instance Unit Identity Identity where 70 | suffix = K (showChar '1') 71 | 72 | 73 | -- ** Conversion 74 | 75 | convert :: forall u u' d a . (Unit d u, Unit d u', Floating a) => u a -> u' a 76 | convert = pure . (/ getK (factor @_ @u')) . (* getK (factor @_ @u)) . prj 77 | 78 | converting :: forall u u' d a b . (Unit d u, Unit d u', Floating a, Floating b) => Iso (u a) (u b) (u' a) (u' b) 79 | converting = iso convert convert 80 | 81 | 82 | -- ** Comparison 83 | 84 | (.==.) :: forall u u' d a . (Unit d u, Unit d u', Eq a, Floating a) => u a -> u' a -> Bool 85 | a .==. b = prj a == prj (convert @u' @u b) 86 | 87 | infix 4 .==. 88 | 89 | compareU :: forall u u' d a . (Unit d u, Unit d u', Ord a, Floating a) => u a -> u' a -> Ordering 90 | compareU a b = prj a `compare` prj (convert @u' @u b) 91 | 92 | (.<.) :: (Unit d u, Unit d u', Ord a, Floating a) => u a -> u' a -> Bool 93 | a .<. b = a `compareU` b == LT 94 | 95 | infix 4 .<. 96 | 97 | (.>.) :: (Unit d u, Unit d u', Ord a, Floating a) => u a -> u' a -> Bool 98 | a .>. b = a `compareU` b == GT 99 | 100 | infix 4 .>. 101 | 102 | (.<=.) :: (Unit d u, Unit d u', Ord a, Floating a) => u a -> u' a -> Bool 103 | a .<=. b = a `compareU` b /= GT 104 | 105 | infix 4 .<=. 106 | 107 | (.>=.) :: (Unit d u, Unit d u', Ord a, Floating a) => u a -> u' a -> Bool 108 | a .>=. b = a `compareU` b /= LT 109 | 110 | infix 4 .>=. 111 | 112 | 113 | -- ** Formatting 114 | 115 | formatWith :: forall u d a . Unit d u => (Maybe Int -> u a -> ShowS) -> Maybe Int -> u a -> String 116 | formatWith with n u = with n u (showChar ' ' (getK (suffix `asTypeOf` (u <$ K ('x':))) "")) 117 | 118 | format :: forall u d a . (Unit d u, RealFloat (u a)) => Maybe Int -> u a -> String 119 | format = formatWith showGFloat 120 | 121 | formatDec :: forall u d a . (Unit d u, RealFloat (u a)) => Maybe Int -> u a -> String 122 | formatDec = formatWith showFFloat 123 | 124 | formatExp :: forall u d a . (Unit d u, RealFloat (u a)) => Maybe Int -> u a -> String 125 | formatExp = formatWith showEFloat 126 | 127 | formatExpR :: forall u d a . (Unit d u, RealFloat (u a)) => Maybe Int -> u a -> String 128 | formatExpR = formatWith (\ prec x -> if 129 | | isNaN x -> showString "NaN" 130 | | isInfinite x -> showString $ if x < 0 then "-Infinity" else "Infinity" 131 | | x < 0 || isNegativeZero x -> showChar '-' . go prec (floatToDigits 10 (-x)) 132 | | otherwise -> go prec (floatToDigits 10 x)) where 133 | go prec = \case 134 | ([0], _) -> showString "10⁰·0" 135 | (is, e) | let is' = maybe is (\ ds -> digits (round (mul (take (ds + 1) is)))) prec 136 | -> showString "10" . superscript (e - 1) . showChar '·' . showDigits (take 1 is') . showChar '.' . showDigits (drop 1 is') 137 | showDigits = foldl' (\ s -> fmap s . showChar . intToDigit) id 138 | mul = foldl' (\ s d -> s * 10 + fromIntegral d) (0 :: Double) 139 | 140 | digits :: Int -> [Int] 141 | digits = go id where 142 | go s n | n >= 10 = let (q, r) = n `quotRem` 10 in go ((r:) . s) q 143 | | otherwise = n:s [] 144 | 145 | superscript :: Int -> ShowS 146 | superscript i 147 | | signum i == -1 = ('⁻':) . go (abs i) 148 | | otherwise = go i where 149 | go = foldl' (\ s -> fmap s . (:) . (sup !!)) id . digits 150 | sup = "⁰¹²³⁴⁵⁶⁷⁸⁹" 151 | -------------------------------------------------------------------------------- /src/Unit/Angle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | module Unit.Angle 7 | ( Angle 8 | , Radians(..) 9 | , Degrees(..) 10 | , module Unit 11 | , module Unit.Algebra 12 | , module Unit.Multiple 13 | ) where 14 | 15 | import Data.Functor.I 16 | import Data.Functor.K 17 | import Foreign.Storable 18 | import GL.Type as GL 19 | import GL.Uniform 20 | import Linear.Conjugate 21 | import Linear.Epsilon 22 | import Linear.Metric 23 | import Linear.Vector 24 | import System.Random (Random) 25 | import Unit 26 | import Unit.Algebra 27 | import Unit.Multiple 28 | 29 | type Angle = I 30 | 31 | 32 | newtype Radians a = Radians { getRadians :: a } 33 | deriving (Column, Conjugate, Epsilon, Enum, Eq, Foldable, Floating, Fractional, Functor, Integral, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 34 | deriving (Additive, Applicative, Metric, Monad) via I 35 | 36 | instance Unit I Radians where 37 | suffix = K ("rad"++) 38 | 39 | 40 | newtype Degrees a = Degrees { getDegrees :: a } 41 | deriving (Column, Conjugate, Epsilon, Enum, Eq, Foldable, Floating, Fractional, Functor, Integral, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 42 | deriving (Additive, Applicative, Metric, Monad) via I 43 | 44 | instance Unit I Degrees where 45 | suffix = K ('°':) 46 | factor = K (pi/180) 47 | -------------------------------------------------------------------------------- /src/Unit/Count.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveTraversable #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | module Unit.Count 11 | ( Count(..) 12 | , module Unit 13 | , module Unit.Algebra 14 | , module Unit.Multiple 15 | ) where 16 | 17 | import Data.Functor.I 18 | import Data.Functor.K 19 | import Data.Proxy 20 | import Foreign.Storable 21 | import GHC.TypeLits 22 | import GL.Type as GL 23 | import GL.Uniform 24 | import Linear 25 | import System.Random (Random) 26 | import Unit 27 | import Unit.Algebra 28 | import Unit.Multiple 29 | 30 | newtype Count (sym :: Symbol) a = Count { getCount :: a } 31 | deriving (Column, Conjugate, Epsilon, Enum, Eq, Foldable, Floating, Fractional, Functor, Integral, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 32 | deriving (Additive, Applicative, Metric, Monad) via I 33 | 34 | instance Dimension (Count sym) 35 | instance KnownSymbol sym => Pow (Count sym) (Count sym) (Count sym) n (Count sym) 36 | 37 | instance KnownSymbol sym => Unit (Count sym) (Count sym) where 38 | suffix = K (symbolVal (Proxy @sym) ++) 39 | -------------------------------------------------------------------------------- /src/Unit/Density/Number/Areal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | module Unit.Density.Number.Areal 4 | ( Density 5 | , module Unit 6 | , module Unit.Algebra 7 | , module Unit.Multiple 8 | ) where 9 | 10 | import Unit 11 | import Unit.Algebra 12 | import Unit.Count 13 | import Unit.Length 14 | import Unit.Multiple 15 | 16 | type Density sym = Count sym :/: Metres :^: 2 17 | -------------------------------------------------------------------------------- /src/Unit/Force.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | module Unit.Force 4 | ( Force 5 | , Newtons 6 | , module Unit 7 | , module Unit.Algebra 8 | , module Unit.Multiple 9 | ) where 10 | 11 | import Unit 12 | import Unit.Algebra 13 | import Unit.Length 14 | import Unit.Mass 15 | import Unit.Multiple 16 | import Unit.Time 17 | 18 | type Force mass length time = mass :*: length :/: time :^: 2 19 | 20 | type Newtons = Force (Kilo Grams) Metres Seconds 21 | -------------------------------------------------------------------------------- /src/Unit/Length.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | module Unit.Length 10 | ( Length 11 | , Metres(..) 12 | , fromAUs 13 | , module Unit 14 | , module Unit.Algebra 15 | , module Unit.Multiple 16 | ) where 17 | 18 | import Data.Functor.I 19 | import Data.Functor.K 20 | import Foreign.Storable 21 | import GHC.TypeLits 22 | import GL.Type as GL 23 | import GL.Uniform 24 | import Linear.Conjugate 25 | import Linear.Epsilon 26 | import Linear.Metric 27 | import Linear.Vector 28 | import System.Random (Random) 29 | import Unit 30 | import Unit.Algebra 31 | import Unit.Multiple 32 | 33 | data Length a 34 | 35 | instance Dimension Length 36 | instance (Unit Length u, KnownNat n) => Pow Length (Length :^: n) u n (u :^: n) 37 | 38 | 39 | newtype Metres a = Metres { getMetres :: a } 40 | deriving (Column, Conjugate, Epsilon, Enum, Eq, Foldable, Floating, Fractional, Functor, Integral, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 41 | deriving (Additive, Applicative, Metric, Monad) via I 42 | 43 | instance Unit Length Metres where 44 | suffix = K ('m':) 45 | 46 | 47 | fromAUs :: Num a => a -> Metres a 48 | fromAUs a = Metres (149597870700 * a) 49 | -------------------------------------------------------------------------------- /src/Unit/Mass.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | module Unit.Mass 10 | ( Mass 11 | , Grams(..) 12 | , module Unit 13 | , module Unit.Algebra 14 | , module Unit.Multiple 15 | ) where 16 | 17 | import Data.Functor.I 18 | import Data.Functor.K 19 | import Foreign.Storable 20 | import GHC.TypeLits 21 | import GL.Type as GL 22 | import GL.Uniform 23 | import Linear.Conjugate 24 | import Linear.Epsilon 25 | import Linear.Metric 26 | import Linear.Vector 27 | import System.Random (Random) 28 | import Unit 29 | import Unit.Algebra 30 | import Unit.Multiple 31 | 32 | data Mass a 33 | 34 | instance Dimension Mass 35 | instance (Unit Mass u, KnownNat n) => Pow Mass (Mass :^: n) u n (u :^: n) 36 | 37 | 38 | newtype Grams a = Grams { getGrams :: a } 39 | deriving (Column, Conjugate, Epsilon, Enum, Eq, Foldable, Floating, Fractional, Functor, Integral, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 40 | deriving (Additive, Applicative, Metric, Monad) via I 41 | 42 | instance Unit Mass Grams where 43 | suffix = K ('g':) 44 | -------------------------------------------------------------------------------- /src/Unit/Multiple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveTraversable #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE NumericUnderscores #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | module Unit.Multiple 13 | ( -- * Prefixes 14 | Mult(..) 15 | -- ** Submultiples 16 | , Pico(..) 17 | , Nano(..) 18 | , Micro(..) 19 | , Milli(..) 20 | -- ** Multiples 21 | , Kilo(..) 22 | , Mega(..) 23 | , Giga(..) 24 | , Tera(..) 25 | ) where 26 | 27 | import Data.Functor.K 28 | import Data.Proxy 29 | import Foreign.Storable 30 | import GHC.TypeLits 31 | import GL.Type as GL 32 | import GL.Uniform 33 | import Linear.Conjugate 34 | import Linear.Epsilon 35 | import Linear.Metric 36 | import Linear.Vector 37 | import System.Random (Random) 38 | import Unit 39 | 40 | -- * Prefixes 41 | 42 | newtype Mult (n :: Nat) (d :: Nat) (s :: Symbol) u a = Mult { getMult :: u a } 43 | deriving (Additive, Applicative, Column, Conjugate, Epsilon, Eq, Foldable, Floating, Fractional, Functor, Metric, Monad, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 44 | 45 | instance (KnownNat n, KnownNat d, KnownSymbol s, Unit du u) => Unit du (Mult n d s u) where 46 | prj = prj . getMult 47 | 48 | factor = fromIntegral (natVal (Proxy @n)) / fromIntegral (natVal (Proxy @d)) 49 | 50 | suffix = K ((symbolVal (Proxy @s) ++) . getK (suffix @_ @u)) 51 | 52 | 53 | -- ** Submultiples 54 | 55 | newtype Pico u a = Pico { getPico :: u a } 56 | deriving (Additive, Applicative, Column, Conjugate, Epsilon, Eq, Foldable, Floating, Fractional, Functor, Metric, Monad, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 57 | deriving (Unit d) via Mult 1 1_000_000_000_000 "p" u 58 | 59 | newtype Nano u a = Nano { getNano :: u a } 60 | deriving (Additive, Applicative, Column, Conjugate, Epsilon, Eq, Foldable, Floating, Fractional, Functor, Metric, Monad, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 61 | deriving (Unit d) via Mult 1 1_000_000_000 "n" u 62 | 63 | newtype Micro u a = Micro { getMicro :: u a } 64 | deriving (Additive, Applicative, Column, Conjugate, Epsilon, Eq, Foldable, Floating, Fractional, Functor, Metric, Monad, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 65 | deriving (Unit d) via Mult 1 1_000_000 "μ" u 66 | 67 | newtype Milli u a = Milli { getMilli :: u a } 68 | deriving (Additive, Applicative, Column, Conjugate, Epsilon, Eq, Foldable, Floating, Fractional, Functor, Metric, Monad, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 69 | deriving (Unit d) via Mult 1 1_000 "m" u 70 | 71 | 72 | -- ** Multiples 73 | 74 | newtype Kilo u a = Kilo { getKilo :: u a } 75 | deriving (Additive, Applicative, Column, Conjugate, Epsilon, Eq, Foldable, Floating, Fractional, Functor, Metric, Monad, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 76 | deriving (Unit d) via Mult 1_000 1 "k" u 77 | 78 | newtype Mega u a = Mega { getMega :: u a } 79 | deriving (Additive, Applicative, Column, Conjugate, Epsilon, Eq, Foldable, Floating, Fractional, Functor, Metric, Monad, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 80 | deriving (Unit d) via Mult 1_000_000 1 "M" u 81 | 82 | newtype Giga u a = Giga { getGiga :: u a } 83 | deriving (Additive, Applicative, Column, Conjugate, Epsilon, Eq, Foldable, Floating, Fractional, Functor, Metric, Monad, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 84 | deriving (Unit d) via Mult 1_000_000_000 1 "G" u 85 | 86 | newtype Tera u a = Tera { getTera :: u a } 87 | deriving (Additive, Applicative, Column, Conjugate, Epsilon, Eq, Foldable, Floating, Fractional, Functor, Metric, Monad, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 88 | deriving (Unit d) via Mult 1_000_000_000_000 1 "T" u 89 | -------------------------------------------------------------------------------- /src/Unit/Power.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | module Unit.Power 10 | ( Power 11 | , Watts(..) 12 | , module Unit 13 | , module Unit.Algebra 14 | , module Unit.Multiple 15 | ) where 16 | 17 | import Data.Functor.I 18 | import Data.Functor.K 19 | import Foreign.Storable 20 | import GHC.TypeLits 21 | import GL.Type as GL 22 | import GL.Uniform 23 | import Linear.Conjugate 24 | import Linear.Epsilon 25 | import Linear.Metric 26 | import Linear.Vector 27 | import System.Random (Random) 28 | import Unit 29 | import Unit.Algebra 30 | import Unit.Multiple 31 | 32 | data Power a 33 | 34 | instance Dimension Power 35 | instance (Unit Power u, KnownNat n) => Pow Power (Power :^: n) u n (u :^: n) 36 | 37 | 38 | newtype Watts a = Watts { getWatts :: a } 39 | deriving (Column, Conjugate, Epsilon, Enum, Eq, Foldable, Floating, Fractional, Functor, Integral, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 40 | deriving (Additive, Applicative, Metric, Monad) via I 41 | 42 | instance Unit Power Watts where 43 | suffix = K ('W':) 44 | -------------------------------------------------------------------------------- /src/Unit/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveTraversable #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | module Unit.Time 11 | ( Time 12 | , Seconds(..) 13 | , Minutes(..) 14 | , Hours(..) 15 | , Days(..) 16 | , module Unit 17 | , module Unit.Algebra 18 | , module Unit.Multiple 19 | ) where 20 | 21 | import Data.Functor.I 22 | import Data.Functor.K 23 | import Foreign.Storable 24 | import GHC.TypeLits 25 | import GL.Type as GL 26 | import GL.Uniform 27 | import Linear.Conjugate 28 | import Linear.Epsilon 29 | import Linear.Metric 30 | import Linear.Vector 31 | import System.Random (Random) 32 | import Unit 33 | import Unit.Algebra 34 | import Unit.Multiple 35 | 36 | data Time a 37 | 38 | instance Dimension Time 39 | instance (Unit Time u, KnownNat n) => Pow Time (Time :^: n) u n (u :^: n) 40 | 41 | 42 | newtype Seconds a = Seconds { getSeconds :: a } 43 | deriving (Column, Conjugate, Epsilon, Enum, Eq, Foldable, Floating, Fractional, Functor, Integral, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 44 | deriving (Additive, Applicative, Metric, Monad) via I 45 | 46 | instance Unit Time Seconds where 47 | suffix = K ('s':) 48 | 49 | 50 | newtype Minutes a = Minutes { getMinutes :: a } 51 | deriving (Column, Conjugate, Epsilon, Enum, Eq, Foldable, Floating, Fractional, Functor, Integral, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 52 | deriving (Additive, Applicative, Metric, Monad) via I 53 | 54 | instance Unit Time Minutes where 55 | factor = K 60 56 | suffix = K ("min"++) 57 | 58 | 59 | newtype Hours a = Hours { getHours :: a } 60 | deriving (Column, Conjugate, Epsilon, Enum, Eq, Foldable, Floating, Fractional, Functor, Integral, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 61 | deriving (Additive, Applicative, Metric, Monad) via I 62 | 63 | instance Unit Time Hours where 64 | factor = K 3600 65 | suffix = K ("h"++) 66 | 67 | 68 | newtype Days a = Days { getDays :: a } 69 | deriving (Column, Conjugate, Epsilon, Enum, Eq, Foldable, Floating, Fractional, Functor, Integral, Num, Ord, Random, Real, RealFloat, RealFrac, Row, Show, Storable, Traversable, GL.Type, Uniform) 70 | deriving (Additive, Applicative, Metric, Monad) via I 71 | 72 | -- | Note that this does not take e.g. leap seconds into account. 73 | instance Unit Time Days where 74 | factor = K 86400 75 | suffix = K ("d"++) 76 | -------------------------------------------------------------------------------- /starlight.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | name: starlight 4 | version: 0.0.0.0 5 | -- synopsis: 6 | -- description: 7 | homepage: https://github.com/robrix/starlight#readme 8 | license: BSD-3-Clause 9 | license-file: LICENSE 10 | author: Rob Rix 11 | maintainer: rob.rix@me.com 12 | copyright: Rob Rix 13 | -- category: Web 14 | build-type: Simple 15 | extra-source-files: README.md 16 | 17 | data-files: 18 | data/data.db 19 | 20 | common common 21 | default-language: Haskell2010 22 | ghc-options: 23 | -Weverything 24 | -Wno-all-missed-specialisations 25 | -Wno-implicit-prelude 26 | -Wno-missed-specialisations 27 | -Wno-missing-import-lists 28 | -Wno-missing-local-signatures 29 | -Wno-monomorphism-restriction 30 | -Wno-name-shadowing 31 | -Wno-safe 32 | -Wno-unsafe 33 | if (impl(ghc >= 8.8)) 34 | ghc-options: -Wno-missing-deriving-strategies 35 | 36 | library 37 | import: common 38 | hs-source-dirs: src 39 | exposed-modules: 40 | Control.Carrier.Database.SQLite 41 | Control.Carrier.Error.IO 42 | Control.Carrier.Finally 43 | Control.Carrier.Reader.Relation 44 | Control.Carrier.State.IORef 45 | Control.Carrier.State.ST.Strict 46 | Control.Carrier.State.STM.TVar 47 | Control.Carrier.Thread.IO 48 | Control.Carrier.Trace.Lift 49 | Control.Concurrent.Lift 50 | Control.Effect.Database 51 | Control.Effect.Finally 52 | Control.Effect.Lens.Exts 53 | Control.Effect.Thread 54 | Control.Exception.Lift 55 | Control.Monad.IO.Class.Lift 56 | Data.Flag 57 | Data.Functor.C 58 | Data.Functor.I 59 | Data.Functor.Interval 60 | Data.Functor.K 61 | Foreign.C.String.Lift 62 | Foreign.Marshal.Alloc.Lift 63 | Foreign.Marshal.Array.Lift 64 | Foreign.Marshal.Utils.Lift 65 | Geometry.Circle 66 | Geometry.Transform 67 | Geometry.Triangle 68 | GL 69 | GL.Array 70 | GL.Buffer 71 | GL.Carrier.Bind 72 | GL.Carrier.Check.Identity 73 | GL.Carrier.Check.IO 74 | GL.Effect.Bind 75 | GL.Effect.Check 76 | GL.Enum 77 | GL.Error 78 | GL.Framebuffer 79 | GL.Object 80 | GL.Primitive 81 | GL.Program 82 | GL.Shader 83 | GL.Shader.DSL 84 | GL.Shader.Vars 85 | GL.Texture 86 | GL.TextureUnit 87 | GL.Type 88 | GL.Viewport 89 | GL.Uniform 90 | Linear.Exts 91 | Starlight.Actor 92 | Starlight.AI 93 | Starlight.Body 94 | Starlight.Character 95 | Starlight.CLI 96 | Starlight.Controls 97 | Starlight.Draw 98 | Starlight.Draw.Body 99 | Starlight.Draw.Radar 100 | Starlight.Draw.Ship 101 | Starlight.Draw.Starfield 102 | Starlight.Draw.Weapon.Laser 103 | Starlight.Faction 104 | Starlight.Game 105 | Starlight.Identifier 106 | Starlight.Integration 107 | Starlight.Input 108 | Starlight.Main 109 | Starlight.Physics 110 | Starlight.Radar 111 | Starlight.Ship 112 | Starlight.Sol 113 | Starlight.System 114 | Starlight.Time 115 | Starlight.UI 116 | Starlight.View 117 | Starlight.Weapon.Laser 118 | Stochastic.Distribution 119 | Stochastic.Histogram 120 | Stochastic.PDF 121 | Stochastic.Sample.Markov 122 | Stochastic.Sample.Metropolis 123 | Stochastic.Sample.Rejection 124 | Stochastic.Sample.Slice 125 | UI.Colour 126 | UI.Context 127 | UI.Drawable 128 | UI.Glyph 129 | UI.Graph 130 | UI.Graph.Lines 131 | UI.Graph.Points 132 | UI.Graph.Vertex 133 | UI.Label 134 | UI.Label.Glyph 135 | UI.Label.Text 136 | UI.Path 137 | UI.Typeface 138 | UI.Window 139 | Unit 140 | Unit.Algebra 141 | Unit.Angle 142 | Unit.Count 143 | Unit.Density.Number.Areal 144 | Unit.Force 145 | Unit.Length 146 | Unit.Mass 147 | Unit.Multiple 148 | Unit.Power 149 | Unit.Time 150 | other-modules: 151 | Paths_starlight 152 | autogen-modules: 153 | Paths_starlight 154 | build-depends: 155 | , adjunctions 156 | , base 157 | , containers 158 | , direct-sqlite ^>= 2.3 159 | , directory ^>= 1.3 160 | , filepath ^>= 1.4 161 | , fused-effects ^>= 1 162 | , fused-effects-lens ^>= 1.2 163 | , fused-effects-profile 164 | , fused-effects-random 165 | , generic-lens 166 | , gl 167 | , lens 168 | , linear 169 | , opentype 170 | , optparse-applicative 171 | , prettyprinter 172 | , prettyprinter-ansi-terminal 173 | , random 174 | , sdl2 ^>= 2.5 175 | , splitmix ^>= 0.0.5 176 | , stm ^>= 2.5 177 | , terminal-size 178 | , text 179 | , time ^>= 1.9 180 | , transformers ^>= 0.5 181 | , unordered-containers 182 | , vector ^>= 0.12 183 | 184 | executable starlight 185 | import: common 186 | hs-source-dirs: app 187 | main-is: Main.hs 188 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 189 | build-depends: 190 | , base 191 | , starlight 192 | 193 | source-repository head 194 | type: git 195 | location: https://github.com/robrix/starlight 196 | --------------------------------------------------------------------------------