├── .gitignore ├── Makefile ├── Readme.txt ├── format ├── lib ├── My │ ├── IO.hs │ └── Prelude.hs ├── Playtime.hs └── Playtime │ ├── ConcurrentState.hs │ ├── Debug.hs │ ├── EngineConfig.hs │ ├── EngineState.hs │ ├── Event.hs │ ├── GL.hs │ ├── GLFW.hs │ ├── Geometry.hs │ ├── LiveCode.hs │ ├── Midi.hs │ ├── Random.hs │ ├── SaveLoad.hs │ ├── Texture.hs │ ├── UI.hs │ ├── Util.hs │ └── Wiring.hs ├── live-coding-demo ├── LiveCodingDemo │ ├── Game.hs │ └── Main.hs ├── Main.hs └── assets │ ├── enemy_red.png │ ├── haskell_love_logo.png │ └── plane.png ├── package.yaml ├── platformer ├── Main.hs ├── Platformer │ ├── GameState.hs │ ├── Main.hs │ └── Visualize.hs └── assets │ ├── floor_plate.png │ └── main_character.png ├── shoot-em-up ├── Main.hs ├── ShootEmUp │ ├── GameState.hs │ ├── Main.hs │ └── Visualize.hs └── assets │ ├── bubble_pop.ogg │ ├── enemy_green.png │ ├── enemy_red.png │ ├── haskell_love_logo.png │ ├── plane.png │ └── venus_music.ogg ├── spaceminer ├── Main.hs ├── SpaceMiner │ ├── GameState.hs │ ├── Main.hs │ └── Visualize.hs └── assets │ ├── floor_plate.aseprite │ ├── floor_plate.png │ ├── inventory.aseprite │ ├── inventory.png │ ├── main_character.aseprite │ ├── main_character.png │ ├── red_resource.aseprite │ ├── red_resource.png │ ├── top_wall.aseprite │ ├── top_wall.png │ └── top_wall_locker.aseprite ├── stack.yaml ├── test └── Spec.hs └── todo.txt /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | stack.yaml.lock 4 | *.cabal 5 | savegame.json 6 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | live-coding-demo-run: 2 | stack build :live-coding-demo --file-watch --exec live-coding-demo 3 | live-coding-demo-watch: 4 | stack build :live-coding-demo --exec live-coding-demo 5 | live-coding-demo-compile: 6 | stack build :live-coding-demo --file-watch 7 | platformer-run: 8 | stack build :platformer --exec platformer 9 | platformer-watch: 10 | stack build :platformer --file-watch --exec platformer 11 | platformer-compile: 12 | stack build :platformer --file-watch 13 | shoot-em-up-run: 14 | stack build :shoot-em-up --exec shoot-em-up 15 | shoot-em-up-watch: 16 | stack build :shoot-em-up --file-watch --exec shoot-em-up 17 | shoot-em-up-compile: 18 | stack build :shoot-em-up --file-watch 19 | spaceminer-run: 20 | stack build :spaceminer --exec spaceminer 21 | spaceminer-watch: 22 | stack build :spaceminer --file-watch --exec spaceminer 23 | spaceminer-compile: 24 | stack build :spaceminer --file-watch 25 | watch: 26 | stack test --file-watch --no-run-tests 27 | watch-test: 28 | stack test --file-watch 29 | -------------------------------------------------------------------------------- /Readme.txt: -------------------------------------------------------------------------------- 1 | Note: there may be external dependencies you need to install in your OS, such as sdl, sdl2, sdl2_mixer 2 | 3 | This is an amateur project exploring how convenient game development in Haskell can be. 4 | 5 | A lot of the code is work in progress. 6 | 7 | Presented at Haskell.Love 2020 https://haskell.love/jan-christopher-vogt/ 8 | 9 | Demo game: https://www.youtube.com/watch?v=KndOBmmuDQg 10 | 11 | Started in June 2020 drawing inspiration from 12 | https://www.youtube.com/watch?v=1MNTerD8IuI - "Writing a game in Haskell" by Elise Huard 13 | 14 | Currently, this project is broken up into a shared engine named "Playtime" and 15 | several executable demos. 16 | 17 | Playtime takes care of interacting with openGL for rendering and GLFW-b for 18 | capturing user inputs. 19 | 20 | A game implementation has to provide a gameStep callback function, which knows 21 | how to advance the game state. Playtime will call this function each time user 22 | input events happen and once per frame. Playtime's EngineState keeps track of 23 | things like time, pressed keys and cursor position for you. 24 | 25 | A game implementation also has to provide a visualization callback function, 26 | which translates from the final game state at each frame to something, which 27 | Playtime knows how to pass to openGL. Playtime is called right before 28 | rendering a frame and right after calling the gameStep function on a 29 | RenderEvent 30 | 31 | Playtime has built in support for 32 | - Pre-loading textures from PNG files including alpha channel transparency 33 | 34 | Playtime provides a few helpers for 35 | - Geometry, in particular collision detection, see Geometry.hs 36 | - saving the game state to disk and loading it, see SaveLoad.hs 37 | - displaying custom debug information in the console while a game is running, see Debug.hs 38 | - dynamically recompiling a game's implementation and injecting it into the running game 39 | for easy experimentation with a fast feedback loop, see LiveCode.hs 40 | -------------------------------------------------------------------------------- /format: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -eu 4 | set -o pipefail 5 | 6 | ORMOLU=$(stack build --exec 'which ormolu') 7 | 8 | find . -type f -name "*.hs" ! -path '*/dist-newstyle/*' ! -path '*/.stack-work*/*' -print0 | \ 9 | xargs -0 -n 1 -P 8 "$ORMOLU" -o -XTypeApplications -o -XBangPatterns -o -XPatternSynonyms -m inplace 10 | -------------------------------------------------------------------------------- /lib/My/IO.hs: -------------------------------------------------------------------------------- 1 | module My.IO 2 | ( module Control.Concurrent, 3 | module Control.Concurrent.MVar, 4 | module Control.Exception, 5 | module Data.ByteString, 6 | module Data.Time.Clock.System, 7 | module System.IO, 8 | module System.FilePath.Posix, 9 | ) 10 | where 11 | 12 | import Control.Concurrent (ThreadId, forkFinally, forkIO, threadDelay) 13 | import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar, readMVar, swapMVar, tryReadMVar) 14 | import Control.Exception (SomeException, evaluate, finally, throwIO, try) 15 | import Data.ByteString (readFile, writeFile) 16 | import Data.Time.Clock.System (getSystemTime) 17 | import System.FilePath.Posix (()) 18 | import System.IO (FilePath, IO, putStr, putStrLn) 19 | -------------------------------------------------------------------------------- /lib/My/Prelude.hs: -------------------------------------------------------------------------------- 1 | module My.Prelude 2 | ( module Codec.Archive.Tar.Entry, 3 | module Control.Applicative, 4 | module Control.DeepSeq, 5 | module Control.Monad, 6 | module Control.Monad.Except, 7 | module Control.Monad.Extra, 8 | module Control.Monad.Loops, 9 | module Data.Bifunctor, 10 | module Data.Bool, 11 | module Data.Char, 12 | module Data.Data, 13 | module Data.Either, 14 | module Data.Eq, 15 | module Data.Fixed, 16 | module Data.Foldable, 17 | module Data.Function, 18 | module Data.Functor, 19 | module Data.Int, 20 | module Data.List, 21 | module Data.List.NonEmpty, 22 | module Data.Map, 23 | module Data.Maybe, 24 | module Data.Monoid, 25 | module Data.Ord, 26 | module Data.Semigroup, 27 | module Data.Sequence, 28 | module Data.Set, 29 | module Data.Text, 30 | module Data.Text.Encoding, 31 | module Data.Time.Clock.System, 32 | module Data.Traversable, 33 | module Data.Tuple, 34 | module Data.Tuple.Extra, 35 | module Foreign, 36 | module GHC.Enum, 37 | module GHC.Float, 38 | module GHC.Generics, 39 | module GHC.Integer, 40 | module GHC.Num, 41 | module GHC.Real, 42 | module GHC.Show, 43 | module Protolude, 44 | module My.Prelude, 45 | module Safe, 46 | module Safe.Foldable, 47 | module Universum, 48 | module System.Random, 49 | FilePath, 50 | ) 51 | where 52 | 53 | import Codec.Archive.Tar.Entry (getDirectoryContentsRecursive) -- is there a more appropriate recursive directory listing functon? 54 | import Control.Applicative ((<*>), (<|>), Alternative, Applicative, ZipList (ZipList, getZipList), pure) 55 | import Control.DeepSeq (NFData) 56 | import Control.Monad ((<=<), (=<<), (>>), (>>=), Monad, fail, filterM, foldM, forever, join, mfilter, return, unless, void, when) 57 | import Control.Monad.Except (ExceptT (ExceptT), runExceptT) 58 | -- UNSAFE, DO NOT IMPORT: foldl1, foldr1 59 | -- mod' is incorrect for large Doubles and always returns 0. 60 | 61 | import "monad-extras" Control.Monad.Extra (unfoldM_) 62 | import "extra" Control.Monad.Extra (ifM, unlessM, whenM, whileM) 63 | import Control.Monad.Loops (iterateM_) 64 | import Data.Bifunctor (Bifunctor, bimap, first, second) 65 | import Data.Bool ((&&), Bool (False, True), not, otherwise, (||)) 66 | import Data.Char (Char) 67 | import Data.Data (Data, toConstr) 68 | import Data.Either (Either (Left, Right), either, isLeft, isRight) 69 | import Data.Eq (Eq ((/=), (==))) 70 | import Data.Fixed (mod') 71 | import Data.Foldable (Foldable, all, any, elem, find, fold, foldl, foldlM, foldr, foldrM, forM_, for_, length, mapM_, null, sum, toList, traverse_) 72 | import Data.Function (($), (&), (.), flip, id) 73 | import Data.Functor (($>), (<$), (<$>), (<&>), Functor, fmap) 74 | import Data.Int (Int) 75 | import Data.List ((\\), concat, drop, dropWhile, filter, iterate, nub, repeat, replicate, reverse, sort, sortBy, sortOn, take, takeWhile, unzip) 76 | import qualified Data.List 77 | import qualified Data.List.NonEmpty 78 | import Data.List.NonEmpty (NonEmpty ((:|)), groupAllWith, groupBy, groupWith, head, last, unfoldr) 79 | import Data.Map (Map, keys, mapKeys) 80 | import qualified Data.Map 81 | import Data.Maybe (Maybe (Just, Nothing), catMaybes, fromMaybe, isJust, isNothing, maybe) 82 | import Data.Monoid ((<>), Any, Monoid, mempty) 83 | import Data.Ord (Ord ((<), (<=), (>), (>=)), max, min) 84 | import Data.Semigroup (Semigroup) 85 | import Data.Sequence (iterateN) 86 | import Data.Set (Set, difference, map, union) 87 | import qualified Data.Set 88 | import Data.Text (Text) 89 | import Data.Text.Encoding (decodeUtf8', encodeUtf8) 90 | import Data.Time.Clock.System (SystemTime) 91 | import Data.Traversable (for, forM, sequence, traverse) 92 | import Data.Tuple (fst, snd, swap, uncurry) 93 | import Data.Tuple.Extra (dupe) 94 | import Foreign (ForeignPtr) 95 | import GHC.Enum (Bounded, Enum, enumFrom, maxBound, minBound) 96 | import GHC.Float ((**), Double, Float, divideDouble) 97 | import GHC.Generics (Generic) 98 | import GHC.Integer (Integer) 99 | import GHC.Num ((*), (+), (-), Num, abs, fromInteger, subtract) 100 | import GHC.Real ((/), Fractional, Integral, fromIntegral) 101 | import GHC.Show (Show (show)) 102 | import Protolude ((<<$>>), (<<*>>)) 103 | import Safe (headMay, lastMay) 104 | import Safe.Foldable (foldl1Safe, foldr1Safe) 105 | import System.IO (FilePath) 106 | import System.Random (StdGen, mkStdGen, random, randomR) 107 | import Universum (foldl1, foldr1) 108 | 109 | mapDelete :: Ord k => k -> Map k a -> Map k a 110 | mapDelete = Data.Map.delete 111 | 112 | mapFromList :: Ord k => [(k, a)] -> Map k a 113 | mapFromList = Data.Map.fromList 114 | 115 | mapInsert :: Ord k => k -> a -> Map k a -> Map k a 116 | mapInsert = Data.Map.insert 117 | 118 | mapLookup :: Ord k => k -> Map k a -> Maybe a 119 | mapLookup = Data.Map.lookup 120 | 121 | mapNull :: Map k a -> Bool 122 | mapNull = Data.Map.null 123 | 124 | mapToList :: Map k a -> [(k, a)] 125 | mapToList = Data.Map.toList 126 | 127 | mapSingleton :: k -> a -> Map k a 128 | mapSingleton = Data.Map.singleton 129 | 130 | mapUnion :: Ord k => Map k a -> Map k a -> Map k a 131 | mapUnion = Data.Map.union 132 | 133 | setDelete :: Ord a => a -> Set a -> Set a 134 | setDelete = Data.Set.delete 135 | 136 | setFilter :: (a -> Bool) -> Set a -> Set a 137 | setFilter = Data.Set.filter 138 | 139 | setFromList :: Ord a => [a] -> Set a 140 | setFromList = Data.Set.fromList 141 | 142 | setInsert :: Ord a => a -> Set a -> Set a 143 | setInsert = Data.Set.insert 144 | 145 | setMember :: Ord a => a -> Set a -> Bool 146 | setMember = Data.Set.member 147 | 148 | setSingleton :: a -> Set a 149 | setSingleton = Data.Set.singleton 150 | 151 | nelTakeWhile :: (a -> Bool) -> NonEmpty a -> [a] 152 | nelTakeWhile = Data.List.NonEmpty.takeWhile 153 | 154 | listDelete :: Eq a => a -> [a] -> [a] 155 | listDelete = Data.List.delete 156 | 157 | listIsSuffixOf :: Eq a => [a] -> [a] -> Bool 158 | listIsSuffixOf = Data.List.isSuffixOf 159 | 160 | -- similar to both in lens 161 | both :: Data.Bifunctor.Bifunctor p => (a -> d) -> p a a -> p d d 162 | both f = bimap f f 163 | 164 | -- similar to (??) in lens 165 | (??) :: Functor f => f (a -> b) -> a -> f b 166 | (??) ff x = (\f -> f x) <$> ff 167 | 168 | -- named version of (??), name inspired by relude 169 | flap :: Functor f => f (a -> b) -> a -> f b 170 | flap = (??) 171 | -------------------------------------------------------------------------------- /lib/Playtime.hs: -------------------------------------------------------------------------------- 1 | module Playtime 2 | ( module Playtime, 3 | module Playtime.EngineConfig, 4 | module Playtime.EngineState, 5 | module Playtime.Event, 6 | module Playtime.Geometry, 7 | module Playtime.LiveCode, 8 | module Playtime.Random, 9 | module Playtime.SaveLoad, 10 | module Playtime.Texture, 11 | module Playtime.UI, 12 | module Playtime.Util, 13 | module Playtime.Wiring, 14 | -- GLFW re-exports 15 | Key (..), 16 | KeyState (..), 17 | MouseButton (..), 18 | MouseButtonState (..), 19 | ) 20 | where 21 | 22 | import qualified "GLFW-b" Graphics.UI.GLFW as GLFW 23 | import My.IO 24 | import My.Prelude 25 | import Playtime.ConcurrentState 26 | import Playtime.Debug 27 | import Playtime.EngineConfig 28 | import Playtime.EngineState 29 | import Playtime.Event 30 | import Playtime.GL 31 | import Playtime.GLFW 32 | import Playtime.Geometry 33 | import Playtime.LiveCode 34 | import Playtime.Random 35 | import Playtime.SaveLoad 36 | import Playtime.Texture 37 | import Playtime.UI 38 | import Playtime.Util 39 | import Playtime.Wiring 40 | 41 | -- README 42 | -- Acronyms to know: 43 | -- es = engine state 44 | -- gs = game state 45 | -- cs = concurrent state 46 | -- pos = Position 47 | -- dim = Dimension 48 | 49 | playtime :: Either LiveCodeState (MVar EngineConfig) -> IO () 50 | playtime lcsOrEcMVar = do 51 | let (lcsMay, ecMVar) = either (\lcs -> (Just lcs, lcsEngineConfig lcs)) (Nothing,) lcsOrEcMVar 52 | EngineConfig {ecScale, ecDim, ecCheckIfContinue} <- readMVar ecMVar 53 | -- initialization 54 | ies@EngineState {esWindowSize} <- makeInitialEngineState ecScale ecDim <$> getSystemTime 55 | cs@ConcurrentState {..} <- makeInitialConcurrentState ies 56 | 57 | void $ forkDebugTerminal cs ecMVar lcsMay 58 | 59 | -- open gl rendering loop 60 | withGLFW esWindowSize "Playtime" $ \window -> do 61 | setEventCallback window $ void . stepStates ecMVar window cs 62 | 63 | whileM $ trackTimeM csTimeRender $ do 64 | GLFW.pollEvents 65 | EngineConfig {ecVisualize} <- readMVar ecMVar 66 | es <- stepStates ecMVar window cs . RenderEvent =<< getSystemTime 67 | pure es 68 | >>= ecVisualize 69 | >>= trackTimeM csTimeGL . renderGL window ecDim 70 | ecCheckIfContinue es 71 | where 72 | stepStates :: MVar EngineConfig -> GLFW.Window -> ConcurrentState -> Event -> IO EngineState 73 | stepStates ecMVar window ConcurrentState {..} event = 74 | modifyMVar csEngineState $ \old_es -> 75 | trackTimeM csTimeStep $ do 76 | EngineConfig {ecStepGameState} <- readMVar ecMVar 77 | GLFW.makeContextCurrent $ Just window -- needed in order to load textures in event handler threads 78 | let new_es = stepEngineState old_es event 79 | ecStepGameState new_es event 80 | pure (new_es, new_es) 81 | -------------------------------------------------------------------------------- /lib/Playtime/ConcurrentState.hs: -------------------------------------------------------------------------------- 1 | module Playtime.ConcurrentState where 2 | 3 | import My.IO 4 | import My.Prelude 5 | import Playtime.EngineState 6 | 7 | data ConcurrentState = ConcurrentState 8 | { csEngineState :: MVar EngineState, 9 | csTimeStep :: MVar [(SystemTime, SystemTime)], 10 | csTimeGL :: MVar [(SystemTime, SystemTime)], 11 | csTimeRender :: MVar [(SystemTime, SystemTime)] 12 | } 13 | 14 | makeInitialConcurrentState :: EngineState -> IO ConcurrentState 15 | makeInitialConcurrentState es = do 16 | csEngineState <- newMVar es 17 | csTimeStep <- newMVar [] 18 | csTimeGL <- newMVar [] 19 | csTimeRender <- newMVar [] 20 | pure $ ConcurrentState {..} 21 | -------------------------------------------------------------------------------- /lib/Playtime/Debug.hs: -------------------------------------------------------------------------------- 1 | module Playtime.Debug where 2 | 3 | import Control.DeepSeq (rnf) 4 | import Data.Aeson 5 | import qualified Data.ByteString.Lazy as BSL 6 | import qualified Data.HashMap.Strict as HMS 7 | import Data.List (lines, zip) 8 | import qualified Data.Text as T 9 | import GHC.Float (int2Double) 10 | import GHC.Real (round) 11 | import My.IO 12 | import My.Prelude 13 | import Playtime.ConcurrentState 14 | import Playtime.EngineConfig 15 | import Playtime.EngineState 16 | import Playtime.LiveCode 17 | import Playtime.Util 18 | import System.Console.ANSI as ANSI 19 | import qualified System.Console.Terminal.Size as TerminalSize 20 | 21 | -- this modile is pretty messy. got to clean up some time. 22 | 23 | -- this relies on lazy evaluation to be correct and measures the time to force a 24 | trackTimeM :: NFData a => MVar [(SystemTime, SystemTime)] -> IO a -> IO a 25 | trackTimeM mvar action = do 26 | before <- getSystemTime 27 | res <- action 28 | pure $ rnf res 29 | after <- getSystemTime 30 | modifyMVar_ mvar $ pure . ((before, after) :) 31 | pure res 32 | 33 | trackTime :: NFData a => MVar [(SystemTime, SystemTime)] -> a -> IO () 34 | trackTime mvar = void . trackTimeM mvar . pure 35 | 36 | forkDebugTerminal :: ConcurrentState -> MVar EngineConfig -> Maybe LiveCodeState -> IO ThreadId 37 | forkDebugTerminal ConcurrentState {..} engineConfigMVar lcsMay = do 38 | -- FIXME: cursor stays hidden after termination 39 | forkIO $ do 40 | flip iterateM_ (0, 0, 0) $ \(oldAvgTimeStep, oldAvgRenderLoopTime, oldAvgTotalLoopTime) -> do 41 | engineState@EngineState {..} <- readMVar csEngineState 42 | timeStep <- modifyMVar csTimeStep $ \t -> pure ([], t) 43 | renderLoopTimes <- modifyMVar csTimeGL $ \t -> pure ([], t) 44 | totalLoopTimes <- modifyMVar csTimeRender $ \t -> pure ([], t) 45 | let _newAvgTimeStep = if not $ null timeStep then (/ 10) . int2Double . round @Double @Int $ 10 * 1 / (pico2second $ avg $ uncurry timeDiffPico <$> timeStep) else oldAvgTimeStep 46 | newAvgRenderLoopTime = if not $ null renderLoopTimes then (/ 10) . int2Double . round @Double @Int $ 10 * 1 / (pico2second $ avg $ uncurry timeDiffPico <$> renderLoopTimes) else oldAvgRenderLoopTime 47 | newAvgTotalLoopTime = if not $ null totalLoopTimes then (/ 10) . int2Double . round @Double @Int $ 10 * 1 / (pico2second $ avg $ uncurry timeDiffPico <$> totalLoopTimes) else oldAvgTotalLoopTime 48 | gameDebugInfo <- ecGameDebugInfo <$> readMVar engineConfigMVar 49 | gameInfo <- gameDebugInfo engineState 50 | clearFromCursorToScreenBeginning 51 | restoreCursor 52 | saveCursor 53 | (join . join -> ce) <- sequence $ tryReadMVar . lcsCompileError <$> lcsMay 54 | Just TerminalSize.Window {height, width} <- TerminalSize.size 55 | putStrLn $ T.unpack $ T.unlines $ take (height -2) $ join $ 56 | T.chunksOf width . T.stripEnd . T.pack 57 | <$> (maybe [] (\e -> lines $ setSGRCode [SetColor Foreground Vivid Red] <> e <> "\n" <> replicate width '-' <> setSGRCode [ANSI.Reset]) ce) 58 | <> ( take width 59 | <$> [ "fps: " <> show newAvgTotalLoopTime, 60 | --"1/renderLoopTime: " <> show newAvgRenderLoopTime, 61 | --"1/timeStep: " <> show newAvgTimeStep, 62 | replicate width '-', 63 | "esCursorPos: " <> show esCursorPos, 64 | "esKeysPressed: " <> show esKeysPressed, 65 | "esMousePressed: " <> show esMousePressed, 66 | --"esActions: " <> show esActions, 67 | "esTimePassed: " <> show esTimePassed, 68 | replicate width '-' 69 | ] 70 | <> gameInfo 71 | ) 72 | 73 | threadDelay $ 200 * 1000 -- FIXME: changing this to 100 * make process freeze on exit 74 | pure (oldAvgTimeStep, newAvgRenderLoopTime, newAvgTotalLoopTime) 75 | 76 | debugPrint :: ToJSON a => a -> [[Char]] 77 | debugPrint a = case toJSON a of 78 | Object hms -> fmap (\(k, v) -> T.unpack k <> ": " <> v) $ sortOn fst $ HMS.keys hms `zip` (enc <$> HMS.elems hms) 79 | other -> [enc other] 80 | where 81 | enc = take 200 . either show T.unpack . decodeUtf8' . BSL.toStrict . encode 82 | -------------------------------------------------------------------------------- /lib/Playtime/EngineConfig.hs: -------------------------------------------------------------------------------- 1 | module Playtime.EngineConfig where 2 | 3 | import My.IO 4 | import My.Prelude 5 | import Playtime.EngineState 6 | import Playtime.Event 7 | import Playtime.Geometry 8 | import Playtime.Texture 9 | 10 | data EngineConfig = EngineConfig 11 | { ecStepGameState :: EngineState -> Event -> IO (), 12 | ecVisualize :: EngineState -> IO [Sprite], 13 | ecDim :: Dim, 14 | ecScale :: Double, 15 | ecCheckIfContinue :: EngineState -> IO Bool, 16 | ecGameDebugInfo :: EngineState -> IO [[Char]] 17 | } 18 | -------------------------------------------------------------------------------- /lib/Playtime/EngineState.hs: -------------------------------------------------------------------------------- 1 | module Playtime.EngineState where 2 | 3 | import GHC.Float 4 | import My.Prelude 5 | import Playtime.Event 6 | import Playtime.Geometry 7 | import Playtime.Util 8 | 9 | data EngineState = EngineState 10 | { esCursorPos :: Pos, 11 | esFps :: Double, 12 | esDimensions :: Dim, 13 | esKeysPressed :: Set Key, 14 | esMousePressed :: Set MouseButton, 15 | esLastLoopTime :: SystemTime, 16 | esActions :: Set Action, 17 | esTimes :: [Integer], 18 | esTimePassed :: Double, 19 | esWindowSize :: Dim 20 | } 21 | deriving (Show, Generic, NFData) 22 | 23 | makeInitialEngineState :: Double -> Dim -> SystemTime -> EngineState 24 | makeInitialEngineState scale dim time = 25 | EngineState 26 | { esCursorPos = 0, 27 | esFps = 0, 28 | esKeysPressed = mempty, 29 | esMousePressed = mempty, 30 | esLastLoopTime = time, 31 | esDimensions = dim, 32 | esActions = mempty, 33 | esTimes = [], 34 | esTimePassed = 0, 35 | esWindowSize = dupe scale * dim 36 | } 37 | 38 | gameExitRequested :: EngineState -> Bool 39 | gameExitRequested es = Exit `elem` (esActions es) 40 | 41 | clearOneTimeEffects :: EngineState -> EngineState 42 | clearOneTimeEffects es = 43 | es 44 | { esActions = 45 | -- clear triggers for one time side effects 46 | esActions es `difference` (setFromList $ fmap OneTimeEffect $ catMaybes $ fmap oneTimeEffectMay $ toList $ esActions es) 47 | } 48 | 49 | stepEngineState :: EngineState -> Event -> EngineState 50 | stepEngineState (clearOneTimeEffects -> gs@EngineState {..}) = \case 51 | WindowSizeEvent width height -> gs {esWindowSize = (int2Double width, int2Double height)} 52 | CursorPosEvent pos -> 53 | gs 54 | { esCursorPos = 55 | -- this ratio calculation leads to proper relative scaling on window resize 56 | -- FIXME: we still get distortion if aspect ration of resized window is different 57 | -- we should be able to fix that by adding black borders as needed 58 | let scale = esDimensions / esWindowSize 59 | relPos = pos 60 | in scale * relPos 61 | } 62 | KeyEvent key KeyState'Pressed -> 63 | let pressed = setInsert key esKeysPressed 64 | matchingBindings = fromMaybe [] $ mapLookup key $ groupKeyBindings keyBindings 65 | actions = setFromList $ take 1 $ snd <$> filter (null . (`difference` pressed) . fst) matchingBindings 66 | in gs {esKeysPressed = pressed, esActions = esActions `union` actions} 67 | KeyEvent key KeyState'Released -> 68 | let pressed = setInsert key esKeysPressed 69 | matchingBindings = fromMaybe [] $ mapLookup key $ groupKeyBindings keyBindings 70 | actions = setFromList $ take 1 $ snd <$> filter (null . (`difference` pressed) . fst) matchingBindings 71 | in gs {esKeysPressed = setDelete key esKeysPressed, esActions = esActions `difference` actions} 72 | MouseEvent mb MouseButtonState'Pressed -> gs {esMousePressed = setInsert mb esMousePressed} 73 | MouseEvent mb MouseButtonState'Released -> gs {esMousePressed = setDelete mb esMousePressed} 74 | WindowCloseEvent -> gs {esActions = setFromList [Exit, OneTimeEffect Save] `union` esActions} 75 | RenderEvent time -> 76 | let picosecs = timeDiffPico esLastLoopTime time 77 | halfsec = 500 * 1000 * 1000 * 1000 78 | in gs 79 | { esLastLoopTime = time, 80 | esTimePassed = pico2Double picosecs, 81 | esTimes = if sum esTimes > halfsec then [] else picosecs : esTimes, 82 | esFps = if sum esTimes > halfsec then avg esTimes else esFps 83 | } 84 | _ -> gs 85 | -------------------------------------------------------------------------------- /lib/Playtime/Event.hs: -------------------------------------------------------------------------------- 1 | module Playtime.Event 2 | ( module Playtime.Event, 3 | Key (..), 4 | KeyState (..), 5 | MouseButton (..), 6 | MouseButtonState (..), 7 | ) 8 | where 9 | 10 | import "GLFW-b" Graphics.UI.GLFW (Key (..), KeyState (..), MouseButton (..), MouseButtonState (..)) 11 | import My.Prelude 12 | import Playtime.Geometry 13 | 14 | data Event 15 | = RenderEvent SystemTime 16 | | MouseEvent MouseButton MouseButtonState 17 | | KeyEvent Key KeyState 18 | | CursorPosEvent Pos 19 | | WindowSizeEvent Int Int 20 | | WindowCloseEvent 21 | deriving (Show) 22 | -------------------------------------------------------------------------------- /lib/Playtime/GL.hs: -------------------------------------------------------------------------------- 1 | module Playtime.GL where 2 | 3 | import Codec.Picture (DynamicImage (ImageRGBA8), Image (Image)) 4 | import Data.Vector.Storable (unsafeWith) 5 | import GHC.Err (error) 6 | import GHC.Float (double2Float, int2Double, int2Float) 7 | import Graphics.Rendering.OpenGL (($=)) 8 | import qualified Graphics.Rendering.OpenGL.GL as GL 9 | import qualified Graphics.Rendering.OpenGL.GLU.Errors as GLU 10 | import qualified "GLFW-b" Graphics.UI.GLFW as GLFW 11 | import My.IO 12 | import My.Prelude 13 | import Playtime.Geometry 14 | import Playtime.Texture 15 | 16 | renderGL :: GLFW.Window -> Dim -> [Sprite] -> IO () 17 | renderGL window (w, h) sprites = do 18 | GL.matrixMode $= GL.Projection 19 | GL.loadIdentity 20 | GL.ortho 0 w h 0 0 1 21 | GL.clear [GL.ColorBuffer, GL.DepthBuffer] 22 | 23 | GL.matrixMode $= GL.Modelview 0 24 | -- GL.lineSmooth $= GL.Disabled 25 | 26 | -- enable png alpha channel transparancy 27 | GL.blend $= GL.Enabled 28 | GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha) 29 | 30 | checkErrorsGLU "before" 31 | 32 | for_ (reverse sprites) $ \(Rectangle area tpe) -> case tpe of 33 | Right (fillType, (RGBA r g b a)) -> do 34 | GL.texture GL.Texture2D $= GL.Disabled 35 | GL.currentColor $= GL.Color4 (int2Float r / 255) (int2Float g / 255) (int2Float b / 255) (int2Float a / 255) 36 | mode <- case fillType of 37 | Solid -> pure GL.Quads 38 | Border l -> do 39 | GL.lineWidth $= l 40 | pure GL.Lines 41 | GL.renderPrimitive mode $ do 42 | let Corners c1 c2 c3 c4 = corners area 43 | forM_ [c1, c2, c2, c3, c3, c4, c4, c1] vertex 44 | Left (Texture _ glObject _) -> do 45 | -- if abs ((width dim / height dim) - (width dim' / height dim')) > 0.001 46 | -- then error $ show (dim, dim') 47 | -- else pure () 48 | GL.currentColor $= GL.Color4 @Float 255 255 255 1 49 | GL.texture GL.Texture2D $= GL.Enabled 50 | GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest) 51 | GL.textureBinding GL.Texture2D $= Just glObject 52 | GL.renderPrimitive GL.Quads $ do 53 | let Corners s1 s2 s3 s4 = cornerScales 54 | Corners c1 c2 c3 c4 = corners area 55 | forM_ [(s1, c1), (s2, c2), (s3, c3), (s4, c4)] $ \(s, c) -> do 56 | texCoord s 57 | vertex c 58 | 59 | checkErrorsGLU "after" 60 | GLFW.swapBuffers window 61 | where 62 | texCoord (sx, sy) = GL.texCoord $ GL.TexCoord2 (double2Float sx) (double2Float sy) -- remember 1 makes this match the size of the vertex/quad 63 | vertex (x, y) = GL.vertex $ GL.Vertex2 (double2Float x) (double2Float y) 64 | checkErrorsGLU csg = void $ error . ("GLU.errors " <>) . (csg <>) . (": " <>) . show <$> GL.get GLU.errors 65 | 66 | -- loadTextureId :: FilePath -> ExceptT [Char] IO Texture 67 | -- loadTextureId file = ExceptT (first ("loadTextureId: " <>) <$> readPng file) >>= loadTexture 68 | 69 | loadTexture :: DynamicImage -> ExceptT [Char] IO Texture 70 | loadTexture img = ExceptT $ case img of 71 | ImageRGBA8 img'@(Image width height dat) -> unsafeWith dat $ \ptr -> do 72 | let txSize = GL.TextureSize2D (fromIntegral width) (fromIntegral height) 73 | [texture] <- GL.genObjectNames 1 74 | GL.textureBinding GL.Texture2D $= Just texture 75 | GL.texImage2D GL.Texture2D GL.NoProxy 0 GL.RGBA8 txSize 0 $ GL.PixelData GL.RGBA GL.UnsignedByte ptr 76 | pure $ Right $ Texture (int2Double width, int2Double height) texture img' 77 | _ -> pure $ Left $ "loadTexture error: We currently only support png graphic files JuicyPixles reads as ImageRGBA8." 78 | -------------------------------------------------------------------------------- /lib/Playtime/GLFW.hs: -------------------------------------------------------------------------------- 1 | module Playtime.GLFW 2 | ( withGLFW, 3 | setEventCallback, 4 | ) 5 | where 6 | 7 | import GHC.Err (error) 8 | import GHC.Float (double2Int) 9 | import qualified "GLFW-b" Graphics.UI.GLFW as GLFW 10 | import My.IO 11 | import My.Prelude 12 | import Playtime.Event 13 | import Playtime.Geometry 14 | 15 | withGLFW :: Dim -> [Char] -> (GLFW.Window -> IO ()) -> IO () 16 | withGLFW (width, height) title glCode = do 17 | GLFW.setErrorCallback $ Just $ \e -> error . ("GLFW:" <>) . (show e <>) 18 | whenM GLFW.init $ flip finally GLFW.terminate $ do 19 | Just _mon <- GLFW.getPrimaryMonitor 20 | let fullscreen = Nothing -- Just mon 21 | GLFW.createWindow (double2Int width) (double2Int height) title fullscreen Nothing >>= \case 22 | Just window -> flip finally (GLFW.destroyWindow window) $ do 23 | GLFW.makeContextCurrent $ Just window 24 | -- setCursorInputMode win CursorInputMode'Hidden 25 | glCode window 26 | Nothing -> error "createWindow returned Nothing" 27 | 28 | setEventCallback :: GLFW.Window -> (Event -> IO ()) -> IO () 29 | setEventCallback window stepStates = do 30 | GLFW.setMouseButtonCallback window $ Just $ \_ button state _modifiers -> stepStates $ MouseEvent button state 31 | GLFW.setKeyCallback window $ Just $ \_ key _scancode keyState _modifiers -> stepStates $ KeyEvent key keyState 32 | GLFW.setWindowSizeCallback window $ Just $ \_ width height -> stepStates $ WindowSizeEvent width height 33 | GLFW.setCursorPosCallback window $ Just $ \_ x y -> stepStates $ CursorPosEvent (x, y) 34 | GLFW.setWindowCloseCallback window $ Just $ \_ -> stepStates $ WindowCloseEvent 35 | -------------------------------------------------------------------------------- /lib/Playtime/Geometry.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Playtime.Geometry where 4 | 5 | import Data.Aeson (FromJSON, ToJSON) 6 | import Data.List (zip) 7 | import GHC.Float 8 | import GHC.Num 9 | import GHC.Real 10 | import My.Prelude 11 | 12 | type Pos = (Double, Double) 13 | 14 | type Dim = (Double, Double) 15 | 16 | type Scale = (Double, Double) 17 | 18 | type Area = (Dim, Pos) 19 | 20 | instance (Num a, Num b) => Num (a, b) where 21 | (lx, ly) + (rx, ry) = (lx + rx, ly + ry) 22 | (lx, ly) - (rx, ry) = (lx - rx, ly - ry) 23 | (lx, ly) * (rx, ry) = (lx * rx, ly * ry) 24 | negate (x, y) = (- x, - y) 25 | abs (x, y) = (abs x, abs y) 26 | signum (x, y) = (signum x, signum y) 27 | fromInteger i = (fromInteger i, fromInteger i) 28 | 29 | instance (Fractional a, Fractional b) => Fractional (a, b) where 30 | (a, b) / (a', b') = (a / a', b / b') 31 | recip (a, b) = (recip a, recip b) 32 | fromRational r = (fromRational r, fromRational r) 33 | 34 | isWithin :: Pos -> Area -> Bool 35 | isWithin (cx, cy) ((width, height), (x, y)) = x <= cx && y <= cy && cx <= (x + width) && cy <= (y + height) 36 | 37 | collidesWith :: Area -> Area -> Bool 38 | collidesWith (da, a1) (db, b1) = 39 | let a2 = a1 + da; b2 = b1 + db 40 | in fst a1 < fst b2 && fst a2 > fst b1 && snd a1 < snd b2 && snd a2 > snd b1 41 | 42 | cornerScales :: Corners Scale 43 | cornerScales = Corners (0, 0) (0, 1) (1, 1) (1, 0) 44 | 45 | data Corners a = Corners {nw :: a, sw :: a, se :: a, ne :: a} deriving (Eq, Ord, Show, Generic, NFData, FromJSON, ToJSON, Functor) -- ne aka north east = upper left corner, etc 46 | 47 | instance Foldable Corners where foldr f b (Corners ne se sw nw) = foldr f b [ne, se, sw, nw] 48 | 49 | corners :: Area -> Corners Pos 50 | corners (dim, pos) = cornerScales <&> \scale -> pos + scale * dim 51 | 52 | move :: Double -> Area -> Pos -> Double -> Double -> [Area] -> Pos 53 | move timePassed (objectDim, objectPos) previousPos velocityX velocityY obstacles = 54 | case lastMay unobstructed of 55 | Nothing -> objectPos 56 | Just pos -> 57 | let step (cx'', cy'') (cx', cy') = 58 | let goY = mfilter nonColliding $ Just $ (cx'', cy') 59 | goX = mfilter nonColliding $ Just $ (cx', cy'') 60 | xOverY = fst objectPos == fst previousPos 61 | in if xOverY then goX <|> goY else goY <|> goX 62 | in case foldM step pos $ drop (length unobstructed) candidates of 63 | Nothing -> pos 64 | Just pos' -> pos' 65 | where 66 | nonColliding p = not $ any ((objectDim, p) `collidesWith`) obstacles 67 | candidates = trajectoryPixels objectPos timePassed (velocityX, velocityY) 68 | unobstructed = takeWhile nonColliding candidates 69 | 70 | -- given a position, a timedifference and x,y velocities - calculate relevant pixels along the trajector for checking collisions 71 | trajectoryPixels :: Pos -> Double -> Dim -> [Pos] 72 | trajectoryPixels objectPos timePassed ((dupe timePassed *) -> (velocityX, velocityY)) = 73 | -- FIXME: We should return a list of all the intersection points with pixel borders along the trajectory. 74 | -- What we currently do instead is wrong, but close enough for the moment. 75 | nub $ candidatesXY mx velocityX stepX `zip` candidatesXY my velocityY stepY 76 | where 77 | (mx, my) = objectPos 78 | steps :: Int 79 | steps = ceiling $ max (abs velocityX) (abs velocityY) 80 | stepX = velocityX / int2Double steps 81 | stepY = velocityY / int2Double steps 82 | candidatesXY :: Double -> Double -> Double -> [Double] 83 | candidatesXY base velocity step = 84 | (<> [base + velocity]) . toList $ 85 | int2Double 86 | . (if step < 0 then floor else ceiling) 87 | <$> iterateN steps (+ step) base 88 | -------------------------------------------------------------------------------- /lib/Playtime/LiveCode.hs: -------------------------------------------------------------------------------- 1 | module Playtime.LiveCode where 2 | 3 | -- This module provides helpers to dynamically compile and load 4 | -- code such as modified game code at runtime. 5 | -- This allows for more interactivity and a quicker feedback loop 6 | -- than restarting the application entirely 7 | -- 8 | -- Partially inspired by Bret Victor's talk "Inventing on Principle" https://vimeo.com/36579366 9 | -- 10 | -- Based on code from these blog posts 11 | -- https://codeutopia.net/blog/2011/08/20/adventures-in-haskell-dynamic-loading-and-compiling-of-modules/ 12 | -- https://gist.github.com/jhartikainen/1158986 13 | -- https://bluishcoder.co.nz/2008/11/25/dynamic-compilation-and-loading-of.html 14 | -- 15 | -- Related work discovered later: 16 | -- - https://github.com/lukexi/halive 17 | -- - https://hackage.haskell.org/package/rapid 18 | 19 | import Bag (bagToList) 20 | import Control.Concurrent.MVar (newEmptyMVar, putMVar) 21 | import Data.Aeson (FromJSON, Result (..), ToJSON, Value (Null), fromJSON, toJSON) 22 | import Data.Dynamic 23 | import Data.Typeable 24 | import DynFlags 25 | import qualified EnumSet 26 | import GHC hiding (loadModule) 27 | import GHC.LanguageExtensions.Type 28 | import GHC.Paths (libdir) 29 | import HscTypes (SourceError, srcErrorMessages) 30 | import My.IO 31 | import My.Prelude 32 | import Playtime.EngineConfig 33 | import System.Console.ANSI as ANSI 34 | import System.FSNotify hiding (Event) 35 | import System.IO (stderr, stdout) 36 | import System.IO.Silently (hCapture) 37 | 38 | type String = [Char] 39 | 40 | startLiveCode :: FromJSON a => LiveCodeState -> IO (Maybe a) 41 | startLiveCode lcs = do 42 | watch lcs 43 | recoverLiveCodeGameState lcs 44 | 45 | liveCodeSwitch :: ToJSON gameState => LiveCodeState -> gameState -> IO () 46 | liveCodeSwitch lcs@LiveCodeState {..} gameState = do 47 | readMVar lcsChangeDetected >>= \case 48 | False -> pure () 49 | True -> do 50 | srcFiles <- fmap (lcsWatchDir ) <$> filter (listIsSuffixOf ".hs") <$> getDirectoryContentsRecursive lcsWatchDir 51 | void $ 52 | swapMVar lcsCompileError =<< do 53 | void $ swapMVar lcsChangeDetected False 54 | void $ swapMVar lcsCompiling True 55 | Playtime.LiveCode.compileAndEval srcFiles lcsModule lcsExpression >>= \case 56 | Left compileErrors -> pure $ Just compileErrors 57 | Right wireEngineConfig -> do 58 | void $ swapMVar lcsGameState $ toJSON gameState 59 | void $ swapMVar lcsEngineConfig =<< wireEngineConfig (Just lcs) 60 | pure Nothing -- doesn't clear compile errors because EngineConfig has already been replaced 61 | void $ swapMVar lcsCompiling False 62 | 63 | makeLiveCodeState :: (Maybe LiveCodeState -> IO EngineConfig) -> [Char] -> [Char] -> FilePath -> IO LiveCodeState 64 | makeLiveCodeState wireEngineConfig lcsModule lcsExpression lcsWatchDir = do 65 | lcsChangeDetected <- newMVar False 66 | lcsCompiling <- newMVar False 67 | lcsCompileError <- newMVar Nothing 68 | lcsGameState <- newMVar Null 69 | lcsEngineConfig <- newEmptyMVar 70 | let lcs = LiveCodeState {..} 71 | putMVar lcsEngineConfig =<< wireEngineConfig (Just lcs) 72 | pure lcs 73 | 74 | data LiveCodeState = LiveCodeState 75 | { lcsWatchDir :: FilePath, 76 | lcsModule :: [Char], 77 | lcsExpression :: [Char], 78 | lcsChangeDetected :: MVar Bool, 79 | lcsCompiling :: MVar Bool, 80 | lcsCompileError :: MVar (Maybe [Char]), 81 | lcsEngineConfig :: MVar EngineConfig, 82 | lcsGameState :: MVar Value 83 | } 84 | 85 | recoverLiveCodeGameState :: FromJSON a => LiveCodeState -> IO (Maybe a) 86 | recoverLiveCodeGameState LiveCodeState {lcsGameState} = 87 | (fromJSON <$> readMVar lcsGameState) <&> \case 88 | Error _ -> Nothing 89 | Success gs -> Just gs 90 | 91 | watch :: LiveCodeState -> IO () 92 | watch LiveCodeState {..} = do 93 | void $ forkIO $ do 94 | mgr <- startManagerConf $ WatchConfig DebounceDefault (100 * 1000) True 95 | -- start a watching job (in the background) 96 | void $ watchTree mgr lcsWatchDir (\_ -> True) $ 97 | \_ -> void $ swapMVar lcsChangeDetected True 98 | forever $ threadDelay $ 1000 * 1000 99 | 100 | compileAndEval :: Typeable a => [FilePath] -> String -> String -> IO (Either String a) 101 | compileAndEval srcFiles modname expr = do 102 | clearFromCursorToScreenBeginning 103 | restoreCursor 104 | saveCursor 105 | setSGR [SetColor Foreground Vivid Blue] 106 | putStrLn $ "EVALING " <> modname <> "." <> expr <> " in:" 107 | putStrLn "" 108 | for_ srcFiles putStrLn 109 | setSGR [ANSI.Reset] 110 | (compileErrors, res) <- hCapture [stdout, stderr] $ runGhc (Just libdir) $ runExceptT $ do 111 | loadSourceGhc srcFiles 112 | evalExpression modname expr 113 | pure $ first (<> compileErrors) res 114 | 115 | evalExpression :: forall a. Typeable a => String -> String -> ExceptT String Ghc a 116 | evalExpression modname expr = ExceptT $ do 117 | mod <- findModule (mkModuleName modname) Nothing 118 | setContext [IIModule $ moduleName mod] 119 | maybe (Left $ "could coerce return value of dynamically loaded code to expected type: " <> show (typeOf $ Proxy @a)) Right 120 | . fromDynamic 121 | <$> dynCompileExpr (modname <> "." <> expr) 122 | 123 | loadSourceGhc :: [FilePath] -> ExceptT String Ghc () 124 | loadSourceGhc paths = ExceptT $ 125 | do 126 | dflags <- getSessionDynFlags 127 | void $ setSessionDynFlags $ 128 | dflags 129 | { ghcLink = LinkInMemory, 130 | hscTarget = HscInterpreted, 131 | -- attempts to improve performance, untested 132 | optLevel = 0, 133 | simplPhases = 0, 134 | debugLevel = 0, 135 | parMakeCount = Nothing, 136 | --log_action :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO (), 137 | --log_action = \_ _ _ _ _ _ -> putStrLn "ERROR", 138 | -- we can't see the package.yaml, so we need to specify used extensions here 139 | extensionFlags = 140 | foldl 141 | (flip EnumSet.insert) 142 | EnumSet.empty 143 | [ TraditionalRecordSyntax, -- FIXME: probably need to make extensions configurable at some point 144 | DeriveAnyClass, 145 | DeriveDataTypeable, 146 | DeriveFunctor, 147 | DeriveGeneric, 148 | DerivingStrategies, 149 | FlexibleContexts, 150 | FlexibleInstances, 151 | GeneralizedNewtypeDeriving, 152 | LambdaCase, 153 | MultiParamTypeClasses, 154 | MultiWayIf, 155 | RecordPuns, -- this is NamedFieldPuns 156 | -- ImplicitPrelude, 157 | OverloadedStrings, 158 | PackageImports, 159 | RecordWildCards, 160 | ScopedTypeVariables, 161 | StandaloneDeriving, 162 | TupleSections, 163 | TypeApplications, 164 | TypeOperators, 165 | ViewPatterns 166 | ], 167 | packageFlags = [ExposePackage "ghc" (PackageArg "ghc") $ ModRenaming True []] 168 | } 169 | for_ paths $ \path -> addTarget =<< guessTarget path Nothing 170 | load LoadAllTargets >>= \case 171 | Failed -> pure $ Left $ "COMPILE ERROR:\n" 172 | Succeeded -> pure $ Right () 173 | `gcatch` \(e :: SourceError) -> pure $ Left $ concat $ fmap show $ bagToList $ srcErrorMessages e 174 | -------------------------------------------------------------------------------- /lib/Playtime/Midi.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Playtime.Midi where 4 | 5 | import Data.FileEmbed (makeRelativeToProject, strToExp) 6 | import Euterpea hiding (Text, forever) 7 | import My.IO 8 | import My.Prelude 9 | import System.Posix.Process (executeFile) 10 | 11 | spawnSynth :: IO () 12 | spawnSynth = 13 | executeFile "/usr/local/bin/fluidsynth" False [$(makeRelativeToProject "Steinway+Grand+Piano+ER3A.sf2" >>= strToExp)] Nothing 14 | 15 | playMusic :: IO () 16 | playMusic = do 17 | let p = Euterpea.play . Euterpea.line 18 | -- let p1 = [c 5 qn, e 5 qn, d 5 en, c 5 en, e 5 qn, c 5 qn, b 4 en, e 5 en, a 4 hn] 19 | -- let p2 = [e 5 qn, e 5 qn, g 5 qn, g 5 en, a 5 en, f 5 qn, a 5 qn, e 5 hn] 20 | -- let p3 = [c 6 qn, b 5 en, a 5 en, b 5 qn, e 5 qn, a 5 qn, e 5 en, d 5 en, e 5 qn, b 4 qn] 21 | -- p $ p1 <> p2 <> p3 22 | -- p $ [chord [c 4 en, e 4 en, g 4 en], chord [c 4 en, e 4 en, g 4 en], chord [c 4 en, e 4 en, g 4 en], chord [a 3 hn, c 4 hn, e 4 hn]] -- p1 <> p2 <> p3 23 | let loykrathong = 24 | [c 3 en, c 3 en, a 2 en, c 3 en, d 3 en, f 3 qn] <> [g 3 en, f 3 en, d 3 qn, c 3 en, d 3 en, c 3 en, a 2 qn] 25 | <> [c 3 en, d 3 en, f 3 en, d 3 en, f 3 qn] 26 | <> [c 3 en, d 3 en, f 3 en, g 3 qn, f 3 en, d 3 en, c 3 en, c 3 qn] 27 | <> [f 3 en, f 3 en, f 3 en, f 3 en, f 3 en, f 3 qn] 28 | <> [c 3 en, c 3 en, c 3 en, c 3 en, c 3 en, c 3 qn] 29 | <> [f 3 en, f 3 en, f 3 en, g 3 en, a 3 qn] 30 | <> [g 3 en, f 3 en, d 3 en, c 3 en, d 3 en, f 3 en, g 3 en, a 3 qn] 31 | <> [a 3 en, a 3 en, a 3 en, a 3 en, a 3 en, a 3 qn] 32 | <> [f 3 en, f 3 en, f 3 en, f 3 en, f 3 en, f 3 qn] 33 | <> [f 3 en, d 3 en, c 3 en, d 3 en, f 3 en, d 3 en, f 3 qn] 34 | <> [f 3 en, d 3 en, c 3 en, d 3 en, f 3 en, d 3 en, f 3 qn] 35 | p $ tempo 0.75 <$> loykrathong 36 | 37 | -- https://github.com/igorski/VSTSID 38 | -- http://hackage.haskell.org/package/csound-expression-typed-0.2.2.0/docs/src/Csound.Typed.Plugins.Diode.html 39 | -- https://sites.google.com/site/fluidvolt/ 40 | -- https://musical-artifacts.com/artifacts/185 41 | -- https://trisamples.com/free-soundfonts/ 42 | -- http://drunk3nj3sus.blogspot.com/2015/04/c64-waveform-soundfonts.html 43 | -------------------------------------------------------------------------------- /lib/Playtime/Random.hs: -------------------------------------------------------------------------------- 1 | module Playtime.Random where 2 | 3 | import Data.List (zip) 4 | import GHC.Float (double2Int, int2Double) 5 | import My.Prelude 6 | import Playtime.Geometry 7 | import System.Random 8 | 9 | randomsR :: (Random a) => StdGen -> Int -> (a, a) -> ([a], StdGen) 10 | randomsR = randomsR' . ([],) 11 | where 12 | randomsR' :: (Random a) => ([a], StdGen) -> Int -> (a, a) -> ([a], StdGen) 13 | randomsR' res n _ | n <= 0 = res 14 | randomsR' (acc, g') n r = randomsR' (first (: acc) $ randomR r g') (n -1) r 15 | 16 | randomPoss :: StdGen -> Int -> Dim -> ([Pos], StdGen) 17 | randomPoss g n (maxX, maxY) = 18 | let (xs, g') = randomsNatDouble g n maxX 19 | (ys, g'') = randomsNatDouble g' n maxY 20 | in (xs `zip` ys, g'') 21 | 22 | randomsNatDouble :: StdGen -> Int -> Double -> ([Double], StdGen) 23 | randomsNatDouble g num maxV = first (fmap int2Double) $ randomsR g num (0, double2Int maxV) 24 | -------------------------------------------------------------------------------- /lib/Playtime/SaveLoad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Playtime.SaveLoad where 4 | 5 | import Data.Aeson 6 | import qualified Data.ByteString.Lazy as BSL 7 | import Data.FileEmbed (makeRelativeToProject, strToExp) 8 | import My.IO 9 | import My.Prelude 10 | import Playtime.EngineState 11 | import Playtime.Util 12 | 13 | saveLocation :: FilePath 14 | saveLocation = $(makeRelativeToProject "savegame.json" >>= strToExp) 15 | 16 | -- FIXME: this hard codes against OneTimeEffects in EngineState. We probably don't want to hard code loading and saving 17 | saveMay :: ToJSON gs => EngineState -> gs -> IO () 18 | saveMay es gs = do 19 | let EngineState {esActions} = es 20 | when (OneTimeEffect Save `setMember` esActions) $ writeFile saveLocation $ BSL.toStrict $ encode gs 21 | 22 | loadMay :: FromJSON gs => EngineState -> IO (Maybe gs) 23 | loadMay es = do 24 | let EngineState {esActions} = es 25 | if OneTimeEffect Load `setMember` esActions 26 | then do 27 | either fail pure . eitherDecode . BSL.fromStrict =<< readFile saveLocation 28 | else pure Nothing 29 | -------------------------------------------------------------------------------- /lib/Playtime/Texture.hs: -------------------------------------------------------------------------------- 1 | module Playtime.Texture where 2 | 3 | import Codec.Picture.Types (Image, PixelRGBA8) 4 | import Data.Aeson (FromJSON, ToJSON) 5 | import GHC.Float 6 | import GHC.Num 7 | import qualified Graphics.Rendering.OpenGL.GL as GL (TextureObject) 8 | import My.Prelude 9 | import Playtime.Geometry 10 | 11 | -- Textures Types 12 | data Texture = Texture 13 | { tDimensions :: Dim, 14 | tGLObject :: GL.TextureObject, 15 | tImage :: Image PixelRGBA8 16 | } 17 | 18 | data FillType = Solid | Border Float 19 | 20 | data Sprite = Rectangle Area (Either Texture (FillType, Color)) 21 | 22 | data Color = RGBA Int Int Int Int deriving (Eq, Ord, Show, Generic, ToJSON, FromJSON, NFData) 23 | 24 | spriteArea :: Sprite -> Area 25 | spriteArea (Rectangle area _) = area 26 | 27 | rectangle :: FillType -> Color -> Dim -> Pos -> Sprite 28 | rectangle ft c d p = Rectangle (d, p) $ Right (ft, c) 29 | 30 | rectangle' :: FillType -> Color -> Area -> Sprite 31 | rectangle' ft c a = Rectangle a $ Right (ft, c) 32 | 33 | textureSprites :: (a -> (Scale, b)) -> (b -> Texture) -> a -> Pos -> Sprite 34 | textureSprites textures f (second f . textures -> (scale, tx@(Texture dim _ _))) pos = Rectangle (scale * dim, pos) (Left tx) 35 | 36 | textureDim :: (a -> (Scale, b)) -> (b -> Texture) -> a -> Dim 37 | textureDim textureScale textures i = 38 | let (scale, b) = textureScale i 39 | Texture dim _ _ = textures b 40 | in scale * dim 41 | 42 | translate :: Dim -> Sprite -> Sprite 43 | translate offset (Rectangle (dim, pos) v) = Rectangle (dim, pos + offset) v 44 | -------------------------------------------------------------------------------- /lib/Playtime/UI.hs: -------------------------------------------------------------------------------- 1 | module Playtime.UI where 2 | 3 | import Data.Aeson (FromJSON, ToJSON) 4 | import "GLFW-b" Graphics.UI.GLFW 5 | import My.Prelude 6 | import Playtime.EngineState 7 | import Playtime.Event 8 | import Playtime.Geometry 9 | 10 | data DragAndDrop = DragAndDrop Pos Dim deriving (Show, Generic, NFData, ToJSON, FromJSON) 11 | 12 | dragAndDrop :: 13 | EngineState -> 14 | gs -> 15 | MouseButton -> 16 | [Area] -> 17 | ([Pos] -> gs -> gs) -> 18 | Maybe DragAndDrop -> 19 | (Maybe DragAndDrop -> gs -> gs) -> 20 | Event -> 21 | gs 22 | dragAndDrop EngineState {..} gs mb areas setPoss dragAndDrop' setDragAndDrop = 23 | let poss = snd <$> areas 24 | in \case 25 | MouseEvent mb' MouseButtonState'Pressed 26 | | mb == mb' -> 27 | let clicked = find (isWithin esCursorPos) areas 28 | in gs 29 | & (setDragAndDrop $ clicked <&> \(_, pos) -> DragAndDrop pos $ pos - esCursorPos) 30 | & (setPoss $ poss \\ catMaybes [snd <$> clicked]) 31 | MouseEvent mb' MouseButtonState'Released 32 | | mb == mb' -> 33 | gs 34 | & (setDragAndDrop Nothing) 35 | & (setPoss $ catMaybes [dragAndDrop' <&> \(DragAndDrop pos _) -> pos] <> poss) 36 | CursorPosEvent cursor -> 37 | gs 38 | & (setDragAndDrop $ dragAndDrop' <&> (\(DragAndDrop _ offset) -> DragAndDrop (cursor + offset) offset)) 39 | _ -> gs 40 | 41 | showDragAndDrop :: Maybe DragAndDrop -> (Pos -> a) -> [a] 42 | showDragAndDrop dragAndDrop' sprite' = catMaybes [dragAndDrop' <&> (\(DragAndDrop pos _) -> sprite' pos)] 43 | 44 | deleteOnClick :: EngineState -> gs -> MouseButton -> [Area] -> ([Pos] -> gs -> gs) -> Event -> gs 45 | deleteOnClick EngineState {..} gs mb areas setPoss = 46 | let poss = snd <$> areas 47 | in \case 48 | MouseEvent mb' MouseButtonState'Pressed 49 | | mb == mb' -> 50 | let clicked = find (isWithin esCursorPos) areas 51 | in gs & (setPoss $ poss \\ catMaybes [snd <$> clicked]) 52 | _ -> gs 53 | -------------------------------------------------------------------------------- /lib/Playtime/Util.hs: -------------------------------------------------------------------------------- 1 | module Playtime.Util where 2 | 3 | import Data.Time.Clock 4 | import Data.Time.Clock.System 5 | import Data.Time.Clock.TAI 6 | import GHC.Float (int2Double) 7 | import My.Prelude 8 | import Playtime.Event 9 | import Playtime.Geometry 10 | 11 | timeDiffPico :: SystemTime -> SystemTime -> Integer 12 | timeDiffPico before after = diffTimeToPicoseconds $ diffAbsoluteTime (systemToTAITime after) (systemToTAITime before) 13 | 14 | pico2second :: Double -> Double 15 | pico2second picosecs = picosecs / 1000 / 1000 / 1000 / 1000 16 | 17 | pico2Double :: Integral i => i -> Double 18 | pico2Double pico = int2Double (fromIntegral pico) / 1000 / 1000 / 1000 / 1000 19 | 20 | avg :: Foldable t => t Integer -> Double 21 | avg xs = (fromInteger @Double $ sum xs) / (int2Double $ length xs) 22 | 23 | allEnumValues :: forall a. (Enum a, Bounded a) => [a] 24 | allEnumValues = enumFrom (minBound :: a) 25 | 26 | mod2 :: Pos -> Pos -> Pos 27 | mod2 = pairWise mod' mod' 28 | 29 | pairWise :: (a -> b -> c) -> (a' -> b' -> c') -> (a, a') -> (b, b') -> (c, c') 30 | pairWise f g (a, a') (b, b') = (f a b, g a' b') 31 | 32 | --- 33 | 34 | --- stuff below needs cleanup or removal: 35 | data OneTimeEffect' = Load | Save | Reset deriving (Eq, Ord, Show, Generic, NFData) 36 | 37 | data MovementAction' = Up | Down | Left' | Right' deriving (Eq, Ord, Show, Generic, NFData) 38 | 39 | data Action = OneTimeEffect OneTimeEffect' | Exit | MovementAction MovementAction' deriving (Eq, Ord, Show, Generic, NFData) 40 | 41 | oneTimeEffectMay :: Action -> Maybe OneTimeEffect' 42 | oneTimeEffectMay (OneTimeEffect v) = Just v 43 | oneTimeEffectMay _ = Nothing 44 | 45 | movementAction :: Action -> Maybe MovementAction' 46 | movementAction (MovementAction v) = Just v 47 | movementAction _ = Nothing 48 | 49 | groupKeyBindings :: [([Key], Action)] -> Map Key [(Set Key, Action)] 50 | groupKeyBindings keyBindingsRaw = mapFromList $ groups <&> \l@(h :| _) -> (fst h, first setFromList <$> (join . toList $ snd <$> l)) 51 | where 52 | groups :: [NonEmpty (Key, [([Key], Action)])] 53 | groups = groupAllWith fst $ join $ keyBindingsRaw <&> (\b@(keys', _) -> (,[b]) <$> keys') 54 | 55 | keyBindings :: [([Key], Action)] 56 | keyBindings = 57 | [ ([Key'LeftSuper, Key'Q], Exit), 58 | ([Key'Escape], Exit), 59 | ([Key'LeftSuper, Key'L], OneTimeEffect Load), 60 | ([Key'LeftSuper, Key'S], OneTimeEffect Save), 61 | ([Key'LeftSuper, Key'R], OneTimeEffect Reset), 62 | ([Key'W], MovementAction Up), 63 | ([Key'S], MovementAction Down), 64 | ([Key'A], MovementAction Left'), 65 | ([Key'D], MovementAction Right') 66 | ] 67 | -------------------------------------------------------------------------------- /lib/Playtime/Wiring.hs: -------------------------------------------------------------------------------- 1 | module Playtime.Wiring where 2 | 3 | import Codec.Picture (DynamicImage) 4 | import Data.Aeson 5 | import GHC.Err (error) 6 | import My.IO 7 | import My.Prelude 8 | import Playtime.Debug 9 | import Playtime.EngineConfig 10 | import Playtime.EngineState 11 | import Playtime.Event 12 | import Playtime.GL 13 | import Playtime.Geometry 14 | import Playtime.LiveCode 15 | import Playtime.Texture 16 | 17 | wireEngineConfig :: 18 | forall a gs. 19 | (Ord a, Show a, ToJSON gs, FromJSON gs) => 20 | ((a -> Texture) -> EngineState -> gs -> Event -> IO gs) -> 21 | ((a -> Texture) -> EngineState -> gs -> [Sprite]) -> 22 | Dim -> 23 | Double -> 24 | Maybe LiveCodeState -> 25 | (a -> IO DynamicImage) -> 26 | [a] -> 27 | gs -> 28 | IO EngineConfig 29 | wireEngineConfig stepGameState visualize ecDim ecScale liveCodeState loadTx allTextures initialGameState = do 30 | recoveredGameState <- for liveCodeState startLiveCode 31 | gameStateMVar <- newMVar $ fromMaybe initialGameState $ join recoveredGameState 32 | texturesMVar <- newMVar mempty 33 | pure $ 34 | EngineConfig 35 | { ecStepGameState = \es event -> do 36 | modifyMVar_ gameStateMVar $ \old_gs -> do 37 | textures <- readTextures texturesMVar 38 | new_gs <- stepGameState textures es old_gs event 39 | for_ liveCodeState $ flip liveCodeSwitch new_gs 40 | pure new_gs, 41 | ecVisualize = \es -> do 42 | textures <- readTextures texturesMVar 43 | visualize textures es <$> readMVar gameStateMVar, 44 | ecDim = ecDim, 45 | ecScale = ecScale, 46 | ecCheckIfContinue = pure . not . gameExitRequested, 47 | ecGameDebugInfo = \EngineState {..} -> debugPrint <$> readMVar gameStateMVar 48 | } 49 | where 50 | readTextures texturesMVar = do 51 | textures' <- readMVar texturesMVar 52 | textures <- 53 | if null textures' then do 54 | textures'' <- loadTextures 55 | void $ swapMVar texturesMVar textures'' 56 | pure textures'' 57 | else 58 | pure textures' 59 | pure $ \t -> 60 | fromMaybe (error $ "error loading texture " <> show t <> ", did you forget putting it into all_textures?") $ 61 | mapLookup t textures 62 | loadTextures = do 63 | lt' <- for allTextures $ \i -> (i,) <$> (either fail pure =<< runExceptT . loadTexture =<< loadTx i) 64 | pure $ foldl (\m (k, v) -> mapInsert k v m) mempty lt' 65 | 66 | -- NOTE: resurrect this when implementing dynamically loaded textures 67 | -- updateTextureCache loadedTexturesMVar visualizations loadTx 68 | -- updateTextureCache :: Ord a => MVar (Map a Texture) -> [Sprite] -> (a -> IO DynamicImage) -> IO () 69 | -- updateTextureCache loadedTexturesMVar visualizations f' = 70 | -- modifyMVar loadedTexturesMVar $ \loadedTextures -> do 71 | -- let f (acc, loadedTextures') = \(Sprite area t) -> case t of 72 | -- DynamicSprite ref -> 73 | -- case mapLookup ref loadedTextures' of 74 | -- Nothing -> do 75 | -- texture <- either fail pure =<< (runExceptT . loadTexture) =<< f' ref 76 | -- pure (TexturePlacements texture area : acc, mapInsert ref texture loadedTextures') 77 | -- Just texture -> pure (TexturePlacements texture area : acc, loadedTextures') 78 | -- s@Rectangle{} -> pure (s : acc, loadedTextures') 79 | -- swap <$> foldlM f ([], loadedTextures) visualizations 80 | -------------------------------------------------------------------------------- /live-coding-demo/LiveCodingDemo/Game.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 2 | {-# OPTIONS_GHC -fno-warn-unused-local-binds #-} 3 | {-# OPTIONS_GHC -fno-warn-unused-matches #-} 4 | 5 | module LiveCodingDemo.Game where 6 | 7 | import Data.Aeson (FromJSON, ToJSON) 8 | import Data.List (zip) 9 | import My.Prelude 10 | import Playtime 11 | 12 | data TextureId = Heart | Spaceship | Enemy deriving (Eq, Ord, Show, Data, Bounded, Enum, Generic, NFData, ToJSON, FromJSON) 13 | 14 | textures :: TextureId -> (Scale, FilePath) 15 | textures = \case 16 | Spaceship -> (1, "plane.png") 17 | Enemy -> (0.1, "enemy_red.png") 18 | Heart -> (0.025, "haskell_love_logo.png") 19 | 20 | data GameState = GameState 21 | { gsPlayer :: Pos, 22 | gsStars :: [Pos], 23 | gsHearts :: [Pos], 24 | gsEnemies :: [Pos] 25 | } 26 | deriving (Show, Generic, NFData, ToJSON, FromJSON) 27 | 28 | makeInitialGameState :: Dim -> Int -> GameState 29 | makeInitialGameState dimensions seed = 30 | let rng = mkStdGen seed 31 | numStars = 500 32 | (stars, _) = randomPoss rng numStars dimensions 33 | in GameState 34 | { gsPlayer = (10000, 10000), 35 | gsStars = [], --stars, 36 | gsHearts = [], 37 | gsEnemies = [] 38 | } 39 | 40 | stepGameStatePure :: Int -> (TextureId -> Dim) -> GameState -> EngineState -> Event -> GameState 41 | stepGameStatePure seed tDim gs@GameState {..} EngineState {..} = \case 42 | KeyEvent Key'Space KeyState'Pressed -> 43 | gs 44 | { gsHearts = gsHearts <> ((gsPlayer +) <$> [(300, 100), (300, 145), (325, 200), (325, 290), (300, 340), (300, 390)]) 45 | } 46 | RenderEvent _ -> 47 | let rng = mkStdGen seed 48 | -- collisionMay e h = if (tDim Enemy, e) `collidesWith` (tDim Heart, h) then Just (e, h) else Nothing 49 | (hitEnemies, hitHearts) = ([],[]) -- unzip $ catMaybes $ collisionMay <$> gsEnemies <*> gsHearts 50 | numAddedEnemies = 10 - length gsEnemies 51 | addedEnemies = [] -- repeat 900 `zip` (fst $ randomsNatDouble rng numAddedEnemies $ snd esWindowSize) 52 | movePlayerY pos = 53 | if 54 | | Key'W `setMember` esKeysPressed -> pos - dupe esTimePassed * (0, 200) 55 | | Key'S `setMember` esKeysPressed -> pos + dupe esTimePassed * (0, 200) 56 | | True -> pos 57 | movePlayerX pos = 58 | if 59 | | Key'A `setMember` esKeysPressed -> pos - dupe esTimePassed * (200, 0) 60 | | Key'D `setMember` esKeysPressed -> pos + dupe esTimePassed * (200, 0) 61 | | True -> pos 62 | newHearts = (gsHearts \\ hitHearts) 63 | newEnemies = ((gsEnemies \\ hitEnemies) <> addedEnemies) 64 | in gs 65 | { gsPlayer = gsPlayer, -- movePlayerX $ movePlayerY gsPlayer, 66 | gsStars = gsStars, -- <&> (`mod2` esDimensions) . (subtract $ dupe esTimePassed * (100,0)), 67 | gsHearts = newHearts, -- filter ((< fst esDimensions) . fst) $ -- <&> (+ dupe esTimePassed * (200, 0)), 68 | gsEnemies = newEnemies -- filter ((>0) . fst) $ <&> (subtract $ dupe esTimePassed * (200,0)) 69 | } 70 | _ -> gs 71 | 72 | visualize :: (TextureId -> Pos -> Sprite) -> EngineState -> GameState -> [Sprite] 73 | visualize sprite EngineState {..} GameState {..} = 74 | let 75 | in [sprite Spaceship gsPlayer] 76 | <> (sprite Heart <$> gsHearts) 77 | <> (sprite Enemy <$> gsEnemies) 78 | <> (rectangle Solid (RGBA 180 180 180 255) 3 <$> gsStars) 79 | -------------------------------------------------------------------------------- /live-coding-demo/LiveCodingDemo/Main.hs: -------------------------------------------------------------------------------- 1 | module LiveCodingDemo.Main where 2 | 3 | import Codec.Picture (readPng) 4 | import LiveCodingDemo.Game 5 | import My.IO 6 | import My.Prelude 7 | import Playtime 8 | import System.Random 9 | 10 | gameDir :: FilePath 11 | gameDir = "live-coding-demo" 12 | 13 | main :: IO () 14 | main = 15 | playtime . Left 16 | =<< makeLiveCodeState makeEngineConfig "LiveCodingDemo.Main" "makeEngineConfig" (gameDir "LiveCodingDemo") 17 | 18 | makeEngineConfig :: Maybe LiveCodeState -> IO EngineConfig 19 | makeEngineConfig liveCodeState = do 20 | initialGameState 21 | >>= wireEngineConfig 22 | (stepGameState . textureDim textures) 23 | (visualize . textureSprites textures) 24 | dimensions 25 | 1 26 | liveCodeState 27 | loadTexture 28 | (snd . textures <$> allEnumValues) 29 | where 30 | dimensions = (1024, 768) 31 | initialGameState = makeInitialGameState dimensions <$> randomIO 32 | stepGameState area es@EngineState {..} old_gs event = do 33 | seed <- randomIO 34 | let new_gs = stepGameStatePure seed area old_gs es event 35 | if Key'R `setMember` esKeysPressed 36 | then initialGameState 37 | else pure new_gs 38 | loadTexture = \name -> either fail pure =<< (readPng $ gameDir "assets" name) 39 | -------------------------------------------------------------------------------- /live-coding-demo/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified LiveCodingDemo.Main 4 | import My.IO 5 | 6 | main :: IO () 7 | main = do 8 | LiveCodingDemo.Main.main 9 | -------------------------------------------------------------------------------- /live-coding-demo/assets/enemy_red.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/live-coding-demo/assets/enemy_red.png -------------------------------------------------------------------------------- /live-coding-demo/assets/haskell_love_logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/live-coding-demo/assets/haskell_love_logo.png -------------------------------------------------------------------------------- /live-coding-demo/assets/plane.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/live-coding-demo/assets/plane.png -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: playtime 2 | version: 0.1.0.0 3 | github: "githubuser/playtime" 4 | author: "Chris Vogt" 5 | maintainer: "" 6 | copyright: "2020 Chris Vogt" 7 | 8 | # Metadata used when publishing your package 9 | # synopsis: Short description of your package 10 | # category: Web 11 | 12 | # To avoid duplicated efforts in documentation and dealing with the 13 | # complications of embedding Haddock markup inside cabal files, it is 14 | # common to point users to the README.md file. 15 | description: Please see the README on GitHub at ... 16 | 17 | dependencies: 18 | # - ansi-terminal 19 | - aeson 20 | - base 21 | - bmp 22 | - bytestring 23 | - containers 24 | - deepseq 25 | - file-embed 26 | - filepath 27 | - integer-gmp 28 | - mtl 29 | - protolude 30 | - random 31 | - safe 32 | - sdl2-mixer 33 | - tar 34 | - text 35 | - time 36 | - unix 37 | - unordered-containers 38 | - vector 39 | 40 | # for debug 41 | - ansi-terminal 42 | - terminal-size 43 | 44 | # for live code feature 45 | - ghc 46 | - ghc-paths 47 | - ghc-boot-th 48 | - fsnotify 49 | - silently 50 | 51 | # extra 52 | - extra 53 | - monad-extras 54 | - monad-loops 55 | - universum 56 | 57 | # formatting 58 | - ormolu 59 | 60 | # opengl and friends 61 | - OpenGL 62 | - JuicyPixels 63 | - GLFW-b 64 | 65 | # maybe game dev relevant 66 | - pathfinding 67 | 68 | # music generation 69 | - Euterpea 70 | 71 | default-extensions: 72 | - DeriveAnyClass 73 | - DeriveDataTypeable 74 | - DeriveFunctor 75 | - DeriveGeneric 76 | - DerivingStrategies 77 | - FlexibleContexts 78 | - FlexibleInstances 79 | - GeneralizedNewtypeDeriving # FIXME: Safe Haskell considers GeneralizedNewtypeDeriving unsafe 80 | - LambdaCase 81 | - MultiParamTypeClasses 82 | - MultiWayIf 83 | - NamedFieldPuns 84 | - NoImplicitPrelude 85 | - OverloadedStrings 86 | - PackageImports 87 | - RecordWildCards 88 | - ScopedTypeVariables 89 | - StandaloneDeriving 90 | - TupleSections 91 | - TypeApplications 92 | - TypeOperators 93 | - ViewPatterns 94 | # FIXME: Safe Haskell considers TemplateHaskell unsafe, maybe at least use manual PRAGMA or use cwd instead of FileEmbed? 95 | 96 | library: 97 | source-dirs: lib 98 | 99 | ghc-options: 100 | -O0 -j -Weverything -Werror 101 | -Wno-missing-export-lists 102 | -Wno-missing-import-lists 103 | -Wno-missing-local-signatures 104 | -Wno-safe 105 | -Wno-unsafe 106 | -Wno-missing-deriving-strategies 107 | -Wno-monomorphism-restriction 108 | # -optP-Wno-nonportable-include-path 109 | 110 | executables: 111 | spaceminer: 112 | main: Main.hs 113 | source-dirs: spaceminer 114 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 115 | dependencies: playtime 116 | platformer: 117 | main: Main.hs 118 | source-dirs: platformer 119 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 120 | dependencies: playtime 121 | shoot-em-up: 122 | main: Main.hs 123 | source-dirs: shoot-em-up 124 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 125 | dependencies: playtime 126 | live-coding-demo: 127 | main: Main.hs 128 | source-dirs: live-coding-demo 129 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 130 | dependencies: playtime 131 | 132 | tests: 133 | playtime-test: 134 | main: Spec.hs 135 | source-dirs: test 136 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 137 | dependencies: playtime 138 | -------------------------------------------------------------------------------- /platformer/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Time.Clock.System 4 | import GHC.Err (error) 5 | import My.IO 6 | import My.Prelude 7 | import Platformer.GameState 8 | import qualified Platformer.Main 9 | import Playtime 10 | 11 | dimensions :: Dim 12 | dimensions = (320, 240) 13 | 14 | main :: IO () 15 | main = do 16 | putStrLn "running tests" 17 | -- tests 18 | putStrLn "starting main" 19 | Platformer.Main.main 20 | 21 | tests :: IO () 22 | tests = do 23 | let igs = 24 | (makeInitialGameState dimensions) 25 | { gsVelocityY = 0.33, 26 | gsMainCharacter = (0, (-7)), 27 | gsRoom = Board $ mapFromList $ (,FloorPlate) <$> [(-6, 5), (6, 5)] 28 | } 29 | time <- getSystemTime 30 | let egs = makeInitialEngineState 3 dimensions time 31 | let igs' = stepGameStatePure (error "load textures in tests") igs egs $ RenderEvent (time {systemNanoseconds = systemNanoseconds time + 1000000000}) 32 | when (gsMainCharacter igs' /= gsMainCharacter igs) $ do 33 | putStrLn $ "FAIL: " <> show igs' 34 | -------------------------------------------------------------------------------- /platformer/Platformer/GameState.hs: -------------------------------------------------------------------------------- 1 | module Platformer.GameState where 2 | 3 | import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON)) 4 | import Data.List (zip) 5 | import "GLFW-b" Graphics.UI.GLFW 6 | import My.Prelude 7 | import Playtime 8 | 9 | data TextureId = FloorPlate | MainCharacter 10 | deriving (Eq, Ord, Show, Data, Bounded, Enum, Generic, NFData, ToJSON, FromJSON) 11 | 12 | textures :: TextureId -> (Scale, FilePath) 13 | textures = \case 14 | MainCharacter -> (1, "main_character.png") 15 | FloorPlate -> (1, "floor_plate.png") 16 | 17 | newtype Board = Board {unBoard :: Map Pos TextureId} deriving newtype (Show, Semigroup, Monoid, NFData) 18 | 19 | data GameState = GameState 20 | { gsCollisions :: Corners (Maybe Area), 21 | gsVelocityY :: Double, 22 | gsVelocityX :: Double, 23 | gsMainCharacter :: Pos, 24 | gsMainCharacterPrevious :: Pos, 25 | gsPenetrable :: Board, 26 | gsRoom :: Board 27 | } 28 | deriving (Show, Generic, NFData, ToJSON, FromJSON) 29 | 30 | gridsize :: Num n => n 31 | gridsize = 12 32 | 33 | makeInitialGameState :: Dim -> GameState 34 | makeInitialGameState dim = 35 | GameState 36 | { gsCollisions = Corners Nothing Nothing Nothing Nothing, 37 | gsVelocityY = 0, 38 | gsVelocityX = 0, 39 | gsMainCharacter = dim * (0.5, 0), 40 | gsMainCharacterPrevious = dim * (0.5, 0), 41 | gsPenetrable = Board $ mempty, 42 | gsRoom = 43 | Board 44 | $ mapInsert (240, 188) FloorPlate 45 | $ mapInsert (240, 176) FloorPlate 46 | $ mapFromList 47 | $ concat 48 | $ take 10 49 | $ (iterate (+ 12) 200 <&>) 50 | $ (\r -> take 60 $ (iterate (+ 12) 0 `zip` repeat r) `zip` (repeat FloorPlate)) 51 | } 52 | 53 | stepGameStatePure :: (TextureId -> Dim) -> GameState -> EngineState -> Event -> GameState 54 | stepGameStatePure area gs@GameState {..} EngineState {..} = \case 55 | KeyEvent Key'Space KeyState'Pressed -> gs {gsVelocityY = -220} 56 | RenderEvent _ -> 57 | let speedX = 100 58 | newMainCharacter = 59 | move 60 | esTimePassed 61 | (area MainCharacter, gsMainCharacter) 62 | gsMainCharacterPrevious 63 | gsVelocityX 64 | gsVelocityY 65 | $ (area FloorPlate,) <$> (keys $ unBoard gsRoom) 66 | in gs 67 | { gsMainCharacter = newMainCharacter, 68 | gsMainCharacterPrevious = gsMainCharacter, 69 | gsVelocityY = 70 | if gsVelocityY /= 0 && snd gsMainCharacter == snd newMainCharacter 71 | then 0 72 | else gsVelocityY + 9.81 * esTimePassed * 55, 73 | gsVelocityX = 74 | if Key'A `setMember` esKeysPressed 75 | then - speedX 76 | else 77 | if Key'D `setMember` esKeysPressed 78 | then speedX 79 | else 0 80 | } 81 | _ -> gs 82 | 83 | instance FromJSON Board where parseJSON = fmap (Board . mapFromList) . parseJSON 84 | 85 | instance ToJSON Board where toJSON = toJSON . mapToList . unBoard 86 | -------------------------------------------------------------------------------- /platformer/Platformer/Main.hs: -------------------------------------------------------------------------------- 1 | module Platformer.Main where 2 | 3 | import Codec.Picture (readPng) 4 | import My.IO 5 | import My.Prelude 6 | import Platformer.GameState 7 | import Platformer.Visualize 8 | import Playtime 9 | 10 | gameDir :: FilePath 11 | gameDir = "platformer" 12 | 13 | main :: IO () 14 | main = 15 | playtime . Left 16 | =<< makeLiveCodeState makeEngineConfig "Platformer.Main" "makeEngineConfig" (gameDir "Platformer") 17 | 18 | makeEngineConfig :: Maybe LiveCodeState -> IO EngineConfig 19 | makeEngineConfig liveCodeState = do 20 | wireEngineConfig 21 | (stepGameState . textureDim textures) 22 | (visualize . textureSprites textures) 23 | dimensions 24 | 3 25 | liveCodeState 26 | loadTexture 27 | (snd . textures <$> allEnumValues) 28 | $ makeInitialGameState dimensions 29 | where 30 | dimensions = (320, 240) 31 | stepGameState area es@EngineState {..} old_gs event = do 32 | let new_gs = stepGameStatePure area old_gs es event 33 | saveMay es new_gs 34 | fromMaybe new_gs <$> loadMay es 35 | loadTexture = \name -> either fail pure =<< (readPng $ gameDir "assets" name) 36 | -------------------------------------------------------------------------------- /platformer/Platformer/Visualize.hs: -------------------------------------------------------------------------------- 1 | module Platformer.Visualize where 2 | 3 | import qualified Data.Map as Map 4 | import My.Prelude 5 | import Platformer.GameState 6 | import Playtime 7 | 8 | visualize :: (TextureId -> Pos -> Sprite) -> EngineState -> GameState -> [Sprite] 9 | visualize sprite EngineState {..} GameState {..} = 10 | [sprite MainCharacter gsMainCharacter] <> room 11 | where 12 | room = (Map.toList $ unBoard gsRoom) <&> \(pos, t) -> sprite t pos 13 | 14 | -- backup of grouping logic as reminder if needed: (groupWith snd $ Map.toList $ unBoard gsFloor) <&> \ne@((_, t) :| _) -> 15 | -------------------------------------------------------------------------------- /platformer/assets/floor_plate.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/platformer/assets/floor_plate.png -------------------------------------------------------------------------------- /platformer/assets/main_character.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/platformer/assets/main_character.png -------------------------------------------------------------------------------- /shoot-em-up/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import My.IO 4 | import My.Prelude 5 | import qualified ShootEmUp.Main 6 | 7 | main :: IO () 8 | main = do 9 | putStrLn "running tests" 10 | tests 11 | putStrLn "starting main" 12 | ShootEmUp.Main.main 13 | 14 | tests :: IO () 15 | tests = pure () 16 | -------------------------------------------------------------------------------- /shoot-em-up/ShootEmUp/GameState.hs: -------------------------------------------------------------------------------- 1 | module ShootEmUp.GameState where 2 | 3 | import Data.Aeson (FromJSON, ToJSON) 4 | import Data.List (zip) 5 | import GHC.Float (double2Int, int2Double) 6 | import GHC.Real (mod) 7 | import "GLFW-b" Graphics.UI.GLFW 8 | import My.IO 9 | import My.Prelude 10 | import Playtime 11 | import System.Random 12 | 13 | data GameState = GameState 14 | { gsMainCharacter :: Pos, 15 | gsEnemies :: [Pos], 16 | gsStars :: [(Double, Pos)], 17 | gsHearts :: [Pos], 18 | gsMaxStarSize :: Double, 19 | gsDragAndDrop :: Maybe DragAndDrop 20 | } 21 | deriving (Show, Generic, NFData, ToJSON, FromJSON) 22 | 23 | numEnemies :: Int 24 | numEnemies = 10 25 | 26 | data TextureId = Enemy | Heart | Spaceship 27 | deriving (Eq, Ord, Show, Data, Bounded, Enum, Generic, NFData, ToJSON, FromJSON) 28 | 29 | textures :: TextureId -> (Scale, FilePath) 30 | textures = \case 31 | Spaceship -> (1, "plane.png") 32 | Enemy -> (0.1, "enemy_red.png") 33 | Heart -> (0.025, "haskell_love_logo.png") 34 | 35 | makeInitialGameState :: Dim -> IO GameState 36 | makeInitialGameState dim = do 37 | let maxStarSize = 3 38 | starX <- fmap (fmap int2Double) $ sequence $ replicate 510 $ randomRIO (0, double2Int $ maxStarSize + fst dim) 39 | starY <- fmap (fmap int2Double) $ sequence $ replicate 510 $ randomRIO (0, double2Int $ maxStarSize + snd dim) 40 | starSize <- fmap (fmap int2Double) $ sequence $ replicate 510 $ randomRIO (0, double2Int maxStarSize) 41 | pure 42 | GameState 43 | { gsMainCharacter = (10, 200), 44 | gsEnemies = mempty, 45 | gsStars = starSize `zip` (starX `zip` starY), 46 | gsHearts = mempty, 47 | gsMaxStarSize = maxStarSize, 48 | gsDragAndDrop = Nothing 49 | } 50 | 51 | stepGameStatePure :: [Int] -> (TextureId -> Dim) -> GameState -> EngineState -> Event -> GameState 52 | stepGameStatePure pre area old_gs es event = 53 | foldl 54 | (&) 55 | old_gs 56 | [ \gs -> dragAndDrop es gs MouseButton'1 (getBulletAreas gs) setBullets (getDragAndDrop gs) setDragAndDrop event, 57 | \gs -> deleteOnClick es gs MouseButton'2 (getBulletAreas gs) setBullets event, 58 | \gs -> stepGameStatePure' pre area gs es event 59 | ] 60 | where 61 | setBullets bullets gs = gs {gsHearts = bullets} 62 | getBulletAreas gs = (area Heart,) <$> gsHearts gs 63 | getDragAndDrop gs = gsDragAndDrop gs 64 | setDragAndDrop v gs = gs {gsDragAndDrop = v} 65 | 66 | stepGameStatePure' :: [Int] -> (TextureId -> Dim) -> GameState -> EngineState -> Event -> GameState 67 | stepGameStatePure' randInts tDim gs@GameState {..} EngineState {..} = \case 68 | KeyEvent Key'Space KeyState'Pressed -> 69 | gs 70 | { gsHearts = 71 | gsHearts 72 | <> ((gsMainCharacter +) <$> [(300, 100) :: Dim, (300, 145), (325, 200), (325, 290), (300, 340), (300, 390)]) 73 | } 74 | RenderEvent _ -> 75 | let distancePerSec = 200 76 | (_, height) = esDimensions 77 | direction :: Dim 78 | direction = 79 | ( if 80 | | MovementAction Left' `setMember` esActions -> -1 81 | | MovementAction Right' `setMember` esActions -> 1 82 | | True -> 0, 83 | if 84 | | MovementAction Up `setMember` esActions -> -1 85 | | MovementAction Down `setMember` esActions -> 1 86 | | True -> 0 87 | ) 88 | bulletVelocity = (300, 0) 89 | bulletStep :: Dim 90 | bulletStep = dupe esTimePassed * bulletVelocity 91 | survivingEnemies = 92 | flip filter gsEnemies $ \enemyPos -> 93 | (fst enemyPos > - fst (tDim Enemy) &&) 94 | $ not 95 | $ any ((tDim Enemy, enemyPos) `collidesWith`) (bulletTrajectory =<< gsHearts) 96 | where 97 | bulletTrajectory pos = (tDim Heart,) <$> trajectoryPixels pos esTimePassed bulletVelocity 98 | newEnemies = survivingEnemies <> (newEnemyPos <$> take numAdded randInts) 99 | where 100 | numAdded = numEnemies - length survivingEnemies 101 | newEnemyPos :: Int -> Pos 102 | newEnemyPos y = (1100, int2Double . flip mod (double2Int $ height - (snd $ tDim Enemy)) $ y) 103 | stepStar :: (Double, Pos) -> (Double, Pos) 104 | stepStar (size, pos) = (size,) $ modu $ move' pos 105 | where 106 | move' = subtract (esTimePassed * size * 6, 0) 107 | modu = (`mod2` (esDimensions + dupe gsMaxStarSize)) 108 | in gs 109 | { gsMainCharacter = gsMainCharacter + (dupe $ esTimePassed * distancePerSec) * direction, 110 | gsEnemies = (subtract $ (esTimePassed * 100, 0)) <$> newEnemies, 111 | gsStars = stepStar <$> gsStars, 112 | gsHearts = filter ((< 1024) . fst) gsHearts <&> (+ bulletStep) 113 | } 114 | _ -> gs 115 | -------------------------------------------------------------------------------- /shoot-em-up/ShootEmUp/Main.hs: -------------------------------------------------------------------------------- 1 | module ShootEmUp.Main where 2 | 3 | import Codec.Picture (readPng) 4 | import Control.Concurrent.MVar (newEmptyMVar, putMVar) 5 | import My.IO 6 | import My.Prelude 7 | import Playtime 8 | import SDL.Mixer 9 | import ShootEmUp.GameState 10 | import ShootEmUp.Visualize 11 | import System.Random 12 | 13 | gameDir :: FilePath 14 | gameDir = "shoot-em-up" 15 | 16 | main :: IO () 17 | main = do 18 | void $ forkIO $ do 19 | openAudio (Audio 44100 FormatS16_LSB Mono) 4410 20 | setChannels 500 -- default 8 seems to be problematic, so choosing somethign much larger ... 500 21 | setVolume 8 AllChannels 22 | void $ playForever =<< load (gameDir "assets/venus_music.ogg") -- https://opengameart.org/content/nes-shooter-music-5-tracks-3-jingles 23 | playtime . Left 24 | =<< makeLiveCodeState makeEngineConfig "ShootEmUp.Main" "makeEngineConfig" (gameDir "ShootEmUp") 25 | 26 | makeEngineConfig :: Maybe LiveCodeState -> IO EngineConfig 27 | makeEngineConfig liveCodeState = do 28 | popSound <- newEmptyMVar 29 | void $ forkIO 30 | $ whileM 31 | $ fmap isLeft 32 | $ try @SomeException 33 | $ putMVar popSound =<< load (gameDir "assets/bubble_pop.ogg") -- https://freesound.org/people/blue2107/sounds/59978/ 34 | makeInitialGameState dimensions 35 | >>= wireEngineConfig 36 | (stepGameState popSound . textureDim textures) 37 | (visualize . textureSprites textures) 38 | dimensions 39 | 1 40 | liveCodeState 41 | loadTx 42 | (snd . textures <$> allEnumValues) 43 | where 44 | dimensions = (1024, 768) 45 | loadTx = \name -> either fail pure =<< (readPng $ gameDir "assets" name) 46 | stepGameState popSound area es@EngineState {..} old_gs event = do 47 | pre <- preIO 48 | let new_gs = stepGameStatePure pre area old_gs es event 49 | postIO es new_gs popSound 50 | preIO = sequence $ replicate 10 randomIO 51 | postIO es new_gs popSound = do 52 | when (Key'Space `elem` esKeysPressed es) $ play =<< readMVar popSound 53 | post_gs <- if Key'R `setMember` esKeysPressed es then makeInitialGameState dimensions else pure new_gs 54 | saveMay es post_gs 55 | fromMaybe post_gs <$> loadMay es 56 | -------------------------------------------------------------------------------- /shoot-em-up/ShootEmUp/Visualize.hs: -------------------------------------------------------------------------------- 1 | module ShootEmUp.Visualize where 2 | 3 | import My.Prelude 4 | import Playtime 5 | import ShootEmUp.GameState 6 | 7 | visualize :: (TextureId -> Pos -> Sprite) -> EngineState -> GameState -> [Sprite] 8 | visualize sprite EngineState {..} GameState {..} = 9 | [sprite Spaceship gsMainCharacter] 10 | <> (sprite Heart <$> gsHearts) 11 | <> (sprite Enemy <$> gsEnemies) 12 | <> stars 13 | <> showDragAndDrop gsDragAndDrop (sprite Heart) 14 | <> showDragAndDrop gsDragAndDrop (rectangle' (Border 3) (RGBA 255 0 0 255) . spriteArea . sprite Heart) 15 | where 16 | stars = 17 | gsStars <&> \((+ 1) -> size, pos) -> 18 | rectangle Solid (RGBA 180 180 180 255) (- size, size) pos -- -size for x so stars extend to the left and can leave the screen smoothly 19 | -------------------------------------------------------------------------------- /shoot-em-up/assets/bubble_pop.ogg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/shoot-em-up/assets/bubble_pop.ogg -------------------------------------------------------------------------------- /shoot-em-up/assets/enemy_green.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/shoot-em-up/assets/enemy_green.png -------------------------------------------------------------------------------- /shoot-em-up/assets/enemy_red.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/shoot-em-up/assets/enemy_red.png -------------------------------------------------------------------------------- /shoot-em-up/assets/haskell_love_logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/shoot-em-up/assets/haskell_love_logo.png -------------------------------------------------------------------------------- /shoot-em-up/assets/plane.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/shoot-em-up/assets/plane.png -------------------------------------------------------------------------------- /shoot-em-up/assets/venus_music.ogg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/shoot-em-up/assets/venus_music.ogg -------------------------------------------------------------------------------- /spaceminer/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import My.IO 4 | import My.Prelude 5 | import qualified SpaceMiner.Main 6 | 7 | main :: IO () 8 | main = do 9 | putStrLn "running tests" 10 | tests 11 | putStrLn "starting main" 12 | SpaceMiner.Main.main 13 | 14 | tests :: IO () 15 | tests = pure () 16 | -------------------------------------------------------------------------------- /spaceminer/SpaceMiner/GameState.hs: -------------------------------------------------------------------------------- 1 | module SpaceMiner.GameState where 2 | 3 | import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON)) 4 | import GHC.Float (int2Double) 5 | import GHC.Real (floor) 6 | import "GLFW-b" Graphics.UI.GLFW 7 | import My.Prelude 8 | import Playtime 9 | 10 | data TextureId = Inventory | RedResource | TopWall | MainCharacter | FloorPlate 11 | deriving (Eq, Ord, Show, Data, Bounded, Enum, Generic, NFData, ToJSON, FromJSON) 12 | 13 | textures :: TextureId -> (Scale, FilePath) 14 | textures = \case 15 | Inventory -> (1, "inventory.png") 16 | RedResource -> (1, "red_resource.png") 17 | TopWall -> (1, "top_wall.png") 18 | MainCharacter -> (1, "main_character.png") 19 | FloorPlate -> (1, "floor_plate.png") 20 | 21 | newtype Board = Board {unBoard :: Map Pos TextureId} deriving newtype (Show, Semigroup, Monoid, NFData) 22 | 23 | data UIMode = TexturePlacementMode TextureId | TextureMoveMode deriving (Show, Generic, NFData, ToJSON, FromJSON) 24 | 25 | data GameState = GameState 26 | { gsUIMode :: UIMode, 27 | gsCollisions :: (Maybe Area, Maybe Area, Maybe Area, Maybe Area), 28 | gsCandidates :: [Pos], 29 | gsFloor :: Board, 30 | gsRoom :: Board, 31 | gsLastPlacement :: Pos, 32 | gsMainCharacter :: Pos, 33 | gsMainCharacterPrevious :: Pos 34 | } 35 | deriving (Show, Generic, NFData, ToJSON, FromJSON) 36 | 37 | gridsize :: Num n => n 38 | gridsize = 12 39 | 40 | makeInitialGameState :: Dim -> GameState 41 | makeInitialGameState dim = 42 | GameState 43 | { gsUIMode = TexturePlacementMode FloorPlate, 44 | gsCandidates = mempty, 45 | gsCollisions = (Nothing, Nothing, Nothing, Nothing), 46 | gsFloor = mempty, 47 | gsRoom = mempty, 48 | gsLastPlacement = 0, 49 | gsMainCharacter = dim / (2 :: Scale), 50 | gsMainCharacterPrevious = dim / (2 :: Scale) 51 | } 52 | 53 | stepGameStatePure :: (TextureId -> Dim) -> GameState -> EngineState -> Event -> GameState 54 | stepGameStatePure tDim gs@GameState {..} EngineState {..} = \case 55 | CursorPosEvent _ -> 56 | let placement = bimap (gridify) (gridify) esCursorPos 57 | gridify = (* gridsize) . int2Double . floor . (/ gridsize) 58 | in gs 59 | { gsLastPlacement = placement, 60 | gsFloor = 61 | case gsUIMode of 62 | TexturePlacementMode texture -> 63 | case (`setMember` esMousePressed) of 64 | f | f MouseButton'1 && texture == FloorPlate -> Board $ mapInsert placement texture (unBoard gsFloor) 65 | f | f MouseButton'2 -> Board $ mapDelete placement (unBoard gsFloor) 66 | _ -> gsFloor 67 | TextureMoveMode -> gsFloor, 68 | gsRoom = 69 | case gsUIMode of 70 | TexturePlacementMode texture -> 71 | case (`setMember` esMousePressed) of 72 | f | f MouseButton'1 && texture /= FloorPlate -> Board $ mapInsert placement texture (unBoard gsRoom) 73 | f | f MouseButton'2 -> Board $ mapDelete placement (unBoard gsRoom) 74 | _ -> gsRoom 75 | TextureMoveMode -> gsRoom 76 | } 77 | KeyEvent key KeyState'Pressed -> 78 | gs 79 | { gsUIMode = case key of 80 | Key'1 -> TexturePlacementMode FloorPlate 81 | Key'2 -> TexturePlacementMode TopWall 82 | Key'3 -> TextureMoveMode 83 | _ -> gsUIMode 84 | } 85 | RenderEvent _ -> 86 | if OneTimeEffect Reset `setMember` esActions 87 | then gs {gsFloor = mempty, gsRoom = mempty} 88 | else 89 | let distancePerSec = 100 90 | velocityX = if MovementAction Left' `setMember` esActions then 0 - distancePerSec else if MovementAction Right' `setMember` esActions then 0 + distancePerSec else 0 91 | velocityY = if MovementAction Up `setMember` esActions then 0 - distancePerSec else if MovementAction Down `setMember` esActions then 0 + distancePerSec else 0 92 | in gs 93 | { gsMainCharacter = move esTimePassed (tDim MainCharacter, gsMainCharacter) gsMainCharacterPrevious velocityX velocityY $ (tDim FloorPlate,) <$> (keys $ unBoard gsRoom), 94 | gsMainCharacterPrevious = gsMainCharacter 95 | } 96 | _ -> gs 97 | 98 | instance FromJSON Board where parseJSON = fmap (Board . mapFromList) . parseJSON 99 | 100 | instance ToJSON Board where toJSON = toJSON . mapToList . unBoard 101 | -------------------------------------------------------------------------------- /spaceminer/SpaceMiner/Main.hs: -------------------------------------------------------------------------------- 1 | module SpaceMiner.Main where 2 | 3 | import Codec.Picture (readPng) 4 | import My.IO 5 | import My.Prelude 6 | import Playtime 7 | import SpaceMiner.GameState 8 | import SpaceMiner.Visualize 9 | 10 | gameDir :: FilePath 11 | gameDir = "spaceminer" 12 | 13 | main :: IO () 14 | main = 15 | playtime . Left 16 | =<< makeLiveCodeState makeEngineConfig "SpaceMiner.Main" "makeEngineConfig" (gameDir "SpaceMiner") 17 | 18 | makeEngineConfig :: Maybe LiveCodeState -> IO EngineConfig 19 | makeEngineConfig liveCodeState = do 20 | wireEngineConfig 21 | (stepGameState . textureDim textures) 22 | (visualize . textureSprites textures) 23 | dimensions 24 | 3 25 | liveCodeState 26 | loadTexture 27 | (snd . textures <$> allEnumValues) 28 | $ makeInitialGameState dimensions 29 | where 30 | dimensions = (320, 240) 31 | stepGameState area es@EngineState {..} old_gs event = do 32 | let new_gs = stepGameStatePure area old_gs es event 33 | saveMay es new_gs 34 | fromMaybe new_gs <$> loadMay es 35 | loadTexture = \name -> either fail pure =<< (readPng $ gameDir "assets" name) 36 | -------------------------------------------------------------------------------- /spaceminer/SpaceMiner/Visualize.hs: -------------------------------------------------------------------------------- 1 | module SpaceMiner.Visualize where 2 | 3 | import Codec.Picture.Types (PixelRGBA8 (PixelRGBA8), pixelAt) 4 | import qualified Data.Map as Map 5 | import GHC.Float (double2Int) 6 | import My.Prelude 7 | import Playtime 8 | import SpaceMiner.GameState 9 | 10 | visualize :: (TextureId -> Pos -> Sprite) -> EngineState -> GameState -> [Sprite] 11 | visualize sprite EngineState {..} GameState {..} = 12 | highlightMouserOver <> sprites 13 | where 14 | sprites = 15 | inventoryUI 16 | <> [ sprite MainCharacter gsMainCharacter, 17 | sprite MainCharacter 0, 18 | sprite MainCharacter 50, 19 | rectangle (Border 3) (RGBA 255 0 0 255) 24 90, 20 | rectangle Solid (RGBA 255 255 0 255) 24 (90, 114) 21 | ] 22 | <> room 23 | <> floor 24 | highlightMouserOver = case findMouseOver of 25 | Nothing -> [] 26 | Just (Rectangle area _) -> highlight area 27 | highlight (dim, pos) = [rectangle (Border 3) (RGBA 0 255 0 255) (dim + 4) (pos -2)] 28 | findMouseOver = 29 | flip find sprites $ \case 30 | Rectangle area@(dim', pos) (Left (Texture dim _ img)) -> 31 | let p = (esCursorPos - pos) * dim / dim' 32 | transparentPixel = case pixelAt img (double2Int $ fst p) (double2Int $ snd p) of PixelRGBA8 _ _ _ a -> a == 0 33 | in esCursorPos `isWithin` area && not transparentPixel 34 | Rectangle area _ -> esCursorPos `isWithin` area 35 | floor = (Map.toList $ unBoard gsFloor) <&> \(pos, t) -> sprite t pos 36 | room = (Map.toList $ unBoard gsRoom) <&> \(pos, t) -> sprite t pos 37 | -- backup of grouping logic as reminder if needed: (groupWith snd $ Map.toList $ unBoard gsFloor) <&> \ne@((_, t) :| _) -> 38 | inventoryUI = 39 | translate (200, 100) 40 | <$> [ sprite RedResource 18, 41 | sprite MainCharacter 3, 42 | sprite Inventory 0 43 | ] 44 | -------------------------------------------------------------------------------- /spaceminer/assets/floor_plate.aseprite: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/spaceminer/assets/floor_plate.aseprite -------------------------------------------------------------------------------- /spaceminer/assets/floor_plate.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/spaceminer/assets/floor_plate.png -------------------------------------------------------------------------------- /spaceminer/assets/inventory.aseprite: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/spaceminer/assets/inventory.aseprite -------------------------------------------------------------------------------- /spaceminer/assets/inventory.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/spaceminer/assets/inventory.png -------------------------------------------------------------------------------- /spaceminer/assets/main_character.aseprite: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/spaceminer/assets/main_character.aseprite -------------------------------------------------------------------------------- /spaceminer/assets/main_character.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/spaceminer/assets/main_character.png -------------------------------------------------------------------------------- /spaceminer/assets/red_resource.aseprite: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/spaceminer/assets/red_resource.aseprite -------------------------------------------------------------------------------- /spaceminer/assets/red_resource.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/spaceminer/assets/red_resource.png -------------------------------------------------------------------------------- /spaceminer/assets/top_wall.aseprite: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/spaceminer/assets/top_wall.aseprite -------------------------------------------------------------------------------- /spaceminer/assets/top_wall.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/spaceminer/assets/top_wall.png -------------------------------------------------------------------------------- /spaceminer/assets/top_wall_locker.aseprite: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cvogt/2020-07-01-haskell-game-demo/f90fcd19ea79802774dcfafe8505415d6f8c8a8b/spaceminer/assets/top_wall_locker.aseprite -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-16.1 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | extra-deps: 45 | - Euterpea-2.0.7 46 | # Euterpea deps 47 | - PortMidi-0.2.0.0 48 | - arrows-0.4.4.2 49 | - Stream-0.4.7.2 50 | - lazysmallcheck-0.6 51 | #----------- 52 | - pathfinding-0.1.0.0 53 | 54 | allow-newer: true 55 | 56 | # Override default flag values for local packages and extra-deps 57 | # flags: {} 58 | 59 | # Extra package databases containing global packages 60 | # extra-package-dbs: [] 61 | 62 | # Control whether we use the GHC we find on the path 63 | # system-ghc: true 64 | # 65 | # Require a specific version of stack, using version ranges 66 | # require-stack-version: -any # Default 67 | # require-stack-version: ">=2.3" 68 | # 69 | # Override the architecture used by stack, especially useful on Windows 70 | # arch: i386 71 | # arch: x86_64 72 | # 73 | # Extra directories used by stack for building 74 | # extra-include-dirs: [/path/to/dir] 75 | # extra-lib-dirs: [/path/to/dir] 76 | # 77 | # Allow a newer minor version of GHC than the snapshot specifies 78 | # compiler-check: newer-minor 79 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import GHC.Err (error) 2 | import My.IO 3 | import My.Prelude 4 | import Playtime.Geometry 5 | 6 | main :: IO () 7 | main = do 8 | -- COLLISION DETECTION TESTS 9 | let area = (12, 1) 10 | assert ("corners: " <> (show $ corners area)) $ 11 | corners area == Corners 1 (1, 13) 13 (13, 1) 12 | 13 | assert "1" $ 14 | 1 `isWithin` area 15 | assert "13" $ 16 | 13 `isWithin` area 17 | assert "1 13" $ 18 | (1, 13) `isWithin` area 19 | assert "13 1" $ 20 | (13, 1) `isWithin` area 21 | assert "14" 22 | $ not 23 | $ 14 `isWithin` area 24 | assert "0" 25 | $ not 26 | $ 0 `isWithin` area 27 | assert "1 14" 28 | $ not 29 | $ (1, 14) `isWithin` area 30 | assert "1 0" 31 | $ not 32 | $ (1, 0) `isWithin` area 33 | assert "0 13" 34 | $ not 35 | $ (0, 13) `isWithin` area 36 | assert "13 12" 37 | $ not 38 | $ (14, 13) `isWithin` area 39 | assert "0 6" 40 | $ not 41 | $ (0, 6) `isWithin` area 42 | assert "6 0" 43 | $ not 44 | $ (6, 0) `isWithin` area 45 | 46 | assert "144 96 within" 47 | $ not 48 | $ (156.1, 107.01540000000021) `isWithin` (12, (144, 96)) 49 | 50 | assert "144 96" 51 | $ not 52 | $ (12, (156.1, 107.01540000000021)) `collidesWith` (12, (144, 96)) 53 | 54 | assert "144 108" 55 | $ not 56 | $ (12, (156.1, 107.01540000000021)) `collidesWith` (12, (144, 108)) 57 | 58 | assert :: [Char] -> Bool -> IO () 59 | assert msg predicate = 60 | if predicate 61 | then putStrLn ("SUCCESS: " <> msg) 62 | else error ("FAILED: " <> msg) 63 | -------------------------------------------------------------------------------- /todo.txt: -------------------------------------------------------------------------------- 1 | SVG support 2 | -- https://svg-clipart.com/svg/symbol/mKBXkcQ-flame-vector.svg 3 | -- https://hackage.haskell.org/package/rasterific-svg-0.3.3.2/docs/Graphics-Rasterific-Svg.html 4 | ---------- 5 | Vector libs to check out 6 | https://hackage.haskell.org/package/fixed-vector-1.2.0.0 7 | https://hackage.haskell.org/package/linear-1.21.1 8 | https://www.stackage.org/haddock/lts-16.6/apecs-physics-0.4.4/index.html 9 | ---------- 10 | Game engines to check out 11 | https://aas.sh/blog/making-a-game-with-haskell-and-apecs/ 12 | -------- 13 | TODO brainstorming: 14 | 15 | 1. milestone: 16 | 17 | coordinate system 18 | - graceful operation when resizing the window / full screen. I.e. scaling the pixel 19 | - modular coordinate system, where something consisting of multiple thing can exist rotated within another (e.g. a spaceship rotated inside of a non rotated grid representing space) 20 | - pathfinding 21 | - collision detection during movement when walking around 22 | - onclick events (also with overlapping assets) 23 | - some sort of menu 24 | 25 | 2. milestone 26 | - take individual images from files containing multiple images 27 | - take animations from image files containing the individual images 28 | - how to handle multi coodinate visual effects 29 | 30 | 31 | 32 | 33 | CREATTIVE IDEAS: 34 | generted music: 35 | - auto-generate music and make user optionally involved in creative process 36 | - craft building blocks affecting music or use minerals 37 | - correlate what happens in the music with what happens in the game, e.g. danger 38 | - have music related rooms, e.g. a mixing or synth room. 39 | - have disco-lighting for the space ship 40 | 41 | usefulness of stuff: 42 | - maybe not fly spaceship directly but put it on course and then have to pass the time until arrival 43 | - pass time until arrival in bed / cryopod / playing with the music / doing other stuff on board. NO MINIGAMES unless super cool. 44 | 45 | main character: 46 | - humantiy has dies, main character is a robot but with personality, has to find out what happened, find blueprints for new chips and modules as game progresses, maybe some related to music or speech synthesis 47 | 48 | spaceship building: 49 | - need air and have a hull integrity system similar to subnautica leading to intersting designs and danger 50 | 51 | planet art style: 52 | - maybe planets are actually 3d spheres of 2d tiles you can look at as you approach and when you get close enough to walk it is so large it's just a plane 53 | 54 | titles: 55 | - musicminer, musebot, museminer, left in space (wakes up as emergency repair bot after incident) --------------------------------------------------------------------------------