├── .devcontainer ├── Dockerfile └── devcontainer.json ├── .ghcid ├── .gitignore ├── README.md ├── Setup.hs ├── app ├── Main.hs └── Reload.hs ├── hie.yaml ├── package.yaml ├── public └── footage.gif ├── resources ├── README.md ├── audio │ ├── scavengers_chop1.aif │ ├── scavengers_chop1.ogg │ ├── scavengers_chop2.aif │ ├── scavengers_chop2.ogg │ ├── scavengers_die.aif │ ├── scavengers_enemy1.aif │ ├── scavengers_enemy2.aif │ ├── scavengers_footstep1.aif │ ├── scavengers_footstep2.aif │ ├── scavengers_fruit1.aif │ ├── scavengers_fruit2.aif │ ├── scavengers_music.aif │ ├── scavengers_music.ogg │ ├── scavengers_soda1.aif │ ├── scavengers_soda1.ogg │ ├── scavengers_soda2.aif │ └── scavengers_soda2.ogg ├── fonts │ ├── OFL.txt │ └── PressStart2P-Regular.ttf └── sprites │ └── Scavengers_SpriteSheet.png ├── src ├── Game.hs ├── Game │ ├── Level.hs │ ├── Resource.hs │ └── System │ │ ├── Draw.hs │ │ ├── Input.hs │ │ ├── Logic.hs │ │ ├── Overlay.hs │ │ └── Setup.hs ├── Play.hs ├── SDL │ └── Draw.hs ├── Types.hs ├── World.hs └── World │ └── Component.hs └── stack.yaml /.devcontainer/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM haskell:8.10.4 2 | 3 | RUN apt-get update 4 | RUN apt-get -y install libicu-dev libtinfo-dev libgmp-dev zlib1g-dev 5 | RUN apt-get -y install libsdl2-dev libsdl2-image-dev libsdl2-mixer-dev libsdl2-ttf-dev 6 | 7 | -------------------------------------------------------------------------------- /.devcontainer/devcontainer.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "Haskell", 3 | "dockerFile": "Dockerfile", 4 | "appPort": 9000, 5 | "postCreateCommand": "stack setup", 6 | "extensions": [ 7 | "haskell.haskell", 8 | "coenraads.bracket-pair-colorizer" 9 | ] 10 | } -------------------------------------------------------------------------------- /.ghcid: -------------------------------------------------------------------------------- 1 | --command "stack ghci game" --test "Reload.update" -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | game.cabal 3 | bondle.zip 4 | bondle 5 | game-exe* 6 | *~ 7 | stack.yaml.lock 8 | *.hie -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Unity Tutorial Project in Haskell with Apecs and SDL2 2 | 3 | This is a project based on the Unity 2D Roguelike tutorial. It doesn't follow the tutorial by the letter, but is very similar. Assets are from [https://learn.unity.com/project/2d-roguelike-tutorial](https://learn.unity.com/project/2d-roguelike-tutorial). It is built upon the ECS [apecs](https://hackage.haskell.org/package/apecs) for game logic and [sdl2](https://www.libsdl.org/download-2.0.php) for window management, images, audio and fonts. 4 | 5 | ![GIF of the game](./public/footage.gif) 6 | 7 | ## Issues during development 8 | 9 | - Some `.aif` files wouldn't work so converted them to `ogg` 10 | - Some documentation about SDL2 bindings that I had a hard time finding, but managed to find what I needed from the respective Github projects of the different bindings. 11 | 12 | ## Inspiration 13 | 14 | [https://hackage.haskell.org/package/apecs](https://hackage.haskell.org/package/apecs) 15 | 16 | - `apecs` is an ECS I always wanted to try out 17 | 18 | [http://jxv.io/blog/2018-02-28-A-Game-in-Haskell.html](http://jxv.io/blog/2018-02-28-A-Game-in-Haskell.html) 19 | 20 | - Non-`apecs` example with `SDL2` 21 | 22 | [https://nmaehlmann.itch.io/mallrl](https://nmaehlmann.itch.io/mallrl) 23 | 24 | - Main inspiration of how to use `apecs` and `SDL2` in a game 25 | 26 | [https://lazyfoo.net/tutorials/SDL/](https://lazyfoo.net/tutorials/SDL/) 27 | 28 | - Tutorials on how to use SDL2 29 | 30 | [https://github.com/haskell-game/sdl2](https://github.com/haskell-game/sdl2) 31 | [https://hackage.haskell.org/package/sdl2-image](https://hackage.haskell.org/package/sdl2-image) 32 | [https://hackage.haskell.org/package/sdl2-mixer](https://hackage.haskell.org/package/sdl2-mixer) 33 | [https://hackage.haskell.org/package/sdl2-ttf](https://hackage.haskell.org/package/sdl2-ttf) 34 | 35 | - Couldn't have done it without the SDL2 bindings 36 | 37 | [https://hackage.haskell.org/package/rapid-0.1.4/docs/Rapid.html](https://hackage.haskell.org/package/rapid-0.1.4/docs/Rapid.html) 38 | [https://github.com/ndmitchell/ghcid](https://github.com/ndmitchell/ghcid) 39 | 40 | - For hot reloading 41 | 42 | ## Building on Linux 43 | 44 | ### 1. Install SDL2 via apt 45 | 46 | `sudo apt install libsdl2-dev libsdl2-ttf-dev libsdl2-image-dev libsdl2-mixer-dev libsdl2-gfx-dev libsdl2-net-dev` 47 | 48 | ### 2. Build and run 49 | 50 | `stack run` 51 | 52 | ## Building on Windows 53 | 54 | ### 1. Install SDL2 via stack & pacman: 55 | 56 | `stack exec -- pacman -Syu` 57 | 58 | `stack exec -- pacman -S mingw-w64-x86_64-pkg-config mingw-w64-x86_64-SDL2` 59 | 60 | ### 2. Build and run 61 | 62 | I couldn't make `stack run` work, so the easiest way to play it is to do either 63 | 64 | - Execute `stack ghci` and run `main` 65 | - Execute `stack build --copy-bins --local-bin-path .` and run the built binary (`game-exe`) 66 | 67 | ## Development 68 | 69 | For development use [rapid](https://hackage.haskell.org/package/rapid-0.1.4/docs/Rapid.html) and [ghcid](https://github.com/ndmitchell/ghcid) for some kind of "hot reloading". `Rapid` allows one to persist state (eg. window, renderer and game state) across `ghci` reloads and `ghcid` a simple way of recompiling changed code and running the `Rapid` entrypoint. 70 | 71 | - Install `ghcid` by executing `stack install ghcid` 72 | - Execute `ghcid` 73 | - Passed flags can be found in `.ghcid` 74 | - Window should appear and update whenever there is a code change 75 | 76 | ## Input 77 | * Main Menu 78 | * ArrowUp, ArrowDown, Enter, Esc (Return to game) 79 | * Game 80 | * ArrowUp, ArrowRight, ArrowDown, ArrowLeft, Esc (Return to menu) 81 | 82 | ## Related projects 83 | 84 | Check out [https://github.com/Simre1/hero](https://github.com/Simre1/hero), it's an ECS like APECS and seems like a really cool project! I hope to make this unity tutorial project for it as well. 85 | 86 | Check out [https://github.com/matthunz/aztecs](https://github.com/matthunz/aztecs), it's _also_ an ECS! 87 | 88 | ## Thanks 89 | 90 | If I forgot something or you think something should be added just open an issue! Free to do whatever with my code, but the assets aren't mine. 91 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Game (initGame, step) 4 | import Play (play) 5 | import Relude 6 | import qualified SDL 7 | 8 | main :: IO () 9 | main = 10 | play 11 | step 12 | "At any cost" 13 | (SDL.V2 640 480) 14 | initGame 15 | -------------------------------------------------------------------------------- /app/Reload.hs: -------------------------------------------------------------------------------- 1 | module Reload where 2 | 3 | import qualified Control.Concurrent.Async as Async 4 | import Data.Text () 5 | import Game (initGame, step) 6 | import Play (play) 7 | import qualified Rapid 8 | import Relude 9 | import qualified SDL 10 | 11 | update :: IO () 12 | update = do 13 | Rapid.rapid 0 $ \r -> do 14 | var <- Rapid.createRef @Text r "step" (newTMVarIO step) 15 | 16 | Rapid.startWith Async.asyncBound r "sdl" $ do 17 | let updateStep = do 18 | join . liftIO . atomically $ readTMVar var 19 | play 20 | updateStep 21 | "Unity Apecs Roguelike Example" 22 | (SDL.V2 640 480) 23 | initGame 24 | 25 | _ <- atomically $ swapTMVar var step 26 | pure () 27 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | stack: 3 | - path: "src" 4 | component: game:lib 5 | 6 | - path: "app" 7 | component: game:exe 8 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | copyright: 2020 Jacob Torrång 2 | maintainer: kopatheonlyone@hotmail.com 3 | 4 | name: game 5 | version: 0.2.0.0 6 | extra-source-files: 7 | - README.md 8 | author: mewhhaha 9 | github: mewhhaha/apecs-unity-tutorial-haskell 10 | license: null 11 | description: Please see the README on GitHub at 12 | 13 | default-extensions: 14 | - NoImplicitPrelude 15 | - StarIsType 16 | - MonomorphismRestriction 17 | - TraditionalRecordSyntax 18 | - EmptyDataDecls 19 | - ForeignFunctionInterface 20 | - PatternGuards 21 | - DoAndIfThenElse 22 | - LambdaCase 23 | - RelaxedPolyRec 24 | - BangPatterns 25 | - BinaryLiterals 26 | - ConstrainedClassMethods 27 | - ConstraintKinds 28 | - DeriveDataTypeable 29 | - DeriveFoldable 30 | - DeriveFunctor 31 | - DeriveGeneric 32 | - DeriveLift 33 | - DeriveTraversable 34 | - EmptyCase 35 | - EmptyDataDeriving 36 | - ExistentialQuantification 37 | - ExplicitForAll 38 | - FlexibleContexts 39 | - FlexibleInstances 40 | - GADTSyntax 41 | - GeneralisedNewtypeDeriving 42 | - HexFloatLiterals 43 | - ImportQualifiedPost 44 | - InstanceSigs 45 | - KindSignatures 46 | - MultiParamTypeClasses 47 | - NamedFieldPuns 48 | - NamedWildCards 49 | - NumericUnderscores 50 | - PolyKinds 51 | - PostfixOperators 52 | - RankNTypes 53 | - ScopedTypeVariables 54 | - StandaloneDeriving 55 | - StandaloneKindSignatures 56 | - TupleSections 57 | - TypeApplications 58 | - OverloadedStrings 59 | - TypeOperators 60 | - TypeSynonymInstances 61 | 62 | dependencies: 63 | - base >= 4.7 && < 5 64 | - relude 65 | - sdl2 66 | - sdl2-image 67 | - sdl2-mixer 68 | - sdl2-ttf 69 | - apecs 70 | - optics-core 71 | - optics-th 72 | - text 73 | - async 74 | - array 75 | - rapid 76 | - mtl 77 | - vector 78 | - filepath 79 | - random 80 | - containers 81 | 82 | ghc-options: 83 | - -Wall 84 | - -fwrite-ide-info 85 | - -fexternal-interpreter 86 | - -fvalidate-ide-info 87 | 88 | library: 89 | source-dirs: src 90 | 91 | executables: 92 | game-exe: 93 | source-dirs: app 94 | main: Main.hs 95 | ghc-options: 96 | - -threaded 97 | - -rtsopts 98 | - -with-rtsopts=-N 99 | - -O2 100 | - +RTS -xn -RTS 101 | dependencies: 102 | - game 103 | -------------------------------------------------------------------------------- /public/footage.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/public/footage.gif -------------------------------------------------------------------------------- /resources/README.md: -------------------------------------------------------------------------------- 1 | Assets from [https://learn.unity.com/project/2d-roguelike-tutorial](https://learn.unity.com/project/2d-roguelike-tutorial). Some audio files have been converted from their original `aif` format to `ogg` because of issues with playing them, they haven't been modified in any other way. 2 | -------------------------------------------------------------------------------- /resources/audio/scavengers_chop1.aif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_chop1.aif -------------------------------------------------------------------------------- /resources/audio/scavengers_chop1.ogg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_chop1.ogg -------------------------------------------------------------------------------- /resources/audio/scavengers_chop2.aif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_chop2.aif -------------------------------------------------------------------------------- /resources/audio/scavengers_chop2.ogg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_chop2.ogg -------------------------------------------------------------------------------- /resources/audio/scavengers_die.aif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_die.aif -------------------------------------------------------------------------------- /resources/audio/scavengers_enemy1.aif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_enemy1.aif -------------------------------------------------------------------------------- /resources/audio/scavengers_enemy2.aif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_enemy2.aif -------------------------------------------------------------------------------- /resources/audio/scavengers_footstep1.aif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_footstep1.aif -------------------------------------------------------------------------------- /resources/audio/scavengers_footstep2.aif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_footstep2.aif -------------------------------------------------------------------------------- /resources/audio/scavengers_fruit1.aif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_fruit1.aif -------------------------------------------------------------------------------- /resources/audio/scavengers_fruit2.aif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_fruit2.aif -------------------------------------------------------------------------------- /resources/audio/scavengers_music.aif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_music.aif -------------------------------------------------------------------------------- /resources/audio/scavengers_music.ogg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_music.ogg -------------------------------------------------------------------------------- /resources/audio/scavengers_soda1.aif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_soda1.aif -------------------------------------------------------------------------------- /resources/audio/scavengers_soda1.ogg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_soda1.ogg -------------------------------------------------------------------------------- /resources/audio/scavengers_soda2.aif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_soda2.aif -------------------------------------------------------------------------------- /resources/audio/scavengers_soda2.ogg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/audio/scavengers_soda2.ogg -------------------------------------------------------------------------------- /resources/fonts/OFL.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, Cody "CodeMan38" Boisclair (cody@zone38.net), with Reserved Font Name "Press Start 2P" 2 | This Font Software is licensed under the SIL Open Font License, Version 1.1. 3 | This license is copied below, and is also available with a FAQ at: 4 | http://scripts.sil.org/OFL 5 | 6 | 7 | ----------------------------------------------------------- 8 | SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007 9 | ----------------------------------------------------------- 10 | 11 | PREAMBLE 12 | The goals of the Open Font License (OFL) are to stimulate worldwide 13 | development of collaborative font projects, to support the font creation 14 | efforts of academic and linguistic communities, and to provide a free and 15 | open framework in which fonts may be shared and improved in partnership 16 | with others. 17 | 18 | The OFL allows the licensed fonts to be used, studied, modified and 19 | redistributed freely as long as they are not sold by themselves. The 20 | fonts, including any derivative works, can be bundled, embedded, 21 | redistributed and/or sold with any software provided that any reserved 22 | names are not used by derivative works. The fonts and derivatives, 23 | however, cannot be released under any other type of license. The 24 | requirement for fonts to remain under this license does not apply 25 | to any document created using the fonts or their derivatives. 26 | 27 | DEFINITIONS 28 | "Font Software" refers to the set of files released by the Copyright 29 | Holder(s) under this license and clearly marked as such. This may 30 | include source files, build scripts and documentation. 31 | 32 | "Reserved Font Name" refers to any names specified as such after the 33 | copyright statement(s). 34 | 35 | "Original Version" refers to the collection of Font Software components as 36 | distributed by the Copyright Holder(s). 37 | 38 | "Modified Version" refers to any derivative made by adding to, deleting, 39 | or substituting -- in part or in whole -- any of the components of the 40 | Original Version, by changing formats or by porting the Font Software to a 41 | new environment. 42 | 43 | "Author" refers to any designer, engineer, programmer, technical 44 | writer or other person who contributed to the Font Software. 45 | 46 | PERMISSION & CONDITIONS 47 | Permission is hereby granted, free of charge, to any person obtaining 48 | a copy of the Font Software, to use, study, copy, merge, embed, modify, 49 | redistribute, and sell modified and unmodified copies of the Font 50 | Software, subject to the following conditions: 51 | 52 | 1) Neither the Font Software nor any of its individual components, 53 | in Original or Modified Versions, may be sold by itself. 54 | 55 | 2) Original or Modified Versions of the Font Software may be bundled, 56 | redistributed and/or sold with any software, provided that each copy 57 | contains the above copyright notice and this license. These can be 58 | included either as stand-alone text files, human-readable headers or 59 | in the appropriate machine-readable metadata fields within text or 60 | binary files as long as those fields can be easily viewed by the user. 61 | 62 | 3) No Modified Version of the Font Software may use the Reserved Font 63 | Name(s) unless explicit written permission is granted by the corresponding 64 | Copyright Holder. This restriction only applies to the primary font name as 65 | presented to the users. 66 | 67 | 4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font 68 | Software shall not be used to promote, endorse or advertise any 69 | Modified Version, except to acknowledge the contribution(s) of the 70 | Copyright Holder(s) and the Author(s) or with their explicit written 71 | permission. 72 | 73 | 5) The Font Software, modified or unmodified, in part or in whole, 74 | must be distributed entirely under this license, and must not be 75 | distributed under any other license. The requirement for fonts to 76 | remain under this license does not apply to any document created 77 | using the Font Software. 78 | 79 | TERMINATION 80 | This license becomes null and void if any of the above conditions are 81 | not met. 82 | 83 | DISCLAIMER 84 | THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 85 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF 86 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT 87 | OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE 88 | COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 89 | INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 90 | DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 91 | FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM 92 | OTHER DEALINGS IN THE FONT SOFTWARE. 93 | -------------------------------------------------------------------------------- /resources/fonts/PressStart2P-Regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/fonts/PressStart2P-Regular.ttf -------------------------------------------------------------------------------- /resources/sprites/Scavengers_SpriteSheet.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mewhhaha/apecs-unity-tutorial-haskell/6f9fd10941636b97ed7aa8598b657059fd11ca4a/resources/sprites/Scavengers_SpriteSheet.png -------------------------------------------------------------------------------- /src/Game.hs: -------------------------------------------------------------------------------- 1 | module Game where 2 | 3 | import Apecs qualified 4 | import Game.System.Draw qualified as Draw 5 | import Game.System.Input qualified as Input 6 | import Game.System.Logic qualified as Logic 7 | import Game.System.Overlay qualified as Overlay 8 | import Game.System.Setup qualified as Setup 9 | import Relude 10 | import SDL qualified 11 | import Types (Step, Tick (..)) 12 | import World (World, initWorld) 13 | 14 | initGame :: IO World 15 | initGame = do 16 | w <- initWorld 17 | Apecs.runWith w (Setup.system >> ask) 18 | 19 | step :: Step IO World 20 | step = do 21 | renderer <- asks readRenderer 22 | world <- asks readWorld 23 | SDL.rendererDrawColor renderer SDL.$= SDL.V4 0 0 0 0 24 | Apecs.runWith world (Input.system >> Logic.system >> Draw.system >> Overlay.system >> ask) 25 | -------------------------------------------------------------------------------- /src/Game/Level.hs: -------------------------------------------------------------------------------- 1 | module Game.Level where 2 | 3 | import Apecs qualified 4 | import Data.Set (elemAt, member) 5 | import Relude hiding (state) 6 | import Relude.Extra (size) 7 | import Relude.Monad.Reexport qualified as State 8 | import SDL qualified 9 | import System.Random (Random (randoms), RandomGen, mkStdGen, newStdGen, randomR, randomRs, setStdGen, split) 10 | import World (System', World) 11 | import World.Component 12 | 13 | edges :: Set Position 14 | edges = fromList $ uncurry SDL.V2 <$> (xs (,0) ++ xs (,14) ++ ys (0,) ++ ys (19,)) 15 | where 16 | xs f = f <$> [0 .. 20] 17 | ys f = f <$> [0 .. 14] 18 | 19 | shuffle :: RandomGen r => r -> [a] -> [a] 20 | shuffle r = fmap snd . sortBy (compare `on` fst) . zip (randoms @Int r) 21 | 22 | pick :: RandomGen r => r -> Int -> State.State [a] [a] 23 | pick r n = do 24 | state <- State.get 25 | let (picked, rest) = splitAt n (shuffle r state) 26 | State.put rest 27 | return picked 28 | 29 | spread :: RandomGen r => Int -> r -> State.State [Position] [Position] 30 | spread origins originalGen = do 31 | positions <- State.get 32 | return (toList . fromList @(Set Position) . concat $ origin positions <$> gs) 33 | where 34 | decreaseChance, initialChance :: Double 35 | decreaseChance = 0.1 36 | initialChance = 0.4 37 | gs = take origins $ iterate (snd . split) originalGen 38 | origin :: RandomGen r => [Position] -> r -> [Position] 39 | origin positions originGen = expand g'' initialChance n' 40 | where 41 | ps = fromList positions 42 | (n', g'') = randPos originGen ps 43 | randPos :: RandomGen r => r -> Set Position -> (Position, r) 44 | randPos g xs = let (n, g') = randomR (0, size xs - 1) g in (elemAt n xs, g') 45 | expand :: RandomGen r => r -> Double -> Position -> [Position] 46 | expand g chance n = n : concat (expand (snd . split $ g) (chance - decreaseChance) <$> neighbours) 47 | where 48 | neighbours = 49 | catMaybes 50 | . zipWith (\c p -> if c < chance then Just p else Nothing) (randomRs (0.0, 1.0) g) 51 | . filter (`member` ps) 52 | $ (n +) <$> [SDL.V2 0 (-1), SDL.V2 0 1, SDL.V2 1 0, SDL.V2 (-1) 0] 53 | 54 | newPlayer :: MonadIO m => Position -> Int -> Apecs.SystemT World m () 55 | newPlayer position life = 56 | Apecs.newEntity 57 | ( CPosition position, 58 | CPlayer, 59 | CAnimation (Animation 0 PlayerIdle 7), 60 | CLife life, 61 | CLerpPosition (LerpPosition 0 position position) 62 | ) 63 | >> pass 64 | 65 | newZombies :: MonadIO m => [Position] -> Apecs.SystemT World m () 66 | newZombies = mapM_ new 67 | where 68 | new position = 69 | Apecs.newEntity 70 | ( CPosition position, 71 | CEnemy Zombie, 72 | CAnimation (Animation 0 ZombieIdle 7), 73 | CLife 1, 74 | CLerpPosition (LerpPosition 0 position position) 75 | ) 76 | 77 | newVampires :: MonadIO m => [Position] -> Apecs.SystemT World m () 78 | newVampires = mapM_ new 79 | where 80 | new position = 81 | Apecs.newEntity 82 | ( CPosition position, 83 | CEnemy Vampire, 84 | CAnimation (Animation 0 VampireIdle 7), 85 | CLife 1, 86 | CLerpPosition (LerpPosition 0 position position) 87 | ) 88 | 89 | newObstacles :: MonadIO m => [Position] -> Apecs.SystemT World m () 90 | newObstacles = mapM_ new 91 | where 92 | new position = Apecs.newEntity (CPosition position, CEnemy Obstacle, CLife 2) 93 | 94 | newSodas :: MonadIO m => [Position] -> Apecs.SystemT World m () 95 | newSodas = mapM_ new 96 | where 97 | new position = Apecs.newEntity (CPosition position, CFood Soda) 98 | 99 | newFruit :: MonadIO m => [Position] -> Apecs.SystemT World m () 100 | newFruit = mapM_ new 101 | where 102 | new position = Apecs.newEntity (CPosition position, CFood Fruit) 103 | 104 | newLevel :: MonadIO m => Int -> Apecs.SystemT World m () 105 | newLevel l = Apecs.set Apecs.global (CLevel (Level l)) 106 | 107 | destroyComponents :: Apecs.Not (CPlayer, CEnemy, CAnimation, CPosition, CFood, CLife, CDead, CLerpPosition) 108 | destroyComponents = Apecs.Not 109 | 110 | cleanLevel :: System' () 111 | cleanLevel = Apecs.cmap $ \(_ :: CPosition) -> destroyComponents 112 | 113 | row :: NonEmpty Int 114 | row = 1 :| [2 .. 18] 115 | 116 | column :: NonEmpty Int 117 | column = 1 :| [2 .. 13] 118 | 119 | start :: SDL.V2 Int 120 | start = SDL.V2 1 (last column) 121 | 122 | goal :: SDL.V2 Int 123 | goal = SDL.V2 (last row) 1 124 | 125 | createLevel :: MonadIO m => Int -> Int -> Apecs.SystemT World m () 126 | createLevel l life = do 127 | liftIO $ setStdGen (mkStdGen l) 128 | g <- liftIO newStdGen 129 | let area = [SDL.V2 x y | x <- toList row, y <- toList column, SDL.V2 x y `notElem` [start, goal]] 130 | [zombies, vampires, sodas, fruit, obstacles] = 131 | flip State.evalState area $ 132 | sequence [pick g 5, pick g 3, pick g 3, pick g 3, spread 10 g] 133 | 134 | newPlayer (SDL.V2 1 13) life 135 | newZombies zombies 136 | newVampires vampires 137 | newSodas sodas 138 | newFruit fruit 139 | newObstacles obstacles 140 | newLevel l 141 | 142 | createLevelOne :: System' () 143 | createLevelOne = createLevel 1 100 -------------------------------------------------------------------------------- /src/Game/Resource.hs: -------------------------------------------------------------------------------- 1 | module Game.Resource where 2 | 3 | import Apecs qualified 4 | import Data.Map.Strict qualified as Map 5 | import Optics.Core (Lens', set, view) 6 | import Relude hiding (init) 7 | import SDL qualified 8 | import SDL.Font qualified as SDLFont 9 | import SDL.Image qualified as SDLImage 10 | import SDL.Mixer qualified as SDLMixer 11 | import System.FilePath (()) 12 | import World (System') 13 | import World.Component (CResources, fonts, sounds, sprites) 14 | 15 | lazyLoad :: Ord a => Lens' CResources (Map a b) -> System' b -> a -> System' b 16 | lazyLoad optic initializeResource key = do 17 | resources <- Apecs.get Apecs.global 18 | let store = view optic resources 19 | case Map.lookup key store of 20 | Nothing -> do 21 | v <- initializeResource 22 | let updatedStore = Map.insert key v store 23 | Apecs.set Apecs.global (set optic updatedStore resources) 24 | pure v 25 | Just v -> pure v 26 | 27 | resourceFont :: FilePath -> Int -> System' SDLFont.Font 28 | resourceFont filepath fontSize = 29 | lazyLoad fonts initializeResource (filepath, fontSize) 30 | where 31 | initializeResource = SDLFont.load ("resources" filepath) fontSize 32 | 33 | resourceSprite :: SDL.Renderer -> FilePath -> System' SDL.Texture 34 | resourceSprite renderer filepath = do 35 | lazyLoad sprites initializeResource filepath 36 | where 37 | initializeResource = SDLImage.loadTexture renderer ("resources" filepath) 38 | 39 | resourceSound :: FilePath -> System' SDLMixer.Chunk 40 | resourceSound filepath = do 41 | lazyLoad sounds initializeResource filepath 42 | where 43 | initializeResource = SDLMixer.load ("resources" filepath) 44 | -------------------------------------------------------------------------------- /src/Game/System/Draw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Game.System.Draw (system) where 4 | 5 | import Apecs qualified 6 | import Game.Level (edges) 7 | import Game.Resource (resourceSound, resourceSprite) 8 | import Optics.Core (over, view) 9 | import Relude 10 | import Relude.Unsafe ((!!)) 11 | import SDL qualified 12 | import SDL.Draw (drawSprite) 13 | import SDL.Mixer qualified as SDLMixer 14 | import System.FilePath (()) 15 | import System.Random (Random (random, randomRIO, randoms), mkStdGen) 16 | import Types (Tick (readDeltaTime, readRenderer)) 17 | import World (System', tickState) 18 | import World.Component 19 | 20 | scavengerSpritesheet :: Integral b => (b, b) -> b -> NonEmpty (SDL.Rectangle b) 21 | scavengerSpritesheet (x, y) frames = go 0 :| (go <$> [1 .. frames - 1]) 22 | where 23 | go i = SDL.Rectangle (SDL.P (SDL.V2 ox oy) * 32) 32 24 | where 25 | ox = (x + i) `mod` 8 26 | oy = y + ((x + i) `div` 8) 27 | 28 | edgeSprites :: NonEmpty (SDL.Rectangle Integer) 29 | edgeSprites = scavengerSpritesheet (1, 3) 4 30 | 31 | obstacleSprites :: NonEmpty (SDL.Rectangle Integer) 32 | obstacleSprites = 33 | scavengerSpritesheet (5, 2) 4 <> scavengerSpritesheet (5, 3) 3 34 | 35 | brokenObstacleSprites :: NonEmpty (SDL.Rectangle Integer) 36 | brokenObstacleSprites = scavengerSpritesheet (0, 6) 7 37 | 38 | groundSprites :: NonEmpty (SDL.Rectangle Integer) 39 | groundSprites = scavengerSpritesheet (0, 4) 8 40 | 41 | playerIdleSprites :: NonEmpty (SDL.Rectangle Integer) 42 | playerIdleSprites = scavengerSpritesheet (0, 0) 6 43 | 44 | playerAttackSprites :: NonEmpty (SDL.Rectangle Integer) 45 | playerAttackSprites = scavengerSpritesheet (0, 5) 2 46 | 47 | playerHurtSprites :: NonEmpty (SDL.Rectangle Integer) 48 | playerHurtSprites = scavengerSpritesheet (5, 5) 2 49 | 50 | zombieIdleSprites :: NonEmpty (SDL.Rectangle Integer) 51 | zombieIdleSprites = scavengerSpritesheet (6, 0) 6 52 | 53 | zombieAttackSprites :: NonEmpty (SDL.Rectangle Integer) 54 | zombieAttackSprites = scavengerSpritesheet (2, 5) 2 55 | 56 | vampireIdleSprites :: NonEmpty (SDL.Rectangle Integer) 57 | vampireIdleSprites = scavengerSpritesheet (4, 1) 6 58 | 59 | vampireAttackSprites :: NonEmpty (SDL.Rectangle Integer) 60 | vampireAttackSprites = scavengerSpritesheet (4, 5) 2 61 | 62 | pickupSprites :: NonEmpty (SDL.Rectangle Integer) 63 | pickupSprites = scavengerSpritesheet (2, 2) 2 64 | 65 | goalSprite :: SDL.Rectangle Integer 66 | goalSprite = head $ scavengerSpritesheet (4, 2) 1 67 | 68 | toRect :: SDL.V2 Int -> SDL.Rectangle Int 69 | toRect position = SDL.Rectangle (SDL.P position * 32) 32 70 | 71 | ground :: Set Position 72 | ground = fromList [SDL.V2 x y | x <- [1 .. 18], y <- [1 .. 13]] 73 | 74 | playerAttackAnimation :: Animation 75 | playerAttackAnimation = Animation 0 PlayerAttack 7 76 | 77 | zombieAttackAnimation :: Animation 78 | zombieAttackAnimation = Animation 0 ZombieAttack 7 79 | 80 | vampireAttackAnimation :: Animation 81 | vampireAttackAnimation = Animation 0 VampireAttack 7 82 | 83 | playerIdleAnimation :: Animation 84 | playerIdleAnimation = Animation 0 PlayerIdle 7 85 | 86 | zombieIdleAnimation :: Animation 87 | zombieIdleAnimation = Animation 0 ZombieIdle 7 88 | 89 | vampireIdleAnimation :: Animation 90 | vampireIdleAnimation = Animation 0 VampireIdle 7 91 | 92 | playerHurtAnimation :: Animation 93 | playerHurtAnimation = Animation 0 PlayerHurt 7 94 | 95 | playRandomChunk :: SDLMixer.Channel -> [SDLMixer.Chunk] -> System' () 96 | playRandomChunk channel chunks = do 97 | randomIndex <- liftIO $ randomRIO (0, length chunks - 1) 98 | let chunk = chunks !! randomIndex 99 | SDLMixer.setVolume 20 chunk 100 | _ <- SDLMixer.playOn channel 1 chunk 101 | pass 102 | 103 | musicChannel :: SDLMixer.Channel 104 | musicChannel = 3 105 | 106 | lerpSpeed :: Double 107 | lerpSpeed = 10 108 | 109 | system :: System' () 110 | system = do 111 | (CScene scene) <- Apecs.get Apecs.global 112 | case scene of 113 | MainMenu _ _ -> pass 114 | GameOver _ -> pass 115 | LevelTitle _ -> pass 116 | Game _ -> do 117 | (CLevel (Level l), CHappenings happenings) <- Apecs.get Apecs.global 118 | let g = mkStdGen l 119 | dt <- tickState readDeltaTime 120 | renderer <- tickState readRenderer 121 | spritesheet <- resourceSprite renderer ("sprites" "Scavengers_SpriteSheet.png") 122 | chunksChop <- mapM (resourceSound . ("audio" )) ["scavengers_chop1.ogg", "scavengers_chop2.ogg"] 123 | chunksFootstep <- mapM (resourceSound . ("audio" )) ["scavengers_footstep1.aif", "scavengers_footstep2.aif"] 124 | chunksFruit <- mapM (resourceSound . ("audio" )) ["scavengers_fruit1.aif", "scavengers_fruit2.aif"] 125 | chunksEnemyDie <- mapM (resourceSound . ("audio" )) ["scavengers_enemy2.aif"] 126 | chunksEnemyAttack <- mapM (resourceSound . ("audio" )) ["scavengers_enemy1.aif"] 127 | chunksSoda <- mapM (resourceSound . ("audio" )) ["scavengers_soda1.ogg", "scavengers_soda2.ogg"] 128 | chunkMusic <- resourceSound ("audio" "scavengers_music.ogg") 129 | 130 | playingMusic <- SDLMixer.playing musicChannel 131 | pausedMusic <- SDLMixer.paused musicChannel 132 | when (not playingMusic || pausedMusic) $ do 133 | SDLMixer.setVolume 10 chunkMusic 134 | _ <- SDLMixer.playOn musicChannel 2 chunkMusic 135 | pass 136 | 137 | Apecs.cmap $ \(CAnimation animation) -> CAnimation (over timer (+ dt * view speed animation) animation) 138 | Apecs.cmap $ \(CLerpPosition lerpPosition@LerpPosition {..}, CPosition position) -> 139 | Just $ 140 | if position /= current 141 | then CLerpPosition $ LerpPosition 0 current position 142 | else CLerpPosition lerpPosition {lerp = min (lerp + dt * lerpSpeed) 1} 143 | 144 | let drawFrame frames n = 145 | let index = n `mod` length frames 146 | in drawSprite renderer spritesheet (Just (toList frames !! index)) . toRect 147 | 148 | zipWithM_ (drawFrame edgeSprites) (randoms g) (toList edges) 149 | zipWithM_ (drawFrame groundSprites) (randoms g) (toList ground) 150 | drawSprite renderer spritesheet (Just goalSprite) (toRect $ SDL.V2 18 1) 151 | 152 | forM_ happenings $ \case 153 | Attack {..} -> do 154 | (player :: Maybe CPlayer, enemy :: Maybe CEnemy, CAnimation unchanged) <- Apecs.get source 155 | 156 | case (player, enemy) of 157 | (Just _, _) -> do 158 | playRandomChunk 0 chunksChop 159 | Apecs.get target >>= \case 160 | (Just (CEnemy e)) | elem e [Zombie, Vampire] -> playRandomChunk 2 chunksEnemyDie 161 | _ -> pass 162 | Apecs.set source $ CAnimation playerAttackAnimation 163 | (_, Just (CEnemy Zombie)) -> do 164 | playRandomChunk 2 chunksEnemyAttack 165 | Apecs.set source $ CAnimation zombieAttackAnimation 166 | Apecs.modify source $ \(CPlayer, CAnimation _) -> CAnimation playerHurtAnimation 167 | (_, Just (CEnemy Vampire)) -> do 168 | playRandomChunk 2 chunksEnemyAttack 169 | Apecs.set source $ CAnimation vampireAttackAnimation 170 | Apecs.modify source $ \(CPlayer, CAnimation _) -> CAnimation playerHurtAnimation 171 | _ -> Apecs.set source $ CAnimation unchanged 172 | Move {..} -> do 173 | playRandomChunk 0 chunksFootstep 174 | Apecs.modify source $ \(CPlayer, CAnimation _) -> CAnimation playerIdleAnimation 175 | Pickup {..} -> do 176 | (CFood food) <- Apecs.get target 177 | case food of 178 | Fruit -> playRandomChunk 1 chunksFruit 179 | Soda -> playRandomChunk 1 chunksSoda 180 | _ -> pass 181 | 182 | Apecs.cmapM_ $ 183 | \(CPosition position, CEnemy enemy, CLife life, Apecs.Entity e) -> 184 | case enemy of 185 | Obstacle -> do 186 | let g' = mkStdGen (e + l) 187 | drawFrame (if life > 1 then obstacleSprites else brokenObstacleSprites) (fst $ random g') position 188 | _ -> pass 189 | 190 | Apecs.cmapM_ $ \(CPosition position, CFood pickup) -> do 191 | case pickup of 192 | Fruit -> drawFrame pickupSprites 0 position 193 | Soda -> drawFrame pickupSprites 1 position 194 | 195 | Apecs.cmapM $ \(CLerpPosition LerpPosition {..}, CAnimation animation, _ :: Apecs.Not CDead) -> do 196 | let animationDone reel = floor (view timer animation) >= length reel 197 | positionDelta = fromIntegral <$> (current - old) 198 | positionOffset = floor <$> positionDelta * 32 * pure lerp 199 | drawAnimation reel = drawSprite renderer spritesheet (Just (toList reel !! t)) (SDL.Rectangle (SDL.P $ old * 32 + positionOffset) 32) 200 | where 201 | t = floor (view timer animation) `mod` length reel 202 | 203 | case view name animation of 204 | PlayerIdle -> do 205 | drawAnimation playerIdleSprites 206 | pure pass 207 | PlayerAttack -> do 208 | drawAnimation playerAttackSprites 209 | pure . when (animationDone playerAttackSprites) $ Left (CAnimation playerIdleAnimation) 210 | PlayerHurt -> do 211 | drawAnimation playerHurtSprites 212 | pure . when (animationDone playerHurtSprites) $ Left (CAnimation playerIdleAnimation) 213 | ZombieIdle -> do 214 | drawAnimation zombieIdleSprites 215 | pure pass 216 | ZombieAttack -> do 217 | drawAnimation zombieAttackSprites 218 | pure . when (animationDone playerAttackSprites) $ Left (CAnimation zombieIdleAnimation) 219 | VampireIdle -> do 220 | drawAnimation vampireIdleSprites 221 | pure pass 222 | VampireAttack -> do 223 | drawAnimation vampireAttackSprites 224 | pure . when (animationDone playerAttackSprites) $ Left (CAnimation vampireIdleAnimation) 225 | 226 | pass 227 | -------------------------------------------------------------------------------- /src/Game/System/Input.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Game.System.Input (system) where 4 | 5 | import Apecs qualified 6 | import Control.Monad.Except (throwError) 7 | import Relude 8 | import Relude.Extra (member) 9 | import SDL qualified 10 | import Types (Command (End), Tick (readEvents)) 11 | import World (System', tickState) 12 | import World.Component 13 | ( CScene (..), 14 | GameInput (..), 15 | GameOverInput (..), 16 | KeyboardInput (..), 17 | KeyboardState (KeyDown, KeyPressed, KeyReleased, KeyUp), 18 | LevelTitleInput (..), 19 | MainMenuInput (..), 20 | Scene (..), 21 | ) 22 | 23 | parseKeyboardInput :: (Set SDL.Scancode, Set SDL.Scancode) -> (SDL.Scancode -> Bool) -> KeyboardInput -> KeyboardInput 24 | parseKeyboardInput (pressedKeys, releasedKeys) isKeyDown (KeyboardInput scancode _) = 25 | let keyPressed = scancode `member` pressedKeys 26 | keyReleased = scancode `member` releasedKeys 27 | keyDown = isKeyDown scancode 28 | in KeyboardInput scancode $ case (keyPressed, keyReleased, keyDown) of 29 | (True, _, _) -> KeyPressed 30 | (_, True, _) -> KeyReleased 31 | (_, _, True) -> KeyDown 32 | _ -> KeyUp 33 | 34 | updateGameInput :: GameInput -> (KeyboardInput -> KeyboardInput) -> GameInput 35 | updateGameInput GameInput {..} update = 36 | GameInput 37 | { moveRight = update moveRight, 38 | moveLeft = update moveLeft, 39 | moveUp = update moveUp, 40 | moveDown = update moveDown, 41 | toMenu = update toMenu, 42 | resetLevel = update resetLevel 43 | } 44 | 45 | updateMainMenuInput :: MainMenuInput -> (KeyboardInput -> KeyboardInput) -> MainMenuInput 46 | updateMainMenuInput MainMenuInput {..} update = 47 | MainMenuInput 48 | { pressUp = update pressUp, 49 | pressDown = update pressDown, 50 | selectOption = update selectOption, 51 | toGame = update toGame 52 | } 53 | 54 | updateLevelTitleInput :: LevelTitleInput -> (KeyboardInput -> KeyboardInput) -> LevelTitleInput 55 | updateLevelTitleInput LevelTitleInput {..} update = 56 | LevelTitleInput 57 | { continue = update continue 58 | } 59 | 60 | updateGameOverInput :: GameOverInput -> (KeyboardInput -> KeyboardInput) -> GameOverInput 61 | updateGameOverInput GameOverInput {..} update = 62 | GameOverInput 63 | { restart = update restart, 64 | exit = update exit 65 | } 66 | 67 | separateMotion :: SDL.KeyboardEventData -> Either SDL.Scancode SDL.Scancode 68 | separateMotion e = if pressed then Left scancode else Right scancode 69 | where 70 | pressed = SDL.keyboardEventKeyMotion e == SDL.Pressed 71 | scancode = SDL.keysymScancode (SDL.keyboardEventKeysym e) 72 | 73 | keyboardEventData :: SDL.EventPayload -> Maybe SDL.KeyboardEventData 74 | keyboardEventData (SDL.KeyboardEvent e) = Just e 75 | keyboardEventData _ = Nothing 76 | 77 | applyBoth :: (t -> b) -> (t, t) -> (b, b) 78 | applyBoth f (a, b) = (f a, f b) 79 | 80 | isQuitEvent :: SDL.Event -> Bool 81 | isQuitEvent (SDL.Event _t SDL.QuitEvent) = True 82 | isQuitEvent _ = False 83 | 84 | system :: System' () 85 | system = do 86 | events <- tickState readEvents 87 | when (any isQuitEvent events) . lift . throwError $ End 88 | 89 | isKeyDown <- SDL.getKeyboardState 90 | let payload = SDL.eventPayload <$> events 91 | keyboardEvents = mapMaybe keyboardEventData payload 92 | keySets = applyBoth (fromList @(Set SDL.Scancode)) . partitionEithers $ separateMotion <$> keyboardEvents 93 | update = parseKeyboardInput keySets isKeyDown 94 | (CScene schema) <- Apecs.get Apecs.global 95 | let updatedSchema = case schema of 96 | Game input -> Game $ updateGameInput input update 97 | GameOver input -> GameOver $ updateGameOverInput input update 98 | MainMenu input menuChoice -> MainMenu (updateMainMenuInput input update) menuChoice 99 | LevelTitle input -> LevelTitle $ updateLevelTitleInput input update 100 | Apecs.set Apecs.global (CScene updatedSchema) 101 | 102 | pass -------------------------------------------------------------------------------- /src/Game/System/Logic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Game.System.Logic (system) where 4 | 5 | import Apecs qualified 6 | import Apecs.Experimental.Reactive (ixLookup, withReactive) 7 | import Control.Monad.Except (throwError) 8 | import Data.List ((!!)) 9 | import Data.Set (member) 10 | import Game.Level (cleanLevel, createLevel, createLevelOne, destroyComponents, edges, goal) 11 | import Relude 12 | import SDL qualified 13 | import System.Random (Random (randomRIO)) 14 | import Types (Command (End)) 15 | import World (System') 16 | import World.Component 17 | 18 | pressed :: KeyboardInput -> Bool 19 | pressed (KeyboardInput _ KeyPressed) = True 20 | pressed _ = False 21 | 22 | entitiesAt :: Position -> System' [Apecs.Entity] 23 | entitiesAt pos = withReactive $ ixLookup (CPosition pos) 24 | 25 | checkPlayerCollision :: Apecs.Entity -> SDL.V2 Int -> Maybe (SDL.V2 Int) -> System' (SDL.V2 Int, [Happening]) 26 | checkPlayerCollision _ from Nothing = pure (from, []) 27 | checkPlayerCollision playerEntity from (Just movement) 28 | | to `member` edges = pure (from, []) 29 | | otherwise = entitiesAt to >>= go 30 | where 31 | to = from + movement 32 | foodLife Fruit = 30 33 | foodLife Soda = 20 34 | 35 | go :: [Apecs.Entity] -> System' (SDL.V2 Int, [Happening]) 36 | go [] = pure (to, [Move playerEntity from to]) 37 | go xs = do 38 | collision <- 39 | fmap (listToMaybe . sortBy (compare `on` fst) . catMaybes) . forM xs $ 40 | Apecs.get 41 | >=> \case 42 | (Just (CEnemy _), _, enemyEntity) -> 43 | pure $ Just (from, [Attack playerEntity 1 enemyEntity]) 44 | (_, Just (CFood food), foodEntity) -> 45 | pure $ 46 | Just 47 | ( to, 48 | [ Move playerEntity from to, 49 | Pickup playerEntity (foodLife food) foodEntity 50 | ] 51 | ) 52 | _ -> pure Nothing 53 | 54 | pure $ fromMaybe (from, []) collision 55 | 56 | checkEnemyCollision :: Apecs.Entity -> SDL.V2 Int -> SDL.V2 Int -> System' (SDL.V2 Int, [Happening]) 57 | checkEnemyCollision enemyEntity from movement 58 | | to `member` edges = pure (from, []) 59 | | otherwise = entitiesAt to >>= go 60 | where 61 | to = from + movement 62 | 63 | go :: [Apecs.Entity] -> System' (SDL.V2 Int, [Happening]) 64 | go [] = pure (to, []) 65 | go xs = do 66 | collision <- 67 | fmap (listToMaybe . catMaybes) . forM xs $ 68 | Apecs.get 69 | >=> \case 70 | (Just CPlayer, playerEntity) -> pure $ Just (from, [Attack enemyEntity 10 playerEntity]) 71 | _ -> pure Nothing 72 | pure $ fromMaybe (from, []) collision 73 | 74 | turn :: (Enum a, Bounded a) => Int -> a -> a 75 | turn n e = toEnum (add (fromEnum (maxBound `asTypeOf` e) + 1) (fromEnum e) n) 76 | where 77 | add m x y = (x + y + m) `rem` m 78 | 79 | changeScene :: Scene -> System' () 80 | changeScene = Apecs.set Apecs.global . CScene 81 | 82 | system :: System' () 83 | system = do 84 | Apecs.cmap $ \CDead -> destroyComponents 85 | Apecs.set Apecs.global (CHappenings []) 86 | 87 | (CScene scene, CLevel (Level l)) <- Apecs.get Apecs.global 88 | case scene of 89 | GameOver GameOverInput {..} -> do 90 | when (pressed restart) $ do 91 | cleanLevel 92 | createLevelOne 93 | changeScene (LevelTitle defaultLevelTitleInput) 94 | when (pressed exit) $ do 95 | cleanLevel 96 | Apecs.set Apecs.global (CLevel (Level 0), CScene (LevelTitle defaultLevelTitleInput)) 97 | MainMenu input@MainMenuInput {..} choice -> do 98 | when (pressed toGame) $ changeScene (Game defaultGameInput) 99 | when (pressed pressUp) $ changeScene (MainMenu input (turn (-1) choice)) 100 | when (pressed pressDown) $ changeScene (MainMenu input (turn 1 choice)) 101 | when (pressed selectOption) $ case choice of 102 | StartGame -> do 103 | if l == 0 104 | then do 105 | cleanLevel 106 | createLevelOne 107 | changeScene (LevelTitle defaultLevelTitleInput) 108 | else do 109 | changeScene (Game defaultGameInput) 110 | ExitGame -> lift . throwError $ End 111 | LevelTitle LevelTitleInput {..} -> do 112 | when (pressed continue) $ do 113 | changeScene (Game defaultGameInput) 114 | Game GameInput {..} -> do 115 | when (pressed toMenu) $ changeScene (MainMenu defaultMainMenuInput StartGame) 116 | 117 | let ifPressed b v = if pressed b then Just v else Nothing 118 | moveInput = 119 | listToMaybe . catMaybes $ 120 | [ ifPressed moveLeft $ SDL.V2 (-1) 0, 121 | ifPressed moveRight $ SDL.V2 1 0, 122 | ifPressed moveUp $ SDL.V2 0 (-1), 123 | ifPressed moveDown $ SDL.V2 0 1 124 | ] 125 | 126 | Apecs.cmapM $ \(CPlayer, CPosition position, e :: Apecs.Entity) -> do 127 | (next, happenings) <- checkPlayerCollision e position moveInput 128 | let nextLevel = [NextLevel | position == goal] 129 | Apecs.modify Apecs.global (<> CHappenings (happenings <> nextLevel)) 130 | pure . Just $ CPosition next 131 | 132 | playerAction <- (\(CHappenings hs) -> not . null $ hs) <$> Apecs.get Apecs.global 133 | 134 | when playerAction . Apecs.cmapM $ \(CEnemy enemy, CPosition position, e :: Apecs.Entity) -> do 135 | case enemy of 136 | Obstacle -> pure $ Left () 137 | _ -> do 138 | let directions = [SDL.V2 (-1) 0, SDL.V2 1 0, SDL.V2 0 (-1), SDL.V2 0 1] 139 | index <- liftIO $ randomRIO (0, length directions - 1) 140 | 141 | (next, happenings) <- checkEnemyCollision e position (directions !! index) 142 | Apecs.modify Apecs.global (<> CHappenings happenings) 143 | pure . Right $ CPosition next 144 | 145 | (CHappenings happenings) <- Apecs.get Apecs.global 146 | 147 | forM_ happenings $ \case 148 | Attack {..} -> do 149 | Apecs.modify source $ \(CPlayer, CLife life) -> CLife (life - 1) 150 | Apecs.modify target $ \(CLife current) -> CLife (current - damage) 151 | Move {..} -> do 152 | Apecs.modify source $ \(CPlayer, CLife life) -> CLife (life - 1) 153 | Pickup {..} -> do 154 | Apecs.modify source $ \(CLife current) -> CLife (current + life) 155 | Apecs.set target CDead 156 | _ -> pass 157 | 158 | Apecs.cmap $ \(CLife current) -> 159 | if current <= 0 160 | then Right CDead 161 | else Left () 162 | 163 | when (pressed resetLevel) $ do 164 | cleanLevel 165 | createLevel l 100 166 | 167 | when (NextLevel `elem` happenings) $ do 168 | Apecs.cmapM_ $ \(CPlayer, CLife life) -> do 169 | cleanLevel 170 | createLevel (l + 1) life 171 | changeScene (LevelTitle defaultLevelTitleInput) 172 | 173 | Apecs.cmapM_ $ \(CPlayer, CDead) -> 174 | changeScene (GameOver defaultGameOverInput) 175 | 176 | pass -------------------------------------------------------------------------------- /src/Game/System/Overlay.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Game.System.Overlay (system) where 4 | 5 | import Apecs qualified 6 | import Foreign.C (CInt) 7 | import Game.Resource (resourceFont) 8 | import Relude 9 | import SDL qualified 10 | import SDL.Font qualified as SDLFont 11 | import System.FilePath (()) 12 | import Types (Tick (readWindow), readRenderer) 13 | import World (System', tickState) 14 | import World.Component 15 | 16 | data Painter 17 | = At {position :: SDL.V2 CInt, content :: Painter} 18 | | Row {columns :: [Painter]} 19 | | Column {rows :: [Painter]} 20 | | Painter {paint :: SDL.V2 CInt -> System' (SDL.V2 CInt)} 21 | 22 | data FontAlign = FontAbove | FontMiddle | FontBelow 23 | 24 | data FontJustify = FontLeft | FontCenter | FontRight 25 | 26 | data TextConfig = TextConfig 27 | { fontFamily :: String, 28 | fontSize :: Int, 29 | fontColor :: SDL.V4 Word8, 30 | fontAlign :: FontAlign, 31 | fontJustify :: FontJustify 32 | } 33 | 34 | defaultText :: TextConfig 35 | defaultText = 36 | TextConfig 37 | { fontFamily = "PressStart2P-Regular.ttf", 38 | fontSize = 16, 39 | fontColor = maxBound, 40 | fontAlign = FontBelow, 41 | fontJustify = FontLeft 42 | } 43 | 44 | text :: TextConfig -> Text -> Painter 45 | text TextConfig {..} t = Painter $ \origin -> do 46 | renderer <- tickState readRenderer 47 | font <- resourceFont ("fonts" fontFamily) fontSize 48 | surface <- SDLFont.blended font fontColor t 49 | texture <- SDL.createTextureFromSurface renderer surface 50 | SDL.freeSurface surface 51 | info <- SDL.queryTexture texture 52 | let size@(SDL.V2 w h) = SDL.V2 (SDL.textureWidth info) (SDL.textureHeight info) 53 | offsetX = case fontJustify of 54 | FontLeft -> 0 55 | FontRight -> (- w) 56 | FontCenter -> (- w `div` 2) 57 | 58 | offsetY = case fontAlign of 59 | FontBelow -> 0 60 | FontAbove -> - h 61 | FontMiddle -> (- h `div` 2) 62 | offset = SDL.V2 offsetX offsetY 63 | SDL.copy renderer texture Nothing (Just (SDL.Rectangle (SDL.P $ fromIntegral <$> (origin + offset)) size)) 64 | SDL.destroyTexture texture 65 | pure size 66 | 67 | runPainter :: Painter -> System' () 68 | runPainter painter = do 69 | _ <- go SDL.zero painter 70 | pass 71 | where 72 | go origin Painter {paint} = paint origin 73 | go _ At {position, content} = go position content 74 | go origin Column {rows} = 75 | let eval rowOrigin [] = pure rowOrigin 76 | eval rowOrigin (row : rs) = do 77 | (SDL.V2 _ h) <- go rowOrigin row 78 | eval (rowOrigin + SDL.V2 0 h) rs 79 | in eval origin rows 80 | go origin Row {columns} = 81 | let eval columnOrigin [] = pure columnOrigin 82 | eval columnOrigin (row : rs) = do 83 | (SDL.V2 w _) <- go columnOrigin row 84 | eval (columnOrigin + SDL.V2 w 0) rs 85 | in eval origin columns 86 | 87 | system :: System' () 88 | system = do 89 | window <- tickState readWindow 90 | (SDL.V2 w h) <- SDL.get (SDL.windowSize window) 91 | 92 | (CScene inputSchema, CLevel (Level l)) <- Apecs.get Apecs.global 93 | 94 | let centeredText = text defaultText {fontJustify = FontCenter, fontAlign = FontMiddle} 95 | let menuText fontColor = text defaultText {fontJustify = FontCenter, fontColor = fontColor} 96 | case inputSchema of 97 | MainMenu MainMenuInput {} choice -> do 98 | let selectColor = SDL.V4 0 255 0 0 99 | let unselectColor = maxBound 100 | let (startColor, exitColor) = case choice of 101 | StartGame -> (selectColor, unselectColor) 102 | ExitGame -> (unselectColor, selectColor) 103 | let startText = if l == 0 then "Start game" else "Continue game" 104 | runPainter $ 105 | At 106 | (SDL.V2 (w `div` 2) (h `div` 2)) 107 | ( Column 108 | [ menuText startColor startText, 109 | menuText exitColor "Exit game" 110 | ] 111 | ) 112 | GameOver GameOverInput {} -> do 113 | runPainter $ At (SDL.V2 (w `div` 2) (h `div` 2)) (Column [centeredText ("You died at level " <> show l), centeredText "Press [Enter] to restart"]) 114 | LevelTitle LevelTitleInput {} -> do 115 | runPainter $ At (SDL.V2 (w `div` 2) (h `div` 2)) (Column [centeredText ("Level " <> show l), centeredText "Press [Enter] to start"]) 116 | Game GameInput {} -> do 117 | Apecs.cmapM_ $ \(CPlayer, CLife life) -> 118 | runPainter $ At (SDL.V2 (w `div` 2) h) (Row [text defaultText {fontJustify = FontCenter, fontAlign = FontAbove} ("Food " <> show life)]) 119 | 120 | pass 121 | -------------------------------------------------------------------------------- /src/Game/System/Setup.hs: -------------------------------------------------------------------------------- 1 | module Game.System.Setup (system) where 2 | 3 | import Apecs (SystemT) 4 | import Relude 5 | import World (World) 6 | 7 | system :: SystemT World IO () 8 | system = do 9 | pass -------------------------------------------------------------------------------- /src/Play.hs: -------------------------------------------------------------------------------- 1 | module Play where 2 | 3 | import Foreign.C (CInt) 4 | import Relude 5 | import SDL qualified 6 | import SDL.Font qualified as SDLFont 7 | import SDL.Image qualified as SDLImage 8 | import SDL.Mixer qualified as SDLMixer 9 | import Types (Command (..), Step, Tick (..)) 10 | 11 | rendererConfig :: SDL.RendererConfig 12 | rendererConfig = 13 | SDL.RendererConfig 14 | { SDL.rendererType = SDL.AcceleratedVSyncRenderer, 15 | SDL.rendererTargetTexture = False 16 | } 17 | 18 | windowConfig :: SDL.V2 CInt -> SDL.WindowConfig 19 | windowConfig windowSize = 20 | SDL.defaultWindow 21 | { SDL.windowInitialSize = windowSize, 22 | SDL.windowResizable = True 23 | } 24 | 25 | play :: (MonadIO m) => Step m a -> Text -> SDL.V2 CInt -> m a -> m () 26 | play step title windowSize createInitialState = do 27 | SDLImage.initialize [] 28 | SDLFont.initialize 29 | SDLMixer.initialize [] 30 | SDLMixer.openAudio SDLMixer.defaultAudio 256 31 | window <- SDL.createWindow title $ windowConfig windowSize 32 | SDL.showWindow window 33 | renderer <- SDL.createRenderer window (-1) rendererConfig 34 | SDL.HintRenderScaleQuality SDL.$= SDL.ScaleNearest 35 | 36 | let loop previousTime currentState = do 37 | currentTime <- SDL.time 38 | events <- SDL.pollEvents 39 | let dt = currentTime - previousTime 40 | SDL.rendererDrawColor renderer SDL.$= minBound 41 | SDL.clear renderer 42 | command <- runExceptT . runReaderT step $ Tick dt events currentState window renderer 43 | SDL.present renderer 44 | case command of 45 | Left end -> case end of 46 | Reset -> do 47 | initialState <- createInitialState 48 | loop 0 initialState 49 | End -> pass 50 | Right nextState -> 51 | loop currentTime nextState 52 | 53 | initialState <- createInitialState 54 | loop 0 initialState 55 | 56 | SDL.destroyRenderer renderer 57 | SDL.destroyWindow window 58 | SDLMixer.quit 59 | SDLFont.quit 60 | SDLImage.quit 61 | SDL.quit 62 | -------------------------------------------------------------------------------- /src/SDL/Draw.hs: -------------------------------------------------------------------------------- 1 | module SDL.Draw where 2 | 3 | import Relude 4 | import SDL qualified 5 | 6 | drawSprite :: (MonadIO m, Integral a1, Integral a2) => SDL.Renderer -> SDL.Texture -> Maybe (SDL.Rectangle a1) -> SDL.Rectangle a2 -> m () 7 | drawSprite r t mask pos = SDL.copy r t (fmap fromIntegral <$> mask) (Just $ fromIntegral <$> pos) -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | module Types where 2 | 3 | import Relude 4 | import SDL qualified 5 | 6 | data Tick a = Tick {readDeltaTime :: Double, readEvents :: [SDL.Event], readWorld :: a, readWindow :: SDL.Window, readRenderer :: SDL.Renderer} 7 | 8 | data Command = End | Reset 9 | 10 | type Step m a = ReaderT (Tick a) (ExceptT Command m) a -------------------------------------------------------------------------------- /src/World.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module World where 4 | 5 | import Apecs 6 | import Relude 7 | import Types (Command, Tick) 8 | import World.Component 9 | 10 | makeWorld "World" [''CResources, ''CLevel, ''CScene, ''CPosition, ''CPlayer, ''CEnemy, ''CFood, ''CHappenings, ''CAnimation, ''CLife, ''CDead, ''CLerpPosition] 11 | 12 | type System' a = (SystemT World (ReaderT (Tick World) (ExceptT Command IO))) a 13 | 14 | instance MonadFail (SystemT World (ReaderT (Tick World) (ExceptT Command IO))) where 15 | fail s = lift (fail s) 16 | 17 | tickState :: (Tick World -> a) -> System' a 18 | tickState f = lift $ asks f -------------------------------------------------------------------------------- /src/World/Component.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | module World.Component where 7 | 8 | import Apecs qualified hiding (Set) 9 | import Apecs.Experimental.Reactive (IxMap, Reactive) 10 | import Data.Array (Ix) 11 | import Optics.TH (makeLenses) 12 | import Relude 13 | import Relude.Container qualified as Container 14 | import SDL qualified 15 | import SDL.Font qualified as SDLFont 16 | import SDL.Mixer qualified as SDLMixer 17 | 18 | -- Game components 19 | 20 | type Position = SDL.V2 Int 21 | 22 | newtype CPosition = CPosition Position 23 | deriving (Show, Eq, Ord) 24 | deriving (Ix) via Position 25 | 26 | instance Bounded CPosition where 27 | minBound = CPosition (SDL.V2 0 0) 28 | maxBound = CPosition (SDL.V2 100 100) 29 | 30 | instance Apecs.Component CPosition where type Storage CPosition = Reactive (IxMap CPosition) (Apecs.Map CPosition) 31 | 32 | data CPlayer = CPlayer 33 | 34 | instance Apecs.Component CPlayer where type Storage CPlayer = Apecs.Unique CPlayer 35 | 36 | data Enemy = Zombie | Vampire | Obstacle 37 | deriving (Eq) 38 | 39 | newtype CEnemy = CEnemy Enemy 40 | 41 | instance Apecs.Component CEnemy where type Storage CEnemy = Apecs.Map CEnemy 42 | 43 | data Food = Fruit | Soda 44 | 45 | newtype CFood = CFood Food 46 | 47 | instance Apecs.Component CFood where type Storage CFood = Apecs.Map CFood 48 | 49 | newtype CLife = CLife Int 50 | 51 | instance Apecs.Component CLife where type Storage CLife = Apecs.Map CLife 52 | 53 | data CDead = CDead 54 | 55 | instance Apecs.Component CDead where type Storage CDead = Apecs.Map CDead 56 | 57 | -- Animation components 58 | 59 | data AnimationName 60 | = PlayerIdle 61 | | PlayerHurt 62 | | PlayerAttack 63 | | ZombieIdle 64 | | ZombieAttack 65 | | VampireIdle 66 | | VampireAttack 67 | 68 | data Animation = Animation 69 | { _timer :: Double, 70 | _name :: AnimationName, 71 | _speed :: Double 72 | } 73 | 74 | makeLenses ''Animation 75 | 76 | newtype CAnimation = CAnimation Animation 77 | 78 | instance Apecs.Component CAnimation where type Storage CAnimation = Apecs.Map CAnimation 79 | 80 | -- Resource components 81 | 82 | data CResources = CResources 83 | { _fonts :: Container.Map (FilePath, Int) SDLFont.Font, 84 | _sprites :: Container.Map FilePath SDL.Texture, 85 | _sounds :: Container.Map FilePath SDLMixer.Chunk 86 | } 87 | 88 | makeLenses ''CResources 89 | 90 | instance Apecs.Component CResources where type Storage CResources = Apecs.Global CResources 91 | 92 | instance Semigroup CResources where _ <> c2 = c2 93 | 94 | instance Monoid CResources where 95 | mempty = 96 | CResources 97 | { _fonts = mempty, 98 | _sprites = mempty, 99 | _sounds = mempty 100 | } 101 | 102 | -- Keyboard event components 103 | 104 | data KeyboardState = KeyPressed | KeyDown | KeyReleased | KeyUp 105 | 106 | data KeyboardInput = KeyboardInput SDL.Scancode KeyboardState 107 | 108 | data GameInput = GameInput 109 | { moveLeft :: KeyboardInput, 110 | moveRight :: KeyboardInput, 111 | moveUp :: KeyboardInput, 112 | moveDown :: KeyboardInput, 113 | resetLevel :: KeyboardInput, 114 | toMenu :: KeyboardInput 115 | } 116 | 117 | data MainMenuInput = MainMenuInput 118 | { pressUp :: KeyboardInput, 119 | pressDown :: KeyboardInput, 120 | selectOption :: KeyboardInput, 121 | toGame :: KeyboardInput 122 | } 123 | 124 | newtype LevelTitleInput = LevelTitleInput 125 | {continue :: KeyboardInput} 126 | 127 | data GameOverInput = GameOverInput 128 | {restart :: KeyboardInput, exit :: KeyboardInput} 129 | 130 | defaultMainMenuInput :: MainMenuInput 131 | defaultMainMenuInput = 132 | MainMenuInput 133 | { pressUp = KeyboardInput SDL.ScancodeUp KeyUp, 134 | pressDown = KeyboardInput SDL.ScancodeDown KeyUp, 135 | selectOption = KeyboardInput SDL.ScancodeReturn KeyUp, 136 | toGame = KeyboardInput SDL.ScancodeEscape KeyUp 137 | } 138 | 139 | defaultGameInput :: GameInput 140 | defaultGameInput = 141 | GameInput 142 | { moveLeft = KeyboardInput SDL.ScancodeLeft KeyUp, 143 | moveRight = KeyboardInput SDL.ScancodeRight KeyUp, 144 | moveUp = KeyboardInput SDL.ScancodeUp KeyUp, 145 | moveDown = KeyboardInput SDL.ScancodeDown KeyUp, 146 | resetLevel = KeyboardInput SDL.ScancodeR KeyUp, 147 | toMenu = KeyboardInput SDL.ScancodeEscape KeyUp 148 | } 149 | 150 | defaultLevelTitleInput :: LevelTitleInput 151 | defaultLevelTitleInput = 152 | LevelTitleInput 153 | { continue = KeyboardInput SDL.ScancodeReturn KeyUp 154 | } 155 | 156 | defaultGameOverInput :: GameOverInput 157 | defaultGameOverInput = 158 | GameOverInput 159 | { restart = KeyboardInput SDL.ScancodeReturn KeyUp, 160 | exit = KeyboardInput SDL.ScancodeEscape KeyUp 161 | } 162 | 163 | -- Scene components 164 | 165 | data MenuChoice = ExitGame | StartGame 166 | deriving (Enum, Bounded) 167 | 168 | data Scene = MainMenu MainMenuInput MenuChoice | LevelTitle LevelTitleInput | Game GameInput | GameOver GameOverInput 169 | 170 | newtype CScene = CScene Scene 171 | 172 | instance Apecs.Component CScene where type Storage CScene = Apecs.Global CScene 173 | 174 | instance Semigroup CScene where _ <> c2 = c2 175 | 176 | instance Monoid CScene where 177 | mempty = CScene $ MainMenu defaultMainMenuInput StartGame 178 | 179 | -- Level components 180 | 181 | newtype Level = Level Int 182 | 183 | newtype CLevel = CLevel Level 184 | 185 | instance Apecs.Component CLevel where type Storage CLevel = Apecs.Global CLevel 186 | 187 | instance Semigroup CLevel where _ <> c2 = c2 188 | 189 | instance Monoid CLevel where 190 | mempty = CLevel $ Level 0 191 | 192 | -- Event components 193 | 194 | data Happening 195 | = NextLevel 196 | | Move {source :: Apecs.Entity, from :: SDL.V2 Int, to :: SDL.V2 Int} 197 | | Attack {source :: Apecs.Entity, damage :: Int, target :: Apecs.Entity} 198 | | Pickup {source :: Apecs.Entity, life :: Int, target :: Apecs.Entity} 199 | deriving (Ord, Eq) 200 | 201 | type Happenings = [Happening] 202 | 203 | newtype CHappenings = CHappenings Happenings 204 | 205 | instance Apecs.Component CHappenings where type Storage CHappenings = Apecs.Global CHappenings 206 | 207 | instance Semigroup CHappenings where (CHappenings c1) <> (CHappenings c2) = CHappenings (c1 <> c2) 208 | 209 | instance Monoid CHappenings where 210 | mempty = CHappenings mempty 211 | 212 | -- Draw components 213 | 214 | data LerpPosition = LerpPosition {lerp :: Double, old :: Position, current :: Position} 215 | 216 | newtype CLerpPosition = CLerpPosition LerpPosition 217 | 218 | instance Apecs.Component CLerpPosition where type Storage CLerpPosition = Apecs.Map CLerpPosition -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2021-04-06 2 | 3 | packages: 4 | - . 5 | 6 | extra-deps: 7 | - sdl2-2.3.0.1 8 | - rapid-0.1.4@sha256:570dbbaf2d57d5de8ed239cae8aad3fcef59737e31246ea7e6999d46d41ae3da,1768 9 | - git: https://github.com/haskell-game/sdl2-image.git 10 | commit: 382395c763b473032721c71921b5c9241142178f 11 | allow-newer: true 12 | --------------------------------------------------------------------------------