├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.config ├── data ├── log-1425999530 └── startFile1425999530 ├── fonts └── good-times.ttf ├── game-in-haskell-book.cabal ├── images ├── alien.bmp ├── background-1.bmp ├── background-1.png ├── background-large.bmp ├── background-tile.bmp ├── bolt-down.bmp ├── bolt-left.bmp ├── bolt-right.bmp ├── bolt-up.bmp ├── dead-monster.bmp ├── game-over.bmp ├── knight-back-1-crossbow-back.bmp ├── knight-back-1-crossbow-front.bmp ├── knight-back-1-crossbow-left.bmp ├── knight-back-1-crossbow-right.bmp ├── knight-back-1.bmp ├── knight-back-3-crossbow-back.bmp ├── knight-back-3-crossbow-front.bmp ├── knight-back-3-crossbow-left.bmp ├── knight-back-3-crossbow-right.bmp ├── knight-back-3.bmp ├── knight-back-crossbow-back.bmp ├── knight-back-crossbow-front.bmp ├── knight-back-crossbow-left.bmp ├── knight-back-crossbow-right.bmp ├── knight-back.bmp ├── knight-front-1-crossbow-back.bmp ├── knight-front-1-crossbow-front.bmp ├── knight-front-1-crossbow-left.bmp ├── knight-front-1-crossbow-right.bmp ├── knight-front-1.bmp ├── knight-front-3-crossbow-back.bmp ├── knight-front-3-crossbow-front.bmp ├── knight-front-3-crossbow-left.bmp ├── knight-front-3-crossbow-right.bmp ├── knight-front-3.bmp ├── knight-front-crossbow-back.bmp ├── knight-front-crossbow-front.bmp ├── knight-front-crossbow-left.bmp ├── knight-front-crossbow-right.bmp ├── knight-front.bmp ├── knight-left-1-crossbow-back.bmp ├── knight-left-1-crossbow-front.bmp ├── knight-left-1-crossbow-left.bmp ├── knight-left-1-crossbow-right.bmp ├── knight-left-1.bmp ├── knight-left-3-crossbow-back.bmp ├── knight-left-3-crossbow-front.bmp ├── knight-left-3-crossbow-left.bmp ├── knight-left-3-crossbow-right.bmp ├── knight-left-3.bmp ├── knight-left-crossbow-back.bmp ├── knight-left-crossbow-front.bmp ├── knight-left-crossbow-left.bmp ├── knight-left-crossbow-right.bmp ├── knight-left.bmp ├── knight-right-1-crossbow-back.bmp ├── knight-right-1-crossbow-front.bmp ├── knight-right-1-crossbow-left.bmp ├── knight-right-1-crossbow-right.bmp ├── knight-right-1.bmp ├── knight-right-3-crossbow-back.bmp ├── knight-right-3-crossbow-front.bmp ├── knight-right-3-crossbow-left.bmp ├── knight-right-3-crossbow-right.bmp ├── knight-right-3.bmp ├── knight-right-crossbow-back.bmp ├── knight-right-crossbow-front.bmp ├── knight-right-crossbow-left.bmp ├── knight-right-crossbow-right.bmp ├── knight-right.bmp ├── monster-hunting-left.bmp ├── monster-hunting-right.bmp ├── monster-hunting.bmp ├── monster-walking-back.bmp ├── monster-walking-front.bmp ├── monster-walking-left.bmp ├── monster-walking-right.bmp ├── monster-walking.bmp └── recording.bmp ├── sounds ├── bite.wav ├── groan.wav ├── oboe-loop.wav ├── shriek.wav ├── thump.wav └── twang.wav ├── src ├── Animated.hs ├── Hunted │ ├── Backend.hs │ ├── Game.hs │ ├── GameTypes.hs │ ├── Graphics.hs │ ├── Main.hs │ └── Sound.hs ├── Music.hs ├── Shapes.hs ├── State.hs ├── StateFRP.hs └── Testing │ ├── Backend.hs │ ├── CommandLine.hs │ ├── Game.hs │ ├── GameTypes.hs │ ├── Graphics.hs │ ├── Internals │ ├── CommandParser.hs │ └── Game.hs │ ├── Main.hs │ └── Sound.hs └── test ├── HUnit.hs ├── Properties.hs └── hlint.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox 2 | dist 3 | cabal.sandbox.config 4 | 5 | # Vim swapfiles 6 | *.sw? 7 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2014-2015 Elise Huard 2 | 3 | The person who associated a work with this deed has dedicated the work 4 | to the public domain by waiving all of his or her rights to the work 5 | worldwide under copyright law, including all related and neighboring 6 | rights, to the extent allowed by law. 7 | 8 | You can copy, modify, distribute and perform the work, even for 9 | commercial purposes, all without asking permission. 10 | 11 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 12 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 13 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 14 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 15 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 16 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 17 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Game Programming Haskell 2 | 3 | code with [https://leanpub.com/gameinhaskell](https://leanpub.com/gameinhaskell) 4 | 5 | ## Contributors 6 | 7 | * Elise Huard 8 | * Tran Quoc-Anh (upgrade 2018) 9 | 10 | ## Usage 11 | 12 | I recommend using a sandbox. clone the repo, and then 13 | 14 | cabal sandbox init 15 | cabal install --only-dependencies 16 | cabal build 17 | 18 | ## Chapter 1 19 | 20 | Showing how to set up a window and draw basic shapes: 21 | 22 | cabal run shapes-demo 23 | 24 | ## Chapter 2 25 | 26 | State in a more traditional way: 27 | 28 | cabal run state-demo 29 | 30 | State with FRP: 31 | 32 | cabal run frp-demo 33 | 34 | ## Chapter 3 35 | 36 | Using textures and animations, and viewport: 37 | 38 | cabal run animated 39 | 40 | ## Chapter 4 41 | 42 | Let's add some music and sounds: 43 | 44 | cabal run music 45 | 46 | ## Chapter 5 47 | 48 | Shooting (ASDW keys), levels, can increase windowsize, etc 49 | 50 | cabal run extended 51 | 52 | ## Chapter 6 53 | 54 | Game with testing enabled 55 | 56 | cabal run testing 57 | 58 | run tests 59 | 60 | cabal test 61 | 62 | Other options from 63 | 64 | cabal run testing -- --help 65 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /data/log-1425999530: -------------------------------------------------------------------------------- 1 | [[false,false,false,false],[false,false,false,false]] 2 | [[false,false,false,false],[false,false,false,false]] 3 | [[false,false,false,false],[false,false,false,false]] 4 | [[false,false,false,false],[false,false,false,false]] 5 | [[false,false,false,false],[false,false,false,false]] 6 | [[false,false,false,false],[false,false,false,false]] 7 | [[false,false,false,false],[false,false,false,false]] 8 | [[false,false,false,false],[false,false,false,false]] 9 | [[false,false,false,false],[false,false,false,false]] 10 | [[false,false,false,false],[false,false,false,false]] 11 | [[false,false,false,false],[false,false,false,false]] 12 | [[false,false,false,false],[false,false,false,false]] 13 | [[false,false,false,false],[false,false,false,false]] 14 | [[false,false,false,false],[false,false,false,false]] 15 | [[false,false,false,false],[false,false,false,false]] 16 | [[false,false,false,false],[false,false,false,false]] 17 | [[false,false,true,false],[false,false,false,false]] 18 | [[false,false,true,false],[false,false,false,false]] 19 | [[false,false,true,false],[false,false,false,false]] 20 | [[false,false,true,false],[false,false,false,false]] 21 | [[false,false,true,false],[false,false,false,false]] 22 | [[false,false,true,false],[false,false,false,false]] 23 | [[false,false,true,false],[false,false,false,false]] 24 | [[false,false,true,false],[false,false,false,false]] 25 | [[false,false,true,false],[false,false,false,false]] 26 | [[false,false,true,false],[false,false,false,false]] 27 | [[false,false,false,false],[false,false,false,false]] 28 | [[false,false,false,false],[false,false,false,false]] 29 | [[false,true,false,false],[false,false,false,false]] 30 | [[false,true,false,false],[false,false,false,false]] 31 | [[false,true,false,false],[false,false,false,false]] 32 | [[false,true,false,false],[false,false,false,false]] 33 | [[false,true,false,false],[false,false,false,false]] 34 | [[false,true,false,false],[false,false,false,false]] 35 | [[false,true,false,false],[false,false,false,false]] 36 | [[false,true,false,false],[false,false,false,false]] 37 | [[false,true,false,false],[false,false,false,false]] 38 | [[false,true,false,false],[false,false,false,false]] 39 | [[false,true,false,false],[false,false,false,false]] 40 | [[false,true,false,false],[false,false,false,false]] 41 | [[false,true,false,true],[false,false,false,false]] 42 | [[false,false,false,true],[false,false,false,false]] 43 | [[false,false,false,true],[false,false,false,false]] 44 | [[false,false,false,true],[false,false,false,false]] 45 | [[false,false,false,true],[false,false,false,false]] 46 | [[false,false,false,true],[false,false,false,false]] 47 | [[false,false,false,true],[false,false,false,false]] 48 | [[false,false,false,true],[false,false,false,false]] 49 | [[false,false,false,true],[false,false,false,false]] 50 | [[false,false,false,true],[false,false,false,false]] 51 | [[false,false,false,true],[false,false,false,false]] 52 | [[false,false,false,true],[false,false,false,false]] 53 | [[false,false,false,true],[false,false,false,false]] 54 | [[false,true,false,true],[false,false,false,false]] 55 | [[false,true,false,false],[false,false,false,false]] 56 | [[false,true,false,false],[false,false,false,false]] 57 | [[false,true,false,false],[false,false,false,false]] 58 | [[false,true,false,false],[false,false,false,false]] 59 | [[false,true,false,false],[false,false,false,false]] 60 | [[false,true,false,false],[false,false,false,false]] 61 | [[false,true,false,false],[false,false,false,false]] 62 | [[false,true,false,false],[false,false,false,false]] 63 | [[false,true,false,false],[false,false,false,false]] 64 | [[false,true,false,false],[false,false,false,false]] 65 | [[false,true,false,false],[false,false,false,false]] 66 | [[false,true,false,false],[false,false,false,false]] 67 | [[false,true,false,false],[false,false,false,false]] 68 | [[false,true,false,false],[false,false,false,false]] 69 | [[false,true,false,false],[false,false,false,false]] 70 | [[false,true,true,false],[false,false,false,false]] 71 | [[false,true,true,false],[false,false,false,false]] 72 | [[false,false,true,false],[false,false,false,false]] 73 | [[false,false,true,false],[false,false,false,false]] 74 | [[false,false,true,false],[false,false,false,false]] 75 | [[false,false,true,false],[false,false,false,false]] 76 | [[false,false,true,false],[false,false,false,false]] 77 | [[false,false,true,false],[false,false,false,false]] 78 | [[false,false,true,false],[false,false,false,false]] 79 | [[false,true,false,false],[false,false,false,false]] 80 | [[false,true,false,false],[false,false,false,false]] 81 | [[false,true,false,false],[false,false,false,false]] 82 | [[false,true,false,false],[false,false,false,false]] 83 | [[false,true,false,false],[false,false,false,false]] 84 | [[false,true,false,false],[false,false,false,false]] 85 | [[false,true,false,false],[false,false,false,false]] 86 | [[false,true,false,false],[false,false,false,false]] 87 | [[false,true,false,false],[false,false,false,false]] 88 | [[false,true,false,false],[false,false,false,false]] 89 | [[false,true,false,false],[false,false,false,false]] 90 | [[false,true,false,false],[false,false,false,false]] 91 | [[false,true,false,true],[false,false,false,false]] 92 | [[false,true,false,true],[false,false,false,false]] 93 | [[false,true,false,true],[false,false,false,false]] 94 | [[false,false,false,true],[false,false,false,false]] 95 | [[false,false,false,true],[false,false,false,false]] 96 | [[false,false,false,true],[false,false,false,false]] 97 | [[false,false,false,true],[false,false,false,false]] 98 | [[false,false,false,true],[false,false,false,false]] 99 | [[false,false,false,true],[false,false,false,false]] 100 | [[false,false,false,true],[false,false,false,false]] 101 | [[false,false,false,true],[false,false,false,false]] 102 | [[false,false,false,true],[false,false,false,false]] 103 | [[false,false,false,true],[false,false,false,false]] 104 | [[false,false,false,true],[false,false,false,false]] 105 | [[false,false,false,true],[false,false,false,false]] 106 | [[false,false,false,true],[false,false,false,false]] 107 | [[false,false,false,true],[false,false,false,false]] 108 | [[false,false,false,true],[false,false,false,false]] 109 | [[false,false,false,true],[false,false,false,false]] 110 | [[false,false,false,true],[false,false,false,false]] 111 | [[false,false,false,true],[false,false,false,false]] 112 | [[false,false,false,true],[false,false,false,false]] 113 | [[false,false,false,true],[false,false,false,false]] 114 | [[false,false,false,true],[false,false,false,false]] 115 | [[false,false,false,true],[false,false,false,false]] 116 | [[false,false,false,true],[false,false,false,false]] 117 | [[false,false,false,true],[false,false,false,false]] 118 | [[false,false,false,true],[false,false,false,false]] 119 | [[false,false,false,true],[false,false,false,false]] 120 | [[false,false,false,true],[false,false,false,false]] 121 | [[false,false,false,true],[false,false,false,false]] 122 | [[false,false,false,true],[false,false,false,false]] 123 | [[false,false,false,true],[false,false,false,false]] 124 | [[false,false,false,true],[false,false,false,false]] 125 | [[false,false,false,true],[false,false,false,false]] 126 | [[false,false,false,true],[false,false,false,false]] 127 | [[false,false,false,true],[false,false,false,false]] 128 | [[false,false,false,true],[false,false,false,false]] 129 | [[false,false,false,true],[false,false,false,false]] 130 | [[false,false,false,true],[false,false,false,false]] 131 | [[false,false,false,true],[false,false,false,false]] 132 | [[true,false,false,false],[false,false,false,false]] 133 | [[true,false,false,false],[false,false,false,false]] 134 | [[true,false,false,false],[false,false,false,false]] 135 | [[true,false,false,false],[false,false,false,false]] 136 | [[true,false,false,false],[false,false,false,false]] 137 | [[true,false,false,false],[false,false,false,false]] 138 | [[true,false,false,false],[false,false,false,false]] 139 | [[true,false,false,false],[false,false,false,false]] 140 | [[true,false,false,false],[false,false,false,false]] 141 | [[true,false,false,false],[false,false,false,false]] 142 | [[true,false,false,false],[false,false,false,false]] 143 | [[true,false,false,false],[false,false,false,false]] 144 | [[true,false,false,false],[false,false,false,false]] 145 | [[true,false,false,false],[false,false,false,false]] 146 | [[true,false,false,false],[false,false,false,false]] 147 | [[true,false,false,false],[false,false,false,false]] 148 | [[true,false,false,false],[false,false,false,false]] 149 | [[true,false,false,false],[false,false,false,false]] 150 | [[true,false,false,false],[false,false,false,false]] 151 | [[true,false,true,false],[false,false,false,false]] 152 | [[true,false,true,false],[false,false,false,false]] 153 | [[false,false,true,false],[false,false,false,false]] 154 | [[false,false,true,false],[false,false,false,false]] 155 | [[false,false,true,false],[false,false,false,false]] 156 | [[false,false,true,false],[false,false,false,false]] 157 | [[false,false,true,false],[false,false,false,false]] 158 | [[false,false,true,false],[false,false,false,false]] 159 | [[false,false,true,false],[false,false,false,false]] 160 | [[false,false,true,false],[false,false,false,false]] 161 | [[false,false,true,false],[false,false,false,false]] 162 | [[false,false,true,false],[false,false,false,false]] 163 | [[false,false,true,false],[false,false,false,false]] 164 | [[false,false,true,false],[false,false,false,false]] 165 | [[false,false,true,false],[false,false,false,false]] 166 | [[false,false,true,false],[false,false,false,false]] 167 | [[false,false,true,false],[false,false,false,false]] 168 | [[false,false,false,false],[false,false,false,false]] 169 | [[true,false,false,false],[false,false,false,false]] 170 | [[true,false,false,false],[false,false,false,false]] 171 | [[true,false,false,false],[false,false,false,false]] 172 | [[true,false,false,false],[false,false,false,false]] 173 | [[true,false,false,false],[false,false,false,false]] 174 | [[true,false,false,false],[false,false,false,false]] 175 | [[true,false,false,false],[false,false,false,false]] 176 | [[true,false,false,false],[false,false,false,false]] 177 | [[true,false,false,false],[false,false,false,false]] 178 | [[true,false,false,false],[false,false,false,false]] 179 | [[true,false,false,false],[false,false,false,false]] 180 | [[true,false,false,false],[false,false,false,false]] 181 | [[true,false,false,false],[false,false,false,false]] 182 | [[true,false,false,false],[false,false,false,false]] 183 | [[true,false,false,false],[false,false,false,false]] 184 | [[true,false,false,false],[false,false,false,false]] 185 | [[true,false,false,false],[false,false,false,false]] 186 | [[true,false,false,false],[false,false,false,false]] 187 | [[true,false,false,false],[false,false,false,false]] 188 | [[true,false,false,false],[false,false,false,false]] 189 | [[false,false,false,false],[false,false,false,false]] 190 | [[false,false,false,true],[false,false,false,false]] 191 | [[false,false,false,true],[false,false,false,false]] 192 | [[false,false,false,true],[false,false,false,false]] 193 | [[false,false,false,true],[false,false,false,false]] 194 | [[false,false,false,true],[false,false,false,false]] 195 | [[false,false,false,true],[false,false,false,false]] 196 | [[false,false,false,true],[false,false,false,false]] 197 | [[false,false,false,true],[false,false,false,false]] 198 | [[false,false,false,true],[false,false,false,false]] 199 | [[false,false,false,true],[false,false,false,false]] 200 | [[false,false,false,true],[false,false,false,false]] 201 | [[false,false,false,true],[false,false,false,false]] 202 | [[false,false,false,true],[false,false,false,false]] 203 | [[false,false,false,true],[false,false,false,false]] 204 | [[false,false,false,true],[false,false,false,false]] 205 | [[false,false,false,true],[false,false,false,false]] 206 | [[false,false,false,true],[false,false,false,false]] 207 | [[false,false,false,true],[false,false,false,false]] 208 | [[false,false,false,true],[false,false,false,false]] 209 | [[false,false,false,true],[false,false,false,false]] 210 | [[false,false,false,true],[false,false,false,false]] 211 | [[false,false,false,true],[false,false,false,false]] 212 | [[false,false,false,false],[false,false,false,false]] 213 | [[false,false,false,false],[false,false,false,false]] 214 | [[false,false,false,false],[false,false,false,false]] 215 | [[false,false,false,false],[false,false,false,false]] 216 | [[false,false,false,false],[false,false,false,false]] 217 | [[false,false,false,false],[false,false,false,false]] 218 | [[false,false,false,false],[false,false,false,false]] 219 | [[false,false,false,false],[false,false,false,false]] 220 | [[false,false,false,false],[false,false,false,false]] 221 | [[false,false,false,false],[false,false,false,false]] 222 | -------------------------------------------------------------------------------- /data/startFile1425999530: -------------------------------------------------------------------------------- 1 | {"viewportTranslateSignal":[-500,-680],"monsterPos":[[-503,-243]],"animationSignal":null,"levelCountSignal":1,"gameStatusSignal":"InGame","playerSignal":{"shootDirection":null,"movement":null,"position":[500,680]},"livesSignal":3,"scoreSignal":0} -------------------------------------------------------------------------------- /fonts/good-times.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/fonts/good-times.ttf -------------------------------------------------------------------------------- /game-in-haskell-book.cabal: -------------------------------------------------------------------------------- 1 | -- Initial game-in-haskell-book.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: game-in-haskell-book 5 | version: 0.1.1.0 6 | -- synopsis: 7 | description: version working with packages available in 2018 - qat@melix.net 8 | homepage: https://leanpub.com/gameinhaskell 9 | license: MIT 10 | license-file: LICENSE 11 | author: Elise Huard 12 | maintainer: elise@jabberwocky.eu + qat@melix.net 13 | -- copyright: 14 | -- category: 15 | build-type: Simple 16 | -- extra-source-files: 17 | cabal-version: >=2.0 18 | 19 | executable shapes-demo 20 | main-is: Shapes.hs 21 | -- other-modules: 22 | -- other-extensions: 23 | ghc-options: -Wall 24 | build-depends: base >= 4.8 && <=5 25 | , GLFW-b >= 1.4.7.2 26 | , text >= 1.2.1.1 27 | , bytestring 28 | , gloss >= 1.9.3.1 29 | , gloss-rendering >= 1.9.3.1 30 | hs-source-dirs: src 31 | default-language: Haskell2010 32 | 33 | executable state-demo 34 | main-is: State.hs 35 | -- other-modules: 36 | -- other-extensions: 37 | ghc-options: -Wall 38 | build-depends: base >=4.8 && <=5 39 | , GLFW-b >= 1.4.7.2 40 | , gloss >= 1.9.3.1 41 | , gloss-rendering >= 1.9.3.1 42 | , mtl 43 | hs-source-dirs: src 44 | default-language: Haskell2010 45 | 46 | executable frp-demo 47 | main-is: StateFRP.hs 48 | -- other-modules: 49 | -- other-extensions: 50 | ghc-options: -Wall 51 | build-depends: base >=4.8 && <=5 52 | , GLFW-b >= 1.4.7.2 53 | , gloss >= 1.9.3.1 54 | , gloss-rendering >= 1.9.3.1 55 | , elerea >= 2.8.0 56 | , random >= 1.1 57 | hs-source-dirs: src 58 | default-language: Haskell2010 59 | 60 | executable animated 61 | main-is: Animated.hs 62 | -- other-modules: 63 | -- other-extensions: 64 | ghc-options: -Wall 65 | build-depends: base >=4.8 && <=5 66 | , GLFW-b >= 1.4.7.2 67 | , gloss >= 1.9.3.1 68 | , gloss-rendering >= 1.9.3.1 69 | , elerea >= 2.8.0 70 | , random >= 1.1 71 | hs-source-dirs: src 72 | default-language: Haskell2010 73 | 74 | executable music 75 | main-is: Music.hs 76 | -- other-modules: 77 | -- other-extensions: 78 | ghc-options: -Wall -threaded 79 | build-depends: base >=4.8 && <=5 80 | , GLFW-b >= 1.4.7.2 81 | , gloss >= 1.9.3.1 82 | , gloss-rendering >= 1.9.3.1 83 | , elerea >= 2.8.0 84 | , random >= 1.1 85 | , ALUT >= 2.4.0.0 86 | hs-source-dirs: src 87 | default-language: Haskell2010 88 | 89 | executable extended 90 | main-is: Hunted/Main.hs 91 | other-modules: Hunted.GameTypes 92 | , Hunted.Game 93 | , Hunted.Sound 94 | , Hunted.Graphics 95 | , Hunted.Backend 96 | ghc-options: -Wall 97 | build-depends: base >=4.8 && <=5 98 | , GLFW-b >= 1.4.7.2 99 | , gloss >= 1.9.3.1 100 | , gloss-rendering >= 1.9.3.1 101 | , elerea >= 2.8.0 102 | , random >= 1.1 103 | , ALUT >= 2.4.0.0 104 | , containers 105 | , transformers 106 | hs-source-dirs: src 107 | default-language: Haskell2010 108 | 109 | library 110 | exposed-modules: Testing.GameTypes 111 | , Testing.Internals.Game 112 | , Testing.Game 113 | , Testing.Sound 114 | , Testing.Graphics 115 | , Testing.Backend 116 | , Testing.CommandLine 117 | , Testing.Internals.CommandParser 118 | -- other-extensions: 119 | ghc-options: -Wall 120 | build-depends: base >=4.8 && <=5 121 | , GLFW-b >= 1.4.7.2 122 | , gloss >= 1.9.3.1 123 | , gloss-rendering >= 1.9.3.1 124 | , elerea >= 2.8.0 125 | , random >= 1.1 126 | , ALUT >= 2.4.0.0 127 | , containers 128 | , bytestring 129 | , aeson >= 0.8.0.2 130 | , time 131 | , haskeline >= 0.7.2.1 132 | , transformers 133 | , attoparsec >= 0.12.1.6 134 | , text 135 | hs-source-dirs: src 136 | default-language: Haskell2010 137 | 138 | executable testing 139 | main-is: Testing/Main.hs 140 | other-modules: Testing.GameTypes 141 | , Testing.Internals.Game 142 | , Testing.Game 143 | , Testing.Sound 144 | , Testing.Graphics 145 | , Testing.Backend 146 | , Testing.CommandLine 147 | , Testing.Internals.CommandParser 148 | 149 | build-depends: base >=4.8 && <=5 150 | , elerea >= 2.8.0 151 | , game-in-haskell-book 152 | , GLFW-b >= 1.4.7.2 153 | , gloss >= 1.9.3.1 154 | , gloss-rendering >= 1.9.3.1 155 | , elerea >= 2.8.0 156 | , random >= 1.1 157 | , ALUT >= 2.4.0.0 158 | , containers 159 | , options >= 1.2.1.1 160 | , aeson >= 0.8.0.2 161 | , bytestring 162 | , time 163 | , haskeline >= 0.7.2.1 164 | , transformers 165 | , attoparsec >= 0.12.1.6 166 | , text 167 | ghc-options: -Wall 168 | hs-source-dirs: src 169 | default-language: Haskell2010 170 | 171 | test-suite hunit 172 | type: exitcode-stdio-1.0 173 | main-is: HUnit.hs 174 | hs-source-dirs: test 175 | build-depends: base >=4.8 && <=5 176 | , HUnit >= 1.2 177 | , test-framework >= 0.6 178 | , test-framework-hunit >= 0.2 179 | , test-framework-th >= 0.2 180 | , game-in-haskell-book 181 | default-language: Haskell2010 182 | 183 | test-suite properties 184 | type: exitcode-stdio-1.0 185 | main-is: Properties.hs 186 | hs-source-dirs: test 187 | other-modules: 188 | 189 | build-depends: base >=4.8 && <=5 190 | , QuickCheck >= 2.4 191 | , test-framework >= 0.6 192 | , test-framework-quickcheck2 >= 0.2 193 | , test-framework-th >= 0.2 194 | , game-in-haskell-book 195 | default-language: Haskell2010 196 | -------------------------------------------------------------------------------- /images/alien.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/alien.bmp -------------------------------------------------------------------------------- /images/background-1.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/background-1.bmp -------------------------------------------------------------------------------- /images/background-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/background-1.png -------------------------------------------------------------------------------- /images/background-large.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/background-large.bmp -------------------------------------------------------------------------------- /images/background-tile.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/background-tile.bmp -------------------------------------------------------------------------------- /images/bolt-down.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/bolt-down.bmp -------------------------------------------------------------------------------- /images/bolt-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/bolt-left.bmp -------------------------------------------------------------------------------- /images/bolt-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/bolt-right.bmp -------------------------------------------------------------------------------- /images/bolt-up.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/bolt-up.bmp -------------------------------------------------------------------------------- /images/dead-monster.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/dead-monster.bmp -------------------------------------------------------------------------------- /images/game-over.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/game-over.bmp -------------------------------------------------------------------------------- /images/knight-back-1-crossbow-back.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-back-1-crossbow-back.bmp -------------------------------------------------------------------------------- /images/knight-back-1-crossbow-front.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-back-1-crossbow-front.bmp -------------------------------------------------------------------------------- /images/knight-back-1-crossbow-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-back-1-crossbow-left.bmp -------------------------------------------------------------------------------- /images/knight-back-1-crossbow-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-back-1-crossbow-right.bmp -------------------------------------------------------------------------------- /images/knight-back-1.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-back-1.bmp -------------------------------------------------------------------------------- /images/knight-back-3-crossbow-back.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-back-3-crossbow-back.bmp -------------------------------------------------------------------------------- /images/knight-back-3-crossbow-front.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-back-3-crossbow-front.bmp -------------------------------------------------------------------------------- /images/knight-back-3-crossbow-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-back-3-crossbow-left.bmp -------------------------------------------------------------------------------- /images/knight-back-3-crossbow-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-back-3-crossbow-right.bmp -------------------------------------------------------------------------------- /images/knight-back-3.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-back-3.bmp -------------------------------------------------------------------------------- /images/knight-back-crossbow-back.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-back-crossbow-back.bmp -------------------------------------------------------------------------------- /images/knight-back-crossbow-front.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-back-crossbow-front.bmp -------------------------------------------------------------------------------- /images/knight-back-crossbow-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-back-crossbow-left.bmp -------------------------------------------------------------------------------- /images/knight-back-crossbow-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-back-crossbow-right.bmp -------------------------------------------------------------------------------- /images/knight-back.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-back.bmp -------------------------------------------------------------------------------- /images/knight-front-1-crossbow-back.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-front-1-crossbow-back.bmp -------------------------------------------------------------------------------- /images/knight-front-1-crossbow-front.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-front-1-crossbow-front.bmp -------------------------------------------------------------------------------- /images/knight-front-1-crossbow-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-front-1-crossbow-left.bmp -------------------------------------------------------------------------------- /images/knight-front-1-crossbow-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-front-1-crossbow-right.bmp -------------------------------------------------------------------------------- /images/knight-front-1.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-front-1.bmp -------------------------------------------------------------------------------- /images/knight-front-3-crossbow-back.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-front-3-crossbow-back.bmp -------------------------------------------------------------------------------- /images/knight-front-3-crossbow-front.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-front-3-crossbow-front.bmp -------------------------------------------------------------------------------- /images/knight-front-3-crossbow-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-front-3-crossbow-left.bmp -------------------------------------------------------------------------------- /images/knight-front-3-crossbow-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-front-3-crossbow-right.bmp -------------------------------------------------------------------------------- /images/knight-front-3.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-front-3.bmp -------------------------------------------------------------------------------- /images/knight-front-crossbow-back.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-front-crossbow-back.bmp -------------------------------------------------------------------------------- /images/knight-front-crossbow-front.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-front-crossbow-front.bmp -------------------------------------------------------------------------------- /images/knight-front-crossbow-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-front-crossbow-left.bmp -------------------------------------------------------------------------------- /images/knight-front-crossbow-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-front-crossbow-right.bmp -------------------------------------------------------------------------------- /images/knight-front.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-front.bmp -------------------------------------------------------------------------------- /images/knight-left-1-crossbow-back.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-left-1-crossbow-back.bmp -------------------------------------------------------------------------------- /images/knight-left-1-crossbow-front.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-left-1-crossbow-front.bmp -------------------------------------------------------------------------------- /images/knight-left-1-crossbow-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-left-1-crossbow-left.bmp -------------------------------------------------------------------------------- /images/knight-left-1-crossbow-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-left-1-crossbow-right.bmp -------------------------------------------------------------------------------- /images/knight-left-1.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-left-1.bmp -------------------------------------------------------------------------------- /images/knight-left-3-crossbow-back.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-left-3-crossbow-back.bmp -------------------------------------------------------------------------------- /images/knight-left-3-crossbow-front.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-left-3-crossbow-front.bmp -------------------------------------------------------------------------------- /images/knight-left-3-crossbow-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-left-3-crossbow-left.bmp -------------------------------------------------------------------------------- /images/knight-left-3-crossbow-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-left-3-crossbow-right.bmp -------------------------------------------------------------------------------- /images/knight-left-3.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-left-3.bmp -------------------------------------------------------------------------------- /images/knight-left-crossbow-back.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-left-crossbow-back.bmp -------------------------------------------------------------------------------- /images/knight-left-crossbow-front.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-left-crossbow-front.bmp -------------------------------------------------------------------------------- /images/knight-left-crossbow-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-left-crossbow-left.bmp -------------------------------------------------------------------------------- /images/knight-left-crossbow-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-left-crossbow-right.bmp -------------------------------------------------------------------------------- /images/knight-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-left.bmp -------------------------------------------------------------------------------- /images/knight-right-1-crossbow-back.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-right-1-crossbow-back.bmp -------------------------------------------------------------------------------- /images/knight-right-1-crossbow-front.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-right-1-crossbow-front.bmp -------------------------------------------------------------------------------- /images/knight-right-1-crossbow-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-right-1-crossbow-left.bmp -------------------------------------------------------------------------------- /images/knight-right-1-crossbow-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-right-1-crossbow-right.bmp -------------------------------------------------------------------------------- /images/knight-right-1.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-right-1.bmp -------------------------------------------------------------------------------- /images/knight-right-3-crossbow-back.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-right-3-crossbow-back.bmp -------------------------------------------------------------------------------- /images/knight-right-3-crossbow-front.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-right-3-crossbow-front.bmp -------------------------------------------------------------------------------- /images/knight-right-3-crossbow-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-right-3-crossbow-left.bmp -------------------------------------------------------------------------------- /images/knight-right-3-crossbow-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-right-3-crossbow-right.bmp -------------------------------------------------------------------------------- /images/knight-right-3.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-right-3.bmp -------------------------------------------------------------------------------- /images/knight-right-crossbow-back.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-right-crossbow-back.bmp -------------------------------------------------------------------------------- /images/knight-right-crossbow-front.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-right-crossbow-front.bmp -------------------------------------------------------------------------------- /images/knight-right-crossbow-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-right-crossbow-left.bmp -------------------------------------------------------------------------------- /images/knight-right-crossbow-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-right-crossbow-right.bmp -------------------------------------------------------------------------------- /images/knight-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/knight-right.bmp -------------------------------------------------------------------------------- /images/monster-hunting-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/monster-hunting-left.bmp -------------------------------------------------------------------------------- /images/monster-hunting-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/monster-hunting-right.bmp -------------------------------------------------------------------------------- /images/monster-hunting.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/monster-hunting.bmp -------------------------------------------------------------------------------- /images/monster-walking-back.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/monster-walking-back.bmp -------------------------------------------------------------------------------- /images/monster-walking-front.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/monster-walking-front.bmp -------------------------------------------------------------------------------- /images/monster-walking-left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/monster-walking-left.bmp -------------------------------------------------------------------------------- /images/monster-walking-right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/monster-walking-right.bmp -------------------------------------------------------------------------------- /images/monster-walking.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/monster-walking.bmp -------------------------------------------------------------------------------- /images/recording.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/images/recording.bmp -------------------------------------------------------------------------------- /sounds/bite.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/sounds/bite.wav -------------------------------------------------------------------------------- /sounds/groan.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/sounds/groan.wav -------------------------------------------------------------------------------- /sounds/oboe-loop.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/sounds/oboe-loop.wav -------------------------------------------------------------------------------- /sounds/shriek.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/sounds/shriek.wav -------------------------------------------------------------------------------- /sounds/thump.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/sounds/thump.wav -------------------------------------------------------------------------------- /sounds/twang.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/elisehuard/game-in-haskell/b755c42d63ff5dc9246b46590fb23ebcc1d455b1/sounds/twang.wav -------------------------------------------------------------------------------- /src/Animated.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports, RecursiveDo, ExtendedDefaultRules #-} 2 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 3 | import "GLFW-b" Graphics.UI.GLFW as GLFW 4 | import Graphics.Gloss 5 | import Graphics.Gloss.Rendering 6 | import Graphics.Gloss.Data.ViewPort 7 | import System.Exit ( exitSuccess ) 8 | import Control.Concurrent (threadDelay) 9 | import Control.Monad (when, unless, join) 10 | import Control.Monad.Fix (fix) 11 | import Control.Applicative ((<*>), (<$>)) 12 | import FRP.Elerea.Simple 13 | import System.Random 14 | 15 | type Pos = Point 16 | data Player = Player { position :: Pos, movement :: Maybe PlayerMovement } 17 | deriving Show 18 | data PlayerMovement = PlayerMovement { dir :: Direction, step :: WalkStage } 19 | deriving Show 20 | data Monster = Monster Pos MonsterStatus 21 | deriving Show 22 | 23 | data MonsterStatus = Wander Direction Int 24 | | Hunting HuntingDirection 25 | deriving Show 26 | data Direction = WalkUp | WalkDown | WalkLeft | WalkRight 27 | deriving (Show, Enum, Bounded) 28 | 29 | data HuntingDirection = HuntingRight | HuntingLeft 30 | deriving Show 31 | 32 | instance Random Direction where 33 | randomR (a, b) g = case randomR (fromEnum a, fromEnum b) g of 34 | (x, g') -> (toEnum x, g') 35 | random g = randomR (minBound, maxBound) g 36 | 37 | data TextureSet = TextureSet { front :: Picture, back :: Picture, left :: Picture, right :: Picture } 38 | | PlayerTextureSet { fronts :: WalkingTexture, backs :: WalkingTexture, lefts :: WalkingTexture, rights :: WalkingTexture } 39 | 40 | data WalkingTexture = WalkingTexture { neutral :: Picture, walkLeft :: Picture, walkRight :: Picture } 41 | 42 | data WalkStage = One | Two | Three | Four 43 | deriving (Show, Eq, Enum, Bounded) 44 | 45 | data Textures = Textures { texturesBackground :: Picture 46 | , texturesPlayer :: TextureSet 47 | , texturesMonsterWalking :: TextureSet 48 | , texturesMonsterHunting :: TextureSet } 49 | 50 | initialPlayer :: Player 51 | initialPlayer = Player (0, 0) Nothing 52 | 53 | initialMonster :: Monster 54 | initialMonster = Monster (200, 200) (Wander WalkUp wanderDist) 55 | 56 | initialViewport :: ViewPort 57 | initialViewport = ViewPort { viewPortTranslate = (0, 0), viewPortRotate = 0, viewPortScale = viewportScale } 58 | 59 | viewportScale :: Float 60 | viewportScale = 4 61 | 62 | width :: Int 63 | width = 640 64 | 65 | height :: Int 66 | height = 480 67 | 68 | worldWidth :: Float 69 | worldWidth = 2560 70 | 71 | worldHeight :: Float 72 | worldHeight = 1920 73 | 74 | playerSize, monsterSize, monsterSpeed :: Float 75 | playerSize = 20 76 | monsterSize = 20 77 | monsterSpeed = 5 78 | 79 | main :: IO () 80 | main = do 81 | (directionKeyGen, directionKeySink) <- external (False, False, False, False) 82 | randomGenerator <- newStdGen 83 | glossState <- initState 84 | textures <- loadTextures 85 | withWindow width height "Game-Demo" $ \win -> do 86 | network <- start $ do 87 | directionKey <- directionKeyGen 88 | hunted win directionKey randomGenerator textures glossState 89 | fix $ \loop -> do 90 | readInput win directionKeySink 91 | join network 92 | threadDelay 20000 93 | esc <- keyIsPressed win Key'Escape 94 | unless esc loop 95 | exitSuccess 96 | 97 | loadTextures :: IO Textures 98 | loadTextures = do 99 | playerTextureSet <- PlayerTextureSet <$> loadAnims "images/knight-front.bmp" "images/knight-front-1.bmp" "images/knight-front-3.bmp" 100 | <*> loadAnims "images/knight-back.bmp" "images/knight-back-1.bmp" "images/knight-back-3.bmp" 101 | <*> loadAnims "images/knight-left.bmp" "images/knight-left-1.bmp" "images/knight-left-3.bmp" 102 | <*> loadAnims "images/knight-right.bmp" "images/knight-right-1.bmp" "images/knight-right-3.bmp" 103 | monsterWalkingSet <- TextureSet <$> loadBMP "images/monster-walking-front.bmp" 104 | <*> loadBMP "images/monster-walking-back.bmp" 105 | <*> loadBMP "images/monster-walking-left.bmp" 106 | <*> loadBMP "images/monster-walking-right.bmp" 107 | -- moves diagonally, so only 2 textures needed technically 108 | monsterHuntingSet <- TextureSet <$> loadBMP "images/monster-hunting-left.bmp" 109 | <*> loadBMP "images/monster-hunting-right.bmp" 110 | <*> loadBMP "images/monster-hunting-left.bmp" 111 | <*> loadBMP "images/monster-hunting-right.bmp" 112 | backgroundTexture <- loadBMP "images/background-tile.bmp" 113 | return Textures { texturesBackground = backgroundTexture 114 | , texturesPlayer = playerTextureSet 115 | , texturesMonsterWalking = monsterWalkingSet 116 | , texturesMonsterHunting = monsterHuntingSet } 117 | 118 | loadAnims :: String -> String -> String -> IO WalkingTexture 119 | loadAnims path1 path2 path3 = WalkingTexture <$> loadBMP path1 <*> loadBMP path2 <*> loadBMP path3 120 | 121 | hunted :: RandomGen t => 122 | Window 123 | -> Signal (Bool, Bool, Bool, Bool) 124 | -> t 125 | -> Textures 126 | -> State 127 | -> SignalGen (Signal (IO ())) 128 | hunted win directionKey randomGenerator textures glossState = mdo 129 | player <- transfer2 initialPlayer (movePlayer 10) directionKey gameOver' 130 | randomNumber <- stateful (undefined, randomGenerator) nextRandom 131 | monster <- transfer3 initialMonster wanderOrHunt player randomNumber gameOver' 132 | gameOver <- memo (playerEaten <$> player <*> monster) 133 | gameOver' <- delay False gameOver 134 | viewport <- transfer initialViewport viewPortMove player 135 | return $ renderFrame win glossState textures <$> player <*> monster <*> gameOver <*> viewport 136 | where playerEaten player monster = distance player monster < 10^(2 :: Integer) 137 | nextRandom (_, g) = random g 138 | 139 | viewPortMove :: Player -> ViewPort -> ViewPort 140 | viewPortMove (Player (x,y) _) (ViewPort { viewPortTranslate = _, viewPortRotate = rotation, viewPortScale = scaled }) = 141 | ViewPort { viewPortTranslate = ((-x), (-y)), viewPortRotate = rotation, viewPortScale = scaled } 142 | 143 | readInput :: Window -> ((Bool, Bool, Bool, Bool) -> IO ()) -> IO () 144 | readInput window directionKeySink = do 145 | pollEvents 146 | l <- keyIsPressed window Key'Left 147 | r <- keyIsPressed window Key'Right 148 | u <- keyIsPressed window Key'Up 149 | d <- keyIsPressed window Key'Down 150 | directionKeySink (l, r, u, d) 151 | 152 | movePlayer :: Float -> (Bool, Bool, Bool, Bool) -> Bool -> Player -> Player 153 | movePlayer _ _ True player = player 154 | movePlayer increment direction False player@(Player (xpos, ypos) _) 155 | | outsideOfLimits (position (move direction player increment)) playerSize = player 156 | | otherwise = move direction player increment 157 | 158 | outsideOfLimits :: (Float, Float) -> Float -> Bool 159 | outsideOfLimits (xmon, ymon) size = xmon > worldWidth/2 - size/2 || 160 | xmon < ((-worldWidth)/2 + size/2) || 161 | ymon > worldHeight/2 - size/2 || 162 | ymon < ((-worldHeight)/2 + size/2) 163 | 164 | move :: (Bool, Bool, Bool, Bool) -> Player -> Float -> Player 165 | move (True, _, _, _) (Player (xpos, ypos) (Just (PlayerMovement WalkLeft n))) increment = Player (xpos - increment, ypos) (Just $ PlayerMovement WalkLeft (circular n)) 166 | move (True, _, _, _) (Player (xpos, ypos) _) increment = Player (xpos - increment, ypos) $ Just $ PlayerMovement WalkLeft One 167 | move (_, True, _, _) (Player (xpos, ypos) (Just (PlayerMovement WalkRight n))) increment = Player (xpos + increment, ypos) (Just $ PlayerMovement WalkRight (circular n)) 168 | move (_, True, _, _) (Player (xpos, ypos) _) increment = Player (xpos + increment, ypos) $ Just $ PlayerMovement WalkRight One 169 | move (_, _, True, _) (Player (xpos, ypos) (Just (PlayerMovement WalkUp n))) increment = Player (xpos, (ypos + increment)) (Just $ PlayerMovement WalkUp (circular n)) 170 | move (_, _, True, _) (Player (xpos, ypos) _) increment = Player (xpos, (ypos + increment)) $ Just $ PlayerMovement WalkUp One 171 | move (_, _, _, True) (Player (xpos, ypos) (Just (PlayerMovement WalkDown n))) increment = Player (xpos, (ypos - increment)) (Just $ PlayerMovement WalkDown (circular n)) 172 | move (_, _, _, True) (Player (xpos, ypos) _) increment = Player (xpos, (ypos - increment)) $ Just $ PlayerMovement WalkDown One 173 | 174 | move (False, False, False, False) (Player (xpos, ypos) _) _ = Player (xpos, ypos) Nothing 175 | 176 | circular :: (Eq x, Enum x, Bounded x) => x -> x 177 | circular x = if x == maxBound then minBound else succ x 178 | 179 | wanderDist :: Int 180 | wanderDist = 45 181 | 182 | huntingDist :: Float 183 | huntingDist = 200 184 | 185 | wanderOrHunt :: RandomGen t => Player -> (Direction, t) -> Bool -> Monster -> Monster 186 | wanderOrHunt _ _ True monster = monster 187 | wanderOrHunt player (r, _) False monster = if close player monster 188 | then hunt player monster 189 | else wander r monster 190 | 191 | close :: Player -> Monster -> Bool 192 | close player monster = distance player monster < huntingDist^2 193 | 194 | distance :: Player -> Monster -> Float 195 | distance (Player (xpos, ypos) _) (Monster (xmon, ymon) _) = (xpos - xmon)^2 + (ypos - ymon)^2 196 | 197 | -- if player is upper left quadrant, diagonal left 198 | -- means xpos > xmon and ypos > ymon 199 | hunt :: Player -> Monster -> Monster 200 | hunt (Player (xpos, ypos) _) (Monster (xmon, ymon) _) = Monster ((xmon + (signum (xpos - xmon))*monsterSpeed), (ymon + (signum (ypos - ymon))*monsterSpeed)) (Hunting $ huntingDirection (signum (xpos - xmon)) (signum (ypos - ymon))) 201 | 202 | huntingDirection :: Float -> Float -> HuntingDirection 203 | huntingDirection (-1) (-1) = HuntingLeft 204 | huntingDirection (-1) 1 = HuntingLeft 205 | huntingDirection 1 (-1) = HuntingRight 206 | huntingDirection 1 1 = HuntingRight 207 | huntingDirection (-1) _ = HuntingLeft 208 | huntingDirection _ _ = HuntingRight 209 | 210 | -- turn in random direction 211 | wander :: Direction -> Monster -> Monster 212 | wander r (Monster (xmon, ymon) (Wander _ 0)) = Monster (xmon, ymon) (Wander r wanderDist) 213 | wander r (Monster (xmon, ymon) (Hunting _)) = Monster (xmon, ymon) (Wander r wanderDist) 214 | -- go straight 215 | wander _ (Monster (xmon, ymon) (Wander direction n)) = do 216 | let currentDirection = continueDirection direction (outsideOfLimits (xmon, ymon) monsterSize) 217 | Monster 218 | (stepInCurrentDirection currentDirection (xmon, ymon) monsterSpeed) 219 | (Wander currentDirection (n-1)) 220 | 221 | continueDirection :: Direction -> Bool -> Direction 222 | continueDirection WalkUp True = WalkDown 223 | continueDirection WalkDown True = WalkUp 224 | continueDirection WalkLeft True = WalkRight 225 | continueDirection WalkRight True = WalkLeft 226 | continueDirection direction False = direction 227 | 228 | stepInCurrentDirection :: Direction -> (Float, Float) -> Float -> (Float, Float) 229 | stepInCurrentDirection WalkUp (xpos, ypos) speed = (xpos, ypos + speed) 230 | stepInCurrentDirection WalkDown (xpos, ypos) speed = (xpos, ypos - speed) 231 | stepInCurrentDirection WalkLeft (xpos, ypos) speed = (xpos - speed, ypos) 232 | stepInCurrentDirection WalkRight (xpos, ypos) speed = (xpos + speed, ypos) 233 | 234 | renderFrame :: Window 235 | -> State 236 | -> Textures 237 | -> Player 238 | -> Monster 239 | -> Bool 240 | -> ViewPort 241 | -> IO () 242 | renderFrame window glossState textures (Player _ playerDir) (Monster (xmon, ymon) status) gameOver viewport = do 243 | displayPicture (width, height) black glossState (viewPortScale viewport) $ 244 | Pictures $ gameOngoing gameOver 245 | [ uncurry translate (viewPortTranslate viewport) $ tiledBackground (texturesBackground textures) 246 | , renderPlayer playerDir (texturesPlayer textures) 247 | , uncurry translate (viewPortTranslate viewport) $ renderMonster status xmon ymon (texturesMonsterWalking textures) (texturesMonsterHunting textures) ] 248 | swapBuffers window 249 | 250 | -- tiling: pictures translated to the appropriate locations to fill up the given width and heights 251 | -- I scaled the tile to the greatest common factor of the width and height, but it should work to fit the actual width and height 252 | -- which potentially means translating the tiles back a bit not to go over the edge 253 | tileSize :: Float 254 | tileSize = 160 255 | 256 | tiledBackground :: Picture -> Picture 257 | tiledBackground texture = Pictures $ map (\a -> ((uncurry translate) a) texture) $ translateMatrix worldWidth worldHeight 258 | 259 | -- what we want: 640, 480 260 | -- -320--x--(-160)--x--0--x--160--x--320 261 | -- -240 -80 80 240 262 | -- -240--x--(-80)--x--80--x--240 263 | -- -160 0 160 264 | translateMatrix :: Float -> Float -> [(Float, Float)] 265 | translateMatrix w h = concat $ map (zip xTiles) 266 | $ map (replicate (length xTiles)) yTiles 267 | where xTiles = [lowerbound w, lowerbound w + tileSize..higherbound w] 268 | yTiles = [lowerbound h, lowerbound h + tileSize..higherbound h] 269 | higherbound size = size/2 - tileSize/2 270 | lowerbound size = -(higherbound size) 271 | 272 | renderPlayer :: Maybe PlayerMovement -> TextureSet -> Picture 273 | renderPlayer (Just (PlayerMovement facing One)) textureSet = neutral $ playerDirectionTexture facing textureSet 274 | renderPlayer (Just (PlayerMovement facing Two)) textureSet = walkLeft $ playerDirectionTexture facing textureSet 275 | renderPlayer (Just (PlayerMovement facing Three)) textureSet = neutral $ playerDirectionTexture facing textureSet 276 | renderPlayer (Just (PlayerMovement facing Four)) textureSet = walkRight $ playerDirectionTexture facing textureSet 277 | renderPlayer Nothing textureSet = neutral $ fronts textureSet 278 | 279 | playerDirectionTexture :: Direction -> TextureSet -> WalkingTexture 280 | playerDirectionTexture WalkUp = backs 281 | playerDirectionTexture WalkDown = fronts 282 | playerDirectionTexture WalkLeft = lefts 283 | playerDirectionTexture WalkRight = rights 284 | 285 | renderMonster :: MonsterStatus -> Float -> Float -> TextureSet -> TextureSet -> Picture 286 | renderMonster (Hunting HuntingLeft) xpos ypos _ textureSet = translate xpos ypos $ left textureSet 287 | renderMonster (Hunting HuntingRight) xpos ypos _ textureSet = translate xpos ypos $ right textureSet 288 | renderMonster (Wander WalkUp _) xpos ypos textureSet _ = translate xpos ypos $ back textureSet 289 | renderMonster (Wander WalkDown _) xpos ypos textureSet _ = translate xpos ypos $ front textureSet 290 | renderMonster (Wander WalkLeft n) xpos ypos textureSet _ = translate xpos ypos $ rotate (16* fromIntegral n) $ left textureSet 291 | renderMonster (Wander WalkRight n) xpos ypos textureSet _ = translate xpos ypos $ rotate (16* fromIntegral n) $ right textureSet 292 | 293 | -- adds gameover text if appropriate 294 | gameOngoing :: Bool -> [Picture] -> [Picture] 295 | gameOngoing gameOver pics = if gameOver then pics ++ [Color black $ translate (-100) 0 $ Scale 0.3 0.3 $ Text "Game Over"] 296 | else pics 297 | 298 | withWindow :: Int -> Int -> String -> (GLFW.Window -> IO ()) -> IO () 299 | withWindow windowWidth windowHeight title f = do 300 | GLFW.setErrorCallback $ Just simpleErrorCallback 301 | r <- GLFW.init 302 | when r $ do 303 | m <- GLFW.createWindow windowWidth windowHeight title Nothing Nothing 304 | case m of 305 | (Just win) -> do 306 | GLFW.makeContextCurrent m 307 | f win 308 | GLFW.setErrorCallback $ Just simpleErrorCallback 309 | GLFW.destroyWindow win 310 | Nothing -> return () 311 | GLFW.terminate 312 | where 313 | simpleErrorCallback e s = 314 | putStrLn $ unwords [show e, show s] 315 | 316 | keyIsPressed :: Window -> Key -> IO Bool 317 | keyIsPressed win key = isPress `fmap` GLFW.getKey win key 318 | 319 | isPress :: KeyState -> Bool 320 | isPress KeyState'Pressed = True 321 | isPress KeyState'Repeating = True 322 | isPress _ = False 323 | -------------------------------------------------------------------------------- /src/Hunted/Backend.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | module Hunted.Backend ( 3 | withWindow 4 | , readInput 5 | , exitKeyPressed 6 | , swapBuffers 7 | ) where 8 | 9 | import "GLFW-b" Graphics.UI.GLFW as GLFW 10 | import Control.Monad (when) 11 | import Control.Applicative ((<$>), (<*>)) 12 | 13 | --withWindow :: Int -> Int -> String -> (GLFW.Window -> IO ()) -> IO () 14 | withWindow :: Int 15 | -> Int 16 | -> ((Int, Int) -> IO ()) 17 | -> String 18 | -> (Window -> IO a) 19 | -> IO () 20 | withWindow width height windowSizeSink title f = do 21 | GLFW.setErrorCallback $ Just simpleErrorCallback 22 | r <- GLFW.init 23 | when r $ do 24 | m <- GLFW.createWindow width height title Nothing Nothing 25 | case m of 26 | (Just win) -> do 27 | GLFW.makeContextCurrent m 28 | setWindowSizeCallback win $ Just $ resize windowSizeSink 29 | _ <- f win 30 | GLFW.setErrorCallback $ Just simpleErrorCallback 31 | GLFW.destroyWindow win 32 | Nothing -> return () 33 | GLFW.terminate 34 | where 35 | simpleErrorCallback e s = 36 | putStrLn $ unwords [show e, show s] 37 | 38 | resize :: ((Int, Int) -> IO()) -> Window -> Int -> Int -> IO() 39 | resize windowSizeSink _ w h = windowSizeSink (w, h) 40 | 41 | keyIsPressed :: Window -> Key -> IO Bool 42 | keyIsPressed win key = isPress `fmap` GLFW.getKey win key 43 | 44 | isPress :: KeyState -> Bool 45 | isPress KeyState'Pressed = True 46 | isPress KeyState'Repeating = True 47 | isPress _ = False 48 | 49 | readInput :: Window -> ((Bool, Bool, Bool, Bool) -> IO ()) -> ((Bool, Bool, Bool, Bool) -> IO ()) -> IO () 50 | readInput window directionKeySink shootKeySink = do 51 | pollEvents 52 | l <- keyIsPressed window Key'Left 53 | r <- keyIsPressed window Key'Right 54 | u <- keyIsPressed window Key'Up 55 | d <- keyIsPressed window Key'Down 56 | directionKeySink (l, r, u, d) 57 | shootKeySink =<< (,,,) <$> keyIsPressed window Key'A 58 | <*> keyIsPressed window Key'D 59 | <*> keyIsPressed window Key'W 60 | <*> keyIsPressed window Key'S 61 | 62 | exitKeyPressed :: Window -> IO Bool 63 | exitKeyPressed window = keyIsPressed window Key'Escape 64 | -------------------------------------------------------------------------------- /src/Hunted/Game.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecursiveDo #-} 2 | {-# LANGUAGE PackageImports #-} 3 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 4 | module Hunted.Game ( 5 | hunted 6 | ) where 7 | 8 | import Hunted.GameTypes 9 | import Hunted.Sound 10 | import Hunted.Graphics 11 | import "GLFW-b" Graphics.UI.GLFW as GLFW 12 | import FRP.Elerea.Simple as Elerea 13 | import Control.Applicative ((<$>), (<*>), liftA2, pure) 14 | import Data.Maybe (mapMaybe) 15 | import Data.Foldable (foldl') 16 | import Graphics.Gloss () 17 | import Graphics.Gloss.Rendering 18 | import Graphics.Gloss.Data.ViewPort 19 | import System.Random (random, RandomGen(..), randomRs) 20 | 21 | initialPlayer :: Player 22 | initialPlayer = Player (0, 0) Nothing Nothing 23 | 24 | initialMonster :: (Float, Float) -> Monster 25 | initialMonster pos = Monster pos (Wander WalkUp wanderDist) 4 26 | 27 | initialViewport :: ViewPort 28 | initialViewport = ViewPort { viewPortTranslate = (0, 0), viewPortRotate = 0, viewPortScale = viewportScale } 29 | 30 | worldWidth :: Float 31 | worldWidth = 2560 32 | 33 | worldHeight :: Float 34 | worldHeight = 1920 35 | 36 | viewportScale :: Float 37 | viewportScale = 4 38 | 39 | playerSize :: Float 40 | playerSize = 20 41 | 42 | monsterSize :: Float 43 | monsterSize = 20 44 | 45 | monsterSpeed :: Float 46 | monsterSpeed = 5 47 | 48 | wanderDist :: Int 49 | wanderDist = 45 50 | 51 | huntingDist :: Float 52 | huntingDist = 200 53 | 54 | boltRange :: Range 55 | boltRange = 20 56 | 57 | boltSpeed :: Float 58 | boltSpeed = 20 59 | 60 | 61 | initialLevel :: LevelStatus 62 | initialLevel = Level 1 63 | 64 | initialLives :: Int 65 | initialLives = 3 66 | 67 | {- 68 | -- GlossState needs to be exported 69 | -- Graphics.Gloss.Internals.Rendering.State 70 | -- pull request required 71 | -} 72 | -- expected: 73 | -- uncomment when the decimal point bug in GLFW-b-3.2 is corrected -- 74 | hunted :: RandomGen p => 75 | GLFW.Window 76 | -> Signal (Int, Int) 77 | -> Signal (Bool, Bool, Bool, Bool) 78 | -> Signal (Bool, Bool, Bool, Bool) 79 | -> p 80 | -> Hunted.Graphics.Textures 81 | -> State 82 | -> Sounds 83 | -> SignalGen (Signal (IO ())) 84 | 85 | hunted win windowSize directionKey shootKey randomGenerator textures glossState sounds = mdo 86 | let mkGame = playGame windowSize directionKey shootKey randomGenerator 87 | (gameState, gameTrigger) <- switcher $ mkGame <$> gameStatus' 88 | gameStatus <- transfer Start gameProgress gameTrigger 89 | gameStatus' <- delay Start gameStatus 90 | return $ outputFunction win glossState textures sounds <$> gameState 91 | where gameProgress False s = s 92 | gameProgress True Start = InGame 93 | gameProgress True InGame = Start 94 | 95 | 96 | playGame :: RandomGen t => 97 | Signal (Int, Int) 98 | -> Signal (Bool, Bool, Bool, Bool) 99 | -> Signal (Bool, Bool, Bool, Bool) 100 | -> t 101 | -> GameStatus 102 | -> SignalGen (Signal GameState, Signal Bool) 103 | -- start game when pressing s 104 | playGame windowSize _ shootKey _ Start = mdo 105 | let startGame = sIsPressed <$> shootKey 106 | renderState = StartRenderState <$> windowSize 107 | return (GameState <$> renderState <*> pure StartSoundState, startGame) 108 | where sIsPressed (_,_,_,s) = s 109 | 110 | -- bool should be gameOver 111 | playGame windowSize directionKey shootKey randomGenerator InGame = mdo 112 | (gameState, levelTrigger) <- switcher $ playLevel windowSize directionKey shootKey randomGenerator <$> levelCount' <*> score' <*> lives' 113 | levelCount <- transfer2 initialLevel levelProgression gameState levelTrigger 114 | levelCount' <- delay initialLevel levelCount 115 | lives <- transfer2 initialLives decrementLives gameState levelTrigger 116 | lives' <- delay initialLives lives 117 | score <- memo (stateScore <$> gameState) 118 | score' <- delay 0 score 119 | let gameOver = isGameOver <$> gameState 120 | return (gameState, gameOver) 121 | where isGameOver (GameState (RenderState {renderState_lives = l}) _) = l == 0 122 | isGameOver (GameState (StartRenderState _) _) = False 123 | stateScore (GameState (RenderState {renderState_score = s}) _) = s 124 | stateScore (GameState (StartRenderState _) _) = 0 125 | decrementLives (GameState (RenderState {renderState_ending = Just Lose}) _) True l = l - 1 126 | decrementLives (GameState _ _) _ l = l 127 | 128 | -- level progression if triggered AND the player won 129 | levelProgression :: GameState -> Bool -> LevelStatus -> LevelStatus 130 | levelProgression _ False level = level 131 | levelProgression (GameState (RenderState {renderState_ending = Just Win}) _) True (Level n) = Level (n + 1) 132 | levelProgression (GameState (RenderState {renderState_ending = Just Lose}) _) True level = level 133 | levelProgression (GameState (RenderState {renderState_ending = Nothing}) _) True level = level 134 | levelProgression (GameState (StartRenderState _) _) _ level = level 135 | 136 | switcher :: Signal (SignalGen (Signal GameState, Signal Bool)) -> SignalGen (Signal GameState, Signal Bool) 137 | switcher levelGen = mdo 138 | trigger <- memo (snd =<< gameSignal) 139 | trigger' <- delay True trigger 140 | maybeSignal <- generator (toMaybe <$> trigger' <*> levelGen) 141 | gameSignal <- transfer undefined store maybeSignal 142 | return (fst =<< gameSignal, trigger) 143 | where store (Just x) _ = x 144 | store Nothing x = x 145 | toMaybe bool x = if bool then Just <$> x else pure Nothing 146 | 147 | 148 | playLevel :: RandomGen t => 149 | Signal (Int, Int) 150 | -> Signal (Bool, Bool, Bool, Bool) 151 | -> Signal (Bool, Bool, Bool, Bool) 152 | -> t 153 | -> LevelStatus 154 | -> Float 155 | -> Int 156 | -> SignalGen (Signal GameState, Signal Bool) 157 | playLevel windowSize directionKey shootKey randomGenerator level@(Level n) currentScore lives = mdo 158 | 159 | -- render signals 160 | let worldDimensions = (worldWidth, worldHeight) 161 | randomWidths = take n $ randomRs (round ((-worldWidth)/2 + monsterSize), round ((worldWidth/2) - monsterSize)) randomGenerator :: [Int] 162 | randomHeights = take n $ randomRs (round ((-worldWidth)/2 + monsterSize), round ((worldWidth/2) - monsterSize)) randomGenerator :: [Int] 163 | monsterPositions = zip (map fromIntegral randomWidths) (map fromIntegral randomHeights) 164 | player <- transfer3 initialPlayer (movePlayer 10 worldDimensions) directionKey levelOver' shootKey 165 | randomNumber <- stateful (undefined, randomGenerator) nextRandom 166 | hits <- memo (fmap <$> (monsterHits <$> bolts') <*> monsters') 167 | monsters <- transfer4 (fmap initialMonster monsterPositions) (monsterWanderings worldDimensions) player randomNumber levelOver' hits 168 | monsters' <- delay (map initialMonster monsterPositions) monsters 169 | score <- transfer currentScore accumulateScore hits 170 | levelOver <- memo (levelEnds <$> player <*> monsters) 171 | levelOver' <- delay Nothing levelOver 172 | animation <- transfer Nothing (endAnimation level) levelOver 173 | viewport <- transfer initialViewport viewPortMove player 174 | 175 | shoot <- edgify shootKey 176 | let bolt direction range startPosition = stateful (Bolt startPosition direction range False) moveBolt 177 | mkShot shot currentPlayer = if hasAny shot 178 | then (:[]) <$> bolt (dirFrom shot) boltRange (position currentPlayer) 179 | else return [] 180 | newBolts <- generator (mkShot <$> shoot <*> player) 181 | bolts <- collection newBolts (boltIsAlive worldDimensions <$> monsters) 182 | bolts' <- delay [] bolts 183 | 184 | -- sound signals 185 | statusChange <- transfer3 Nothing safeOrDanger monsters monsters' levelOver 186 | playerScreams <- Elerea.till ((== (Just Lose)) <$> levelOver) 187 | monsterScreams <- Elerea.till ((== (Just Win)) <$> levelOver) 188 | 189 | 190 | let monsterIsHunting = (foldr (||) False) <$> (fmap <$> (stillHunting <$> levelOver) <*> monsters) 191 | renderState = RenderState <$> player 192 | <*> monsters 193 | <*> levelOver 194 | <*> viewport 195 | <*> bolts 196 | <*> pure lives 197 | <*> score 198 | <*> animation 199 | <*> windowSize 200 | soundState = SoundState <$> statusChange 201 | <*> playerScreams 202 | <*> monsterIsHunting 203 | <*> monsterScreams 204 | <*> (hasAny <$> shoot) 205 | <*> (boltHit <$> monsters <*> bolts) 206 | 207 | return (GameState <$> renderState <*> soundState, animationEnd <$> animation) 208 | where playerEaten player monsters 209 | | any (\monster -> distance player monster < (playerSize^2 :: Float)) monsters = Just Lose 210 | | otherwise = Nothing 211 | monstersDead monsters 212 | | all monsterDead monsters = Just Win 213 | | otherwise = Nothing 214 | monsterDead (Monster _ _ health) = health == 0 215 | levelEnds player monsters = maybe (monstersDead monsters) Just (playerEaten player monsters) 216 | nextRandom (_, g) = random g 217 | 218 | -- FRP 219 | 220 | collection :: (Signal [Signal Bolt]) -> Signal (Bolt -> Bool) -> SignalGen (Signal [Bolt]) 221 | collection source isAlive = mdo 222 | boltSignals <- delay [] (map snd <$> boltsAndSignals') 223 | -- bolts: SignalGen [Signal Bolt]) 224 | -- add new bolt signals 225 | bolts <- memo (liftA2 (++) source boltSignals) 226 | -- boltsAndSignals type: SignalGen (Signal [Bolt], [Signal Bolt]) 227 | let boltsAndSignals = zip <$> (sequence =<< bolts) <*> bolts 228 | -- filter out 229 | boltsAndSignals' <- memo (filter <$> ((.fst) <$> isAlive) <*> boltsAndSignals) 230 | -- return 231 | return $ map fst <$> boltsAndSignals' 232 | 233 | -- FRP 234 | 235 | hasAny :: (Bool, Bool, Bool, Bool) -> Bool 236 | hasAny (l, r, u, d) = l || r || u || d 237 | 238 | endAnimation :: LevelStatus -> Maybe Ending -> Maybe Animation -> Maybe Animation 239 | endAnimation _ _ (Just (DeathAnimation 0)) = Just (DeathAnimation 0) 240 | endAnimation _ _ (Just (NextLevelAnimation l 0)) = Just (NextLevelAnimation l 0) 241 | endAnimation _ _ (Just (DeathAnimation n)) = Just (DeathAnimation (n - 1)) 242 | endAnimation _ _ (Just (NextLevelAnimation l n)) = Just (NextLevelAnimation l (n - 1)) 243 | endAnimation _ (Just Lose) _ = Just $ DeathAnimation 50 244 | endAnimation (Level n) (Just Win) _ = Just $ NextLevelAnimation (Level (n+1)) 50 245 | endAnimation _ _ Nothing = Nothing 246 | 247 | animationEnd :: Maybe Animation -> Bool 248 | animationEnd (Just (DeathAnimation 0)) = True 249 | animationEnd (Just (NextLevelAnimation _ 0)) = True 250 | animationEnd _ = False 251 | 252 | moveBolt :: Bolt -> Bolt 253 | moveBolt (Bolt (xpos, ypos) direction range alreadyHit) = Bolt (boltSpeed `times` (stepInDirection direction) `plus` (xpos, ypos)) direction (range - 1) alreadyHit 254 | 255 | boltIsAlive :: (Float, Float) -> [Monster] -> Bolt -> Bool 256 | boltIsAlive worldDimensions monsters bolt = (not (any (\monster -> hasHit monster bolt) monsters)) && boltStillGoing worldDimensions bolt 257 | 258 | -- let it come closer so that the hit can be registered before removing the bolt 259 | hasHit :: Monster -> Bolt -> Bool 260 | hasHit (Monster (xmon, ymon) _ _) (Bolt (x, y) _ _ _) 261 | | dist (xmon, ymon) (x, y) < ((monsterSize/4)^2) = True 262 | | otherwise = False 263 | 264 | edgify :: Signal (Bool, Bool, Bool, Bool) 265 | -> SignalGen (Signal (Bool, Bool, Bool, Bool)) 266 | edgify s = do 267 | s' <- delay (False, False, False, False) s 268 | return $ s' >>= \x -> throttle x s 269 | 270 | throttle :: (Bool, Bool, Bool, Bool) -> Signal (Bool, Bool, Bool, Bool) -> Signal (Bool, Bool, Bool, Bool) 271 | throttle shot sig 272 | | hasAny shot = return (False, False, False, False) 273 | | otherwise = sig 274 | 275 | -- boltStillGoing depends on the bolt range and on whether it hit the monster 276 | boltStillGoing :: (Float, Float) -> Bolt -> Bool 277 | boltStillGoing (width, height) (Bolt (x, y) _ range alreadyHit) = 278 | (not alreadyHit) && (range > 0) && x < width/2 && y < height/2 279 | 280 | stillHunting :: Maybe Ending -> Monster -> Bool 281 | stillHunting (Just _) _ = False 282 | stillHunting _ (Monster _ (Hunting _) 0) = False 283 | stillHunting Nothing (Monster _ (Hunting _) _) = True 284 | stillHunting Nothing _ = False 285 | 286 | viewPortMove :: Player -> ViewPort -> ViewPort 287 | viewPortMove (Player (x,y) _ _) (ViewPort { viewPortTranslate = _, viewPortRotate = rotation, viewPortScale = scaled }) = 288 | ViewPort { viewPortTranslate = ((-x), (-y)), viewPortRotate = rotation, viewPortScale = scaled } 289 | 290 | movePlayer :: Float 291 | -> (Float, Float) 292 | -> (Bool, Bool, Bool, Bool) 293 | -> Maybe Ending 294 | -> (Bool, Bool, Bool, Bool) 295 | -> Player 296 | -> Player 297 | movePlayer _ _ _ (Just _) _ player = player 298 | movePlayer increment dimensions direction Nothing shootDir player 299 | | outsideOfLimits dimensions (position (move direction shootDir player increment)) playerSize = player 300 | | otherwise = move direction shootDir player increment 301 | 302 | outsideOfLimits :: (Float, Float) -> (Float, Float) -> Float -> Bool 303 | outsideOfLimits (width, height) (xmon, ymon) size = xmon > width/2 - size/2 || 304 | xmon < (-(width)/2 + size/2) || 305 | ymon > height/2 - size/2 || 306 | ymon < (-(height)/2 + size/2) 307 | 308 | move :: (Bool, Bool, Bool, Bool) -> (Bool, Bool, Bool, Bool) -> Player -> Float -> Player 309 | move (False, False, False, False) sK (Player (xpos, ypos) _ _) _ = Player (xpos, ypos) Nothing (crossbowPointed sK) 310 | move keys sK (Player (xpos, ypos) (Just (PlayerMovement direction n)) _) increment 311 | | dirFrom keys == direction = Player ((xpos, ypos) `plus` increment `times` stepInDirection direction) (Just $ PlayerMovement direction (circular n)) (crossbowPointed sK) 312 | | otherwise = Player ((xpos, ypos) `plus` increment `times` stepInDirection (dirFrom keys)) (Just $ PlayerMovement (dirFrom keys) One) (crossbowPointed sK) 313 | move keys sK (Player (xpos, ypos) Nothing _) increment = Player ((xpos, ypos) `plus` increment `times` stepInDirection (dirFrom keys)) (Just $ PlayerMovement (dirFrom keys) One) (crossbowPointed sK) 314 | 315 | crossbowPointed :: (Bool, Bool, Bool, Bool) -> Maybe Direction 316 | crossbowPointed (a,d,w,s) 317 | | w = Just WalkUp 318 | | s = Just WalkDown 319 | | a = Just WalkLeft 320 | | d = Just WalkRight 321 | | otherwise = Nothing 322 | 323 | dirFrom :: (Bool, Bool, Bool, Bool) -> Direction 324 | dirFrom (l, r, u, d) 325 | | l = WalkLeft 326 | | r = WalkRight 327 | | u = WalkUp 328 | | d = WalkDown 329 | | otherwise = error "no direction from keys" 330 | 331 | stepInDirection :: Direction -> (Float, Float) 332 | stepInDirection WalkLeft = (-1, 0) 333 | stepInDirection WalkRight = (1, 0) 334 | stepInDirection WalkUp = (0, 1) 335 | stepInDirection WalkDown = (0, -1) 336 | 337 | hitOrMiss :: Float -> Monster -> Monster 338 | hitOrMiss hits (Monster (xmon, ymon) status health) = 339 | Monster (xmon, ymon) status (health - hits) 340 | 341 | monsterHits :: [Bolt] -> Monster -> Float 342 | monsterHits bolts monster = fromIntegral $ length 343 | $ filter (<= (monsterSize/2)^2) (boltDistances monster (filter notCounted bolts)) 344 | where notCounted (Bolt _ _ _ alreadyHit) = not alreadyHit 345 | 346 | accumulateScore :: [Float] -> Float -> Float 347 | accumulateScore hits score = score + sum hits 348 | 349 | boltDistances :: Monster -> [Bolt] -> [Float] 350 | boltDistances (Monster (xmon, ymon) _ _) bolts = 351 | map (\(Bolt (xbolt, ybolt) _ _ _) -> dist (xmon, ymon) (xbolt, ybolt)) bolts 352 | 353 | boltHit :: [Monster] -> [Bolt] -> Bool 354 | boltHit monsters bolts = any (== True) $ concat $ map (\monster -> map (< (monsterSize/2)^2) (boltDistances monster bolts)) monsters 355 | 356 | monsterWanderings :: RandomGen t => (Float, Float) -> Player -> (Direction, t) -> Maybe Ending -> [Float] -> [Monster] -> [Monster] 357 | monsterWanderings dim p gen ending hits monsters = map (wanderOrHunt dim p gen ending) (zip hits monsters) 358 | 359 | wanderOrHunt :: System.Random.RandomGen t => 360 | (Float, Float) 361 | -> Player 362 | -> (Direction, t) 363 | -> Maybe Ending 364 | -> (Float, Monster) 365 | -> Monster 366 | -- game ended 367 | wanderOrHunt _ _ _ (Just _) (_, monster) = monster 368 | 369 | -- no health left: dead 370 | wanderOrHunt _ _ _ _ (_, monster@(Monster _ _ 0)) = monster 371 | 372 | -- normal game 373 | wanderOrHunt dimensions player (r, _) Nothing (hits, monster) = do 374 | let monsterHit = hitOrMiss hits monster 375 | if close player monsterHit 376 | then hunt player monsterHit 377 | else wander r monsterHit dimensions 378 | 379 | close :: Player -> Monster -> Bool 380 | close player monster = distance player monster < huntingDist^2 381 | 382 | distance :: Player -> Monster -> Float 383 | distance (Player (xpos, ypos) _ _) (Monster (xmon, ymon) _ _) = dist (xpos, ypos) (xmon, ymon) 384 | 385 | -- if player is upper left quadrant, diagonal left 386 | -- means xpos > xmon and ypos > ymon 387 | hunt :: Player -> Monster -> Monster 388 | hunt (Player (xpos, ypos) _ _) (Monster (xmon, ymon) _ health) = Monster ((xmon + (signum (xpos - xmon))*monsterSpeed), (ymon + (signum (ypos - ymon))*monsterSpeed)) (Hunting $ huntingDirection (signum (xpos - xmon)) (signum (ypos - ymon))) health 389 | 390 | huntingDirection :: Float -> Float -> Direction 391 | huntingDirection (-1) (-1) = WalkLeft 392 | huntingDirection (-1) 1 = WalkLeft 393 | huntingDirection 1 (-1) = WalkRight 394 | huntingDirection 1 1 = WalkRight 395 | huntingDirection (-1) _ = WalkLeft 396 | huntingDirection _ _ = WalkRight 397 | 398 | -- turn in random direction 399 | wander :: Direction -> Monster -> (Float, Float) -> Monster 400 | wander r (Monster (xmon, ymon) (Wander _ 0) health) _ = Monster (xmon, ymon) (Wander r wanderDist) health 401 | wander r (Monster (xmon, ymon) (Hunting _) health) _ = Monster (xmon, ymon) (Wander r wanderDist) health 402 | -- go straight 403 | wander _ (Monster (xmon, ymon) (Wander direction n) health) dimensions = do 404 | let currentDirection = continueDirection direction (outsideOfLimits dimensions (xmon, ymon) monsterSize) 405 | Monster 406 | (stepInCurrentDirection currentDirection (xmon, ymon) monsterSpeed) 407 | (Wander currentDirection (n-1)) 408 | health 409 | 410 | continueDirection :: Direction -> Bool -> Direction 411 | continueDirection WalkUp True = WalkDown 412 | continueDirection WalkDown True = WalkUp 413 | continueDirection WalkLeft True = WalkRight 414 | continueDirection WalkRight True = WalkLeft 415 | continueDirection direction False = direction 416 | 417 | stepInCurrentDirection :: Direction -> (Float, Float) -> Float -> Pos 418 | stepInCurrentDirection direction (xpos, ypos) speed = speed `times` (stepInDirection direction) `plus` (xpos, ypos) 419 | 420 | safeOrDanger :: [Monster] -> [Monster] -> Maybe Ending -> Maybe StatusChange -> Maybe StatusChange 421 | safeOrDanger _ _ (Just _) _ = Just Safe 422 | safeOrDanger monsters monsters' _ _ = do 423 | let statusChanges = mapMaybe monitorStatusChange (zip monsters monsters') 424 | foldl' dominatingChanges Nothing statusChanges 425 | where dominatingChanges _ Danger = Just Danger 426 | dominatingChanges (Just Danger) Safe = Just Danger 427 | dominatingChanges _ Safe = Just Safe 428 | 429 | monitorStatusChange :: (Monster, Monster) -> Maybe StatusChange 430 | monitorStatusChange ((Monster _ _ num), (Monster _ _ 0)) = if num > 0 then Just Safe else Nothing 431 | monitorStatusChange ((Monster _ (Hunting _) _), (Monster _ (Wander _ _) _)) = Just Danger 432 | monitorStatusChange ((Monster _ (Wander _ _) _), (Monster _ (Hunting _) _)) = Just Safe 433 | monitorStatusChange _ = Nothing 434 | 435 | -- output functions 436 | -- uncomment when decimal point in module suffix bug is corrected 437 | outputFunction :: GLFW.Window 438 | -> State 439 | -> Hunted.Graphics.Textures 440 | -> Sounds 441 | -> GameState 442 | -> IO () 443 | 444 | outputFunction window glossState textures sounds (GameState renderState soundState) = 445 | (renderFrame window glossState textures (worldWidth, worldHeight) renderState) >> (playSounds sounds soundState) 446 | -------------------------------------------------------------------------------- /src/Hunted/GameTypes.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | module Hunted.GameTypes where 3 | 4 | import System.Random 5 | import Graphics.Gloss.Data.ViewPort (ViewPort) 6 | import Data.Monoid 7 | 8 | type Pos = (Float, Float) 9 | data Vec num = Vec num num 10 | 11 | dist :: Pos -> Pos -> Float 12 | dist (x1, y1) (x2, y2) = (x2 - x1)^2 + (y2 - y1)^2 13 | 14 | times :: Float -> Pos -> Pos 15 | times a (x,y) = (a*x, a*y) 16 | infixl 7 `times` 17 | 18 | plus :: Pos -> Pos -> Pos 19 | plus (a,b) (c,d) = getTupleSum $ (Sum a, Sum b) <> (Sum c, Sum d) 20 | where getTupleSum (x, y) = (getSum x, getSum y) 21 | infixl 6 `plus` 22 | 23 | type Health = Float 24 | 25 | data Player = Player { position :: Pos, movement :: Maybe PlayerMovement, shootDirection :: Maybe Direction } 26 | deriving Show 27 | data PlayerMovement = PlayerMovement { dir :: Direction, step :: WalkStage } 28 | deriving Show 29 | data WalkStage = One | Two | Three | Four 30 | deriving (Show, Eq, Enum, Bounded) 31 | 32 | circular :: (Eq x, Enum x, Bounded x) => x -> x 33 | circular x = if x == maxBound then minBound else succ x 34 | 35 | data Monster = Monster Pos MonsterStatus Health 36 | deriving Show 37 | 38 | data MonsterStatus = Wander Direction Int 39 | | Hunting Direction 40 | deriving Show 41 | data Direction = WalkUp | WalkDown | WalkLeft | WalkRight 42 | deriving (Show, Enum, Bounded, Eq) 43 | 44 | instance Random Direction where 45 | randomR (a, b) g = case randomR (fromEnum a, fromEnum b) g of 46 | (x, g') -> (toEnum x, g') 47 | random g = randomR (minBound, maxBound) g 48 | 49 | data RenderState = RenderState { renderState_player :: Player 50 | , renderState_monster :: [Monster] 51 | , renderState_ending :: Maybe Ending 52 | , renderState_viewport :: ViewPort 53 | , renderState_bolts :: [Bolt] 54 | , renderState_lives :: Int 55 | , renderState_score :: Float 56 | , renderState_animation :: Maybe Animation 57 | , renderState_windowSize :: (Int, Int) } 58 | | StartRenderState (Int, Int) 59 | data SoundState = SoundState { mood :: (Maybe StatusChange) 60 | , playerScreams :: Bool 61 | , hunting :: Bool 62 | , monsterDies :: Bool 63 | , shoot :: Bool 64 | , hit :: Bool } 65 | | StartSoundState 66 | 67 | data GameState = GameState RenderState SoundState 68 | 69 | data StatusChange = Danger | Safe 70 | 71 | type Range = Int 72 | data Bolt = Bolt Pos Direction Range Bool 73 | deriving Show 74 | 75 | data Ending = Win | Lose 76 | deriving (Show, Eq) 77 | 78 | data LevelStatus = Level Int 79 | deriving Show 80 | data GameStatus = Start | InGame 81 | deriving Show 82 | 83 | data Animation = DeathAnimation Float | NextLevelAnimation LevelStatus Float 84 | deriving Show 85 | -------------------------------------------------------------------------------- /src/Hunted/Graphics.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE PackageImports #-} 3 | module Hunted.Graphics ( 4 | loadTextures 5 | , initState 6 | , renderFrame 7 | , Textures 8 | ) where 9 | 10 | import Hunted.GameTypes 11 | import Hunted.Backend (swapBuffers) 12 | import "GLFW-b" Graphics.UI.GLFW as GLFW 13 | import Graphics.Gloss hiding (play) 14 | import Graphics.Gloss.Rendering 15 | import Graphics.Gloss.Data.ViewPort 16 | import Control.Applicative ((<*>), (<$>)) 17 | import qualified Data.Map.Strict as Map 18 | 19 | data TextureSet = TextureSet { front :: Picture, back :: Picture, left :: Picture, right :: Picture } 20 | | PlayerTextureSet { fronts :: WalkingTexture, backs :: WalkingTexture, lefts :: WalkingTexture, rights :: WalkingTexture } 21 | 22 | data WalkingTexture = WalkingTexture { neutral :: ShootingTexture, walkLeft :: ShootingTexture, walkRight :: ShootingTexture } 23 | data ShootingTexture = ShootingTexture { shootDown :: Picture, shootUp :: Picture, shootLeft :: Picture, shootRight :: Picture } 24 | 25 | data Textures = Textures { background :: Picture 26 | , playerTextures :: TextureSet 27 | , monsterWalking :: TextureSet 28 | , monsterHunting :: TextureSet 29 | , deadMonster :: Picture 30 | , texts :: Map.Map String Picture 31 | , boltTextures :: TextureSet } 32 | 33 | loadTextures :: IO Textures 34 | loadTextures = do 35 | playerTextureSet <- PlayerTextureSet <$> loadWalkingTexture "front" 36 | <*> loadWalkingTexture "back" 37 | <*> loadWalkingTexture "left" 38 | <*> loadWalkingTexture "right" 39 | monsterWalkingSet <- TextureSet <$> loadBMP "images/monster-walking-front.bmp" 40 | <*> loadBMP "images/monster-walking-back.bmp" 41 | <*> loadBMP "images/monster-walking-left.bmp" 42 | <*> loadBMP "images/monster-walking-right.bmp" 43 | -- moves diagonally, so only 2 textures needed technically 44 | monsterHuntingSet <- TextureSet <$> loadBMP "images/monster-hunting-left.bmp" 45 | <*> loadBMP "images/monster-hunting-right.bmp" 46 | <*> loadBMP "images/monster-hunting-left.bmp" 47 | <*> loadBMP "images/monster-hunting-right.bmp" 48 | deadMonsterTexture <- loadBMP "images/dead-monster.bmp" 49 | boltSet <- TextureSet <$> loadBMP "images/bolt-down.bmp" 50 | <*> loadBMP "images/bolt-up.bmp" 51 | <*> loadBMP "images/bolt-left.bmp" 52 | <*> loadBMP "images/bolt-right.bmp" 53 | backgroundTexture <- loadBMP "images/background-tile.bmp" 54 | gameOverText <- loadBMP "images/game-over.bmp" 55 | return Textures { background = backgroundTexture 56 | , playerTextures = playerTextureSet 57 | , monsterWalking = monsterWalkingSet 58 | , monsterHunting = monsterHuntingSet 59 | , deadMonster = deadMonsterTexture 60 | , texts = Map.singleton "game-over" gameOverText 61 | , boltTextures = boltSet } 62 | 63 | loadWalkingTexture :: String -> IO WalkingTexture 64 | loadWalkingTexture facing = do 65 | let pathFn faces shooting animationphase = "images/knight-" ++ faces ++ animationphase ++ "-crossbow-" ++ shooting ++ ".bmp" 66 | paths = map (pathFn facing) ["front", "back", "left", "right"] 67 | shootingTexture [a,b,c,d] = ShootingTexture a b c d 68 | shootingTexture _ = error "no other arrays allowed" 69 | WalkingTexture <$> (shootingTexture <$> (sequence $ map (\p -> loadBMP $ p "") paths)) 70 | <*> (shootingTexture <$> (sequence $ map (\p -> loadBMP $ p "-1") paths)) 71 | <*> (shootingTexture <$> (sequence $ map (\p -> loadBMP $ p "-3") paths)) 72 | 73 | -- again, need to export gloss internal state for this signature, pull request required 74 | renderFrame :: GLFW.Window 75 | -> State -> Textures -> (Float, Float) -> RenderState -> IO () 76 | 77 | renderFrame window 78 | glossState 79 | textures 80 | (worldWidth, worldHeight) 81 | (RenderState player 82 | monsters 83 | gameOver 84 | viewport 85 | bolts 86 | lives 87 | score 88 | mbAnimation 89 | dimensions) = do 90 | displayPicture dimensions black glossState (viewPortScale viewport) $ 91 | Pictures $ animation mbAnimation dimensions $ gameOngoing gameOver lives (texts textures) $ gameStats lives score dimensions $ 92 | [ uncurry translate (viewPortTranslate viewport) $ tiledBackground (background textures) worldWidth worldHeight 93 | , Pictures $ map (uncurry translate (viewPortTranslate viewport) . (renderBolt (boltTextures textures))) bolts 94 | , renderPlayer player (playerTextures textures) 95 | , uncurry translate (viewPortTranslate viewport) $ Pictures $ map (renderMonster (monsterWalking textures) (monsterHunting textures) (deadMonster textures)) monsters 96 | , uncurry translate (viewPortTranslate viewport) $ Pictures $ map renderHealthBar monsters ] 97 | swapBuffers window 98 | 99 | renderFrame window glossState _ _ (StartRenderState dimensions) = do 100 | displayPicture dimensions black glossState 1 $ 101 | Pictures [ Color green $ translate (-140) 0 $ scale 0.4 0.4 $ Text "Hunting Season" 102 | , Color green $ translate (-140) (-50) $ scale 0.1 0.1 $ Text "Press s to get started" ] 103 | swapBuffers window 104 | 105 | -- tiling: pictures translated to the appropriate locations to fill up the given width and heights 106 | -- I scaled the tile to the greatest common factor of the width and height, but it should work to fit the actual width and height 107 | -- which potentially means translating the tiles back a bit not to go over the edge 108 | tileSize :: Float 109 | tileSize = 160 110 | 111 | tiledBackground :: Picture -> Float -> Float -> Picture 112 | tiledBackground texture width height = Pictures $ map (\a -> ((uncurry translate) a) texture) $ translateMatrix width height 113 | 114 | -- what we want: 640, 480 115 | -- -320--x--(-160)--x--0--x--160--x--320 116 | -- -240 -80 80 240 117 | -- -240--x--(-80)--x--80--x--240 118 | -- -160 0 160 119 | translateMatrix :: Float -> Float -> [(Float, Float)] 120 | translateMatrix w h = concat $ map (zip xTiles) 121 | $ map (replicate (length xTiles)) yTiles 122 | where xTiles = [lowerbound w, lowerbound w + tileSize..higherbound w] 123 | yTiles = [lowerbound h, lowerbound h + tileSize..higherbound h] 124 | higherbound size = size/2 - tileSize/2 125 | lowerbound size = -(higherbound size) 126 | 127 | -- put crossbow behind player when he's facing up or profile, otherwise in front 128 | renderPlayer :: Player -> TextureSet -> Picture 129 | renderPlayer (Player _ (Just (PlayerMovement facing One)) shootDir) textureSet = shootDirectionTexture (Just facing) shootDir $ neutral $ playerDirectionTexture facing textureSet 130 | renderPlayer (Player _ (Just (PlayerMovement facing Two)) shootDir) textureSet = shootDirectionTexture (Just facing) shootDir $ walkLeft $ playerDirectionTexture facing textureSet 131 | renderPlayer (Player _ (Just (PlayerMovement facing Three)) shootDir) textureSet = shootDirectionTexture (Just facing) shootDir $ neutral $ playerDirectionTexture facing textureSet 132 | renderPlayer (Player _ (Just (PlayerMovement facing Four)) shootDir) textureSet = shootDirectionTexture (Just facing) shootDir $ walkRight $ playerDirectionTexture facing textureSet 133 | renderPlayer (Player _ Nothing shootDir) textureSet = shootDirectionTexture Nothing shootDir $ neutral $ fronts textureSet 134 | 135 | renderMonster :: TextureSet -> TextureSet -> Picture -> Monster -> Picture 136 | renderMonster _ _ dead (Monster (xpos, ypos) _ 0) = translate xpos ypos $ dead 137 | renderMonster _ textureSet _ (Monster (xpos, ypos) (Hunting facing) _) = translate xpos ypos $ directionTexture facing textureSet 138 | renderMonster textureSet _ _ (Monster (xpos, ypos) (Wander WalkUp _) _) = translate xpos ypos $ back textureSet 139 | renderMonster textureSet _ _ (Monster (xpos, ypos) (Wander WalkDown _) _) = translate xpos ypos $ front textureSet 140 | renderMonster textureSet _ _ (Monster (xpos, ypos) (Wander WalkLeft n) _) = translate xpos ypos $ rotate (16* fromIntegral n) $ left textureSet 141 | renderMonster textureSet _ _ (Monster (xpos, ypos) (Wander WalkRight n) _) = translate xpos ypos $ rotate ((-16)* fromIntegral n) $ right textureSet 142 | 143 | renderBolt :: TextureSet -> Bolt -> Picture 144 | renderBolt textureSet (Bolt (xpos, ypos) facing _ _) = translate xpos ypos $ directionTexture facing textureSet 145 | 146 | directionTexture :: Direction -> TextureSet -> Picture 147 | directionTexture WalkUp = back 148 | directionTexture WalkDown = front 149 | directionTexture WalkLeft = left 150 | directionTexture WalkRight = right 151 | 152 | playerDirectionTexture :: Direction -> TextureSet -> WalkingTexture 153 | playerDirectionTexture WalkUp = backs 154 | playerDirectionTexture WalkDown = fronts 155 | playerDirectionTexture WalkLeft = lefts 156 | playerDirectionTexture WalkRight = rights 157 | 158 | shootDirectionTexture :: Maybe Direction -> Maybe Direction -> ShootingTexture -> Picture 159 | shootDirectionTexture _ (Just WalkDown) = shootDown 160 | shootDirectionTexture _ (Just WalkUp) = shootUp 161 | shootDirectionTexture _ (Just WalkLeft) = shootLeft 162 | shootDirectionTexture _ (Just WalkRight) = shootRight 163 | shootDirectionTexture Nothing Nothing = shootDown 164 | shootDirectionTexture facing Nothing = shootDirectionTexture Nothing facing 165 | 166 | -- [x x x x x] 167 | -- [0 0] 168 | -- 1 centered around xmon, size bar 169 | -- 2 centered around xmon - bar/2 + health/2 170 | numberOfLives :: Float 171 | numberOfLives = 4 172 | 173 | healthBarLength :: Float 174 | healthBarLength = 40 175 | 176 | healthBarWidth :: Float 177 | healthBarWidth = 5 178 | 179 | renderHealthBar :: Monster -> Picture 180 | renderHealthBar (Monster _ _ 0) = Pictures [] 181 | renderHealthBar (Monster (xmon, ymon) _ health) = Pictures [ translate xmon (ymon + 30) $ Color black $ rectangleSolid healthBarLength healthBarWidth 182 | , translate (xmon - healthBarLength/2 + health*healthBarLength/(numberOfLives*2)) (ymon + 30) $ Color red $ rectangleSolid (health*healthBarLength/numberOfLives) healthBarWidth ] 183 | 184 | -- adds gameover text if appropriate 185 | gameOngoing :: Maybe Ending -> Int -> Map.Map String Picture -> [Picture] -> [Picture] 186 | gameOngoing (Just Lose) 1 textTextures pics = pics ++ [translate (-50) 0 $ (textTextures Map.! "game-over")] 187 | gameOngoing (Just Lose) _ _ pics = pics ++ [Color black $ translate (-100) 0 $ Scale 0.3 0.3 $ Text "Aaargh"] 188 | gameOngoing (Just Win) _ _ pics = pics ++ [Color black $ translate (-100) 0 $ Scale 0.3 0.3 $ Text "You win!"] 189 | gameOngoing Nothing _ _ pics = pics 190 | 191 | -- add score and lives 192 | -- lives are reprented by circles 193 | gameStats :: Int -> Float -> (Int, Int) -> [Picture] -> [Picture] 194 | gameStats lives score (w, h) pics = do 195 | let fWidth = fromIntegral w 196 | fHeight = fromIntegral h 197 | pics ++ [ Color black $ translate (fWidth/2 - 80) (fHeight/2 - 50) $ Scale 0.2 0.2 $ Text $ show $ round score 198 | , Color (makeColor 1 1 1 0.5) $ translate ((-fWidth/2) + 80) (fHeight/2 - 40) $ rectangleSolid 250 40 199 | , Color black $ translate ((-fWidth)/2 + 20) (fHeight/2 - 50) $ Scale 0.2 0.2 $ Text "lives: "] 200 | ++ map (\i -> Color red $ translate ((-fWidth)/2 + 90 + 40*i) (fHeight/2 - 40) $ circleSolid 10) [0..(fromIntegral (lives - 1))] 201 | 202 | animation :: Maybe Animation -> (Int, Int) -> [Picture] -> [Picture] 203 | animation Nothing _ pics = pics 204 | animation (Just (DeathAnimation _)) _ pics = pics 205 | animation (Just (NextLevelAnimation l n)) (w, h) pics = pics ++ 206 | [ Color (animationColor n) $ rectangleSolid (fromIntegral w) (fromIntegral h) 207 | , Color white $ translate (-100) 0 $ scale 0.3 0.3 $ Text $ show l ] 208 | where animationColor i 209 | | n > 25 = makeColor 0 0 0 (0.04*(50-i)) 210 | | otherwise = makeColor 0 0 0 (0.04*i) 211 | -------------------------------------------------------------------------------- /src/Hunted/Main.hs: -------------------------------------------------------------------------------- 1 | import Hunted.Sound 2 | import Hunted.Backend 3 | import Hunted.Graphics 4 | import Hunted.Game 5 | 6 | import System.Exit ( exitSuccess ) 7 | import System.Random 8 | import Control.Concurrent (threadDelay) 9 | import Control.Monad (unless, join) 10 | import Control.Monad.Fix (fix) 11 | import FRP.Elerea.Simple as Elerea 12 | 13 | width :: Int 14 | width = 640 15 | 16 | height :: Int 17 | height = 480 18 | 19 | main :: IO () 20 | main = do 21 | (directionKeyGen, directionKeySink) <- external (False, False, False, False) 22 | (shootKeyGen, shootKeySink) <- external (False, False, False, False) 23 | (windowSizeGen,windowSizeSink) <- external (fromIntegral width, fromIntegral height) 24 | randomGenerator <- newStdGen 25 | glossState <- initState 26 | textures <- loadTextures 27 | withWindow width height windowSizeSink "hunted" $ \win -> do 28 | withSound $ \_ _ -> do 29 | sounds <- loadSounds 30 | backgroundMusic (backgroundTune sounds) 31 | network <- start $ do 32 | directionKey <- directionKeyGen 33 | windowSize <- windowSizeGen 34 | shootKey <- shootKeyGen 35 | hunted win windowSize directionKey shootKey randomGenerator textures glossState sounds 36 | fix $ \loop -> do 37 | readInput win directionKeySink shootKeySink 38 | join network 39 | threadDelay 20000 40 | esc <- exitKeyPressed win 41 | unless esc loop 42 | exitSuccess 43 | -------------------------------------------------------------------------------- /src/Hunted/Sound.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Hunted.Sound ( 3 | withSound 4 | , loadSounds 5 | , backgroundMusic 6 | , playSounds 7 | , Sounds(..) 8 | ) where 9 | 10 | import Hunted.GameTypes 11 | 12 | import Sound.ALUT hiding (Static) 13 | import System.IO ( hPutStrLn, stderr ) 14 | import Data.List (intersperse) 15 | import Control.Monad (when, unless) 16 | -- import Control.Monad.IO.Class (MonadIO(..)) 17 | import Control.Monad.IO.Class () 18 | import Control.Applicative ((<$>), (<*>)) 19 | 20 | data Sounds = Sounds { backgroundTune :: Source 21 | , shriek :: Source 22 | , bite :: Source 23 | , groan :: Source 24 | , twang :: Source 25 | , thump :: Source } 26 | 27 | -- convenience function to abstract the ALUT context 28 | withSound :: forall a. Runner IO a 29 | withSound = withProgNameAndArgs runALUT 30 | 31 | -- sounds 32 | -- music: https://www.freesound.org/people/Thirsk/sounds/121035/ 33 | -- shriek: https://www.freesound.org/people/dan2008ds/sounds/175169/ 34 | -- bite: https://www.freesound.org/people/dan2008ds/sounds/175169/ 35 | -- twang https://www.freesound.org/people/cubic.archon/sounds/44192/ 36 | -- thump https://www.freesound.org/people/fons/sounds/101362/ 37 | -- groan https://www.freesound.org/people/dag451/sounds/118336/ 38 | 39 | loadSounds :: IO Sounds 40 | loadSounds = do 41 | biteSource <- loadSound "sounds/bite.wav" 42 | sourceGain biteSource $= 0.5 43 | Sounds <$> loadSound "sounds/oboe-loop.wav" 44 | <*> loadSound "sounds/shriek.wav" 45 | <*> return biteSource 46 | <*> loadSound "sounds/groan.wav" 47 | <*> loadSound "sounds/twang.wav" 48 | <*> loadSound "sounds/thump.wav" 49 | 50 | loadSound :: FilePath -> IO Source 51 | loadSound path = do 52 | buf <- createBuffer (File path) 53 | source <- genObjectName 54 | buffer source $= Just buf 55 | return source 56 | 57 | backgroundMusic :: Source -> IO () 58 | backgroundMusic source = do 59 | loopingMode source $= Looping 60 | play [source] 61 | 62 | -- ALUT internal float format 63 | paceToPitch :: StatusChange -> ALfloat 64 | paceToPitch Safe = 1 65 | paceToPitch Danger = 2 66 | 67 | playSounds :: Sounds -> SoundState -> IO () 68 | playSounds _ StartSoundState = return () 69 | playSounds sounds soundState = do 70 | changeBackgroundMusic (backgroundTune sounds) (mood soundState) 71 | when (playerScreams soundState) $ playSound (shriek sounds) 72 | when (monsterDies soundState) $ playSound (groan sounds) 73 | when (shoot soundState) $ playSound (twang sounds) 74 | when (hit soundState) $ playSound (thump sounds) 75 | if (hunting soundState) then playContinuousSound (bite sounds) 76 | else stop [bite sounds] 77 | 78 | changeBackgroundMusic :: Source -> Maybe StatusChange -> IO () 79 | changeBackgroundMusic source (Just pace) = pitch source $= (paceToPitch pace) 80 | changeBackgroundMusic _ Nothing = return () 81 | 82 | playContinuousSound :: Source -> IO () 83 | playContinuousSound source = do 84 | state <- get (sourceState source) 85 | unless (state == Playing) $ play [source] 86 | 87 | playSound :: Source -> IO () 88 | playSound source = do 89 | play [source] 90 | -- Normally nothing should go wrong above, but one never knows... 91 | errs <- get alErrors 92 | unless (null errs) $ do 93 | hPutStrLn stderr (concat (intersperse "," [ d | ALError _ d <- errs ])) 94 | return () 95 | -------------------------------------------------------------------------------- /src/Music.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports, RecursiveDo #-} 2 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 3 | import "GLFW-b" Graphics.UI.GLFW as GLFW 4 | import Graphics.Gloss hiding (play) 5 | import Graphics.Gloss.Rendering 6 | import Graphics.Gloss.Data.ViewPort 7 | import System.Exit ( exitSuccess ) 8 | import Control.Concurrent (threadDelay) 9 | import Control.Monad (when, unless, join) 10 | import Control.Monad.Fix (fix) 11 | import Control.Applicative ((<*>), (<$>)) 12 | import FRP.Elerea.Simple as Elerea 13 | import System.Random 14 | import Sound.ALUT hiding (Static, direction) 15 | import System.IO ( hPutStrLn, stderr ) 16 | import Data.List (intersperse) 17 | 18 | type Pos = Point 19 | data Player = Player { position :: Pos, movement :: Maybe PlayerMovement } 20 | deriving Show 21 | 22 | data PlayerMovement = PlayerMovement { dir :: Direction, step :: WalkStage } 23 | deriving Show 24 | 25 | data WalkStage = One | Two | Three | Four 26 | deriving (Show, Eq, Enum, Bounded) 27 | 28 | data Monster = Monster Pos MonsterStatus 29 | deriving Show 30 | 31 | data MonsterStatus = Wander Direction Int 32 | | Hunting HuntingDirection 33 | deriving Show 34 | 35 | data Direction = WalkUp | WalkDown | WalkLeft | WalkRight 36 | deriving (Show, Enum, Bounded) 37 | 38 | data HuntingDirection = HuntingLeft | HuntingRight 39 | deriving Show 40 | 41 | instance Random Direction where 42 | randomR (a, b) g = case randomR (fromEnum a, fromEnum b) g of 43 | (x, g') -> (toEnum x, g') 44 | random g = randomR (minBound, maxBound) g 45 | 46 | data TextureSet = TextureSet { front :: Picture, back :: Picture, left :: Picture, right :: Picture } 47 | | PlayerTextureSet { fronts :: WalkingTexture, backs :: WalkingTexture, lefts :: WalkingTexture, rights :: WalkingTexture } 48 | 49 | data WalkingTexture = WalkingTexture { neutral :: Picture, walkLeft :: Picture, walkRight :: Picture } 50 | 51 | data Textures = Textures { backgroundTexture :: Picture 52 | , playerTexture :: TextureSet 53 | , monsterWalkingTexture :: TextureSet 54 | , monsterHuntingTexture :: TextureSet } 55 | 56 | data RenderState = RenderState Player Monster Bool ViewPort 57 | data SoundState = SoundState (Maybe StatusChange) Bool Bool 58 | 59 | data StatusChange = Danger | Safe 60 | 61 | data Sounds = Sounds { backgroundTune :: Source 62 | , shriek :: Source 63 | , bite :: Source } 64 | 65 | initialPlayer :: Player 66 | initialPlayer = Player (0, 0) Nothing 67 | 68 | initialMonster :: Monster 69 | initialMonster = Monster (200, 200) (Wander WalkUp wanderDist) 70 | 71 | initialViewport :: ViewPort 72 | initialViewport = ViewPort { viewPortTranslate = (0, 0), viewPortRotate = 0, viewPortScale = viewportScale } 73 | 74 | viewportScale :: Float 75 | viewportScale = 4 76 | 77 | width, height :: Int 78 | width = 640 79 | height = 480 80 | 81 | worldWidth, worldHeight :: Float 82 | worldWidth = 2560 83 | worldHeight = 1920 84 | 85 | playerSize, monsterSize, monsterSpeed :: Float 86 | playerSize = 20 87 | monsterSize = 20 88 | monsterSpeed = 5 89 | 90 | main :: IO () 91 | main = do 92 | (directionKeyGen, directionKeySink) <- external (False, False, False, False) 93 | randomGenerator <- newStdGen 94 | glossState <- initState 95 | textures <- loadTextures 96 | withWindow width height "Game-Demo" $ \win -> do 97 | withProgNameAndArgs runALUT $ \_ _ -> do 98 | sounds <- loadSounds 99 | backgroundMusic (backgroundTune sounds) 100 | network <- start $ do 101 | directionKey <- directionKeyGen 102 | hunted win directionKey randomGenerator textures glossState sounds 103 | fix $ \loop -> do 104 | readInput win directionKeySink 105 | join network 106 | threadDelay 20000 107 | esc <- keyIsPressed win Key'Escape 108 | unless esc loop 109 | exitSuccess 110 | 111 | loadTextures :: IO Textures 112 | loadTextures = do 113 | playerTextureSet <- PlayerTextureSet <$> loadAnims "images/knight-front.bmp" "images/knight-front-1.bmp" "images/knight-front-3.bmp" 114 | <*> loadAnims "images/knight-back.bmp" "images/knight-back-1.bmp" "images/knight-back-3.bmp" 115 | <*> loadAnims "images/knight-left.bmp" "images/knight-left-1.bmp" "images/knight-left-3.bmp" 116 | <*> loadAnims "images/knight-right.bmp" "images/knight-right-1.bmp" "images/knight-right-3.bmp" 117 | monsterWalkingSet <- TextureSet <$> loadBMP "images/monster-walking-front.bmp" 118 | <*> loadBMP "images/monster-walking-back.bmp" 119 | <*> loadBMP "images/monster-walking-left.bmp" 120 | <*> loadBMP "images/monster-walking-right.bmp" 121 | -- moves diagonally, so only 2 textures needed technically 122 | monsterHuntingSet <- TextureSet <$> loadBMP "images/monster-hunting-left.bmp" 123 | <*> loadBMP "images/monster-hunting-right.bmp" 124 | <*> loadBMP "images/monster-hunting-left.bmp" 125 | <*> loadBMP "images/monster-hunting-right.bmp" 126 | background <- loadBMP "images/background-tile.bmp" 127 | return Textures { backgroundTexture = background 128 | , playerTexture = playerTextureSet 129 | , monsterWalkingTexture = monsterWalkingSet 130 | , monsterHuntingTexture = monsterHuntingSet } 131 | 132 | loadSounds :: IO Sounds 133 | loadSounds = do 134 | musicSource <- loadSound "sounds/oboe-loop.wav" 135 | shriekSource <- loadSound "sounds/shriek.wav" 136 | biteSource <- loadSound "sounds/bite.wav" 137 | sourceGain biteSource $= 0.5 138 | return $ Sounds musicSource shriekSource biteSource 139 | 140 | loadSound :: FilePath -> IO Source 141 | loadSound path = do 142 | buf <- createBuffer (File path) 143 | source <- genObjectName 144 | buffer source $= Just buf 145 | return source 146 | 147 | loadAnims :: String -> String -> String -> IO WalkingTexture 148 | loadAnims path1 path2 path3 = WalkingTexture <$> loadBMP path1 <*> loadBMP path2 <*> loadBMP path3 149 | 150 | hunted :: RandomGen t => 151 | Window 152 | -> Signal (Bool, Bool, Bool, Bool) 153 | -> t 154 | -> Textures 155 | -> State 156 | -> Sounds 157 | -> SignalGen (Signal (IO ())) 158 | hunted win directionKey randomGenerator textures glossState sounds = mdo 159 | player <- transfer2 initialPlayer (movePlayer 10) directionKey gameOver' 160 | randomNumber <- stateful (undefined, randomGenerator) nextRandom 161 | monster <- transfer3 initialMonster wanderOrHunt player randomNumber gameOver' 162 | monster' <- delay initialMonster monster 163 | gameOver <- memo (playerEaten <$> player <*> monster) 164 | gameOver' <- delay False gameOver 165 | viewport <- transfer initialViewport viewPortMove player 166 | statusChange <- transfer2 Nothing monitorStatusChange monster monster' 167 | endOfGame <- Elerea.till gameOver 168 | 169 | let hunting = stillHunting <$> monster <*> gameOver 170 | renderState = RenderState <$> player <*> monster <*> gameOver <*> viewport 171 | soundState = SoundState <$> statusChange <*> endOfGame <*> hunting 172 | 173 | return $ outputFunction win glossState textures sounds <$> renderState <*> soundState 174 | where playerEaten player monster = distance player monster < (playerSize^2 :: Float) 175 | nextRandom (_, g) = random g 176 | 177 | stillHunting :: Monster -> Bool -> Bool 178 | stillHunting _ True = False 179 | stillHunting (Monster _ (Hunting _)) False = True 180 | stillHunting _ False = False 181 | 182 | viewPortMove :: Player -> ViewPort -> ViewPort 183 | viewPortMove (Player (x,y) _) (ViewPort { viewPortTranslate = _, viewPortRotate = rotation, viewPortScale = scaled }) = 184 | ViewPort { viewPortTranslate = ((-x), (-y)), viewPortRotate = rotation, viewPortScale = scaled } 185 | 186 | readInput :: Window -> ((Bool, Bool, Bool, Bool) -> IO ()) -> IO () 187 | readInput window directionKeySink = do 188 | pollEvents 189 | l <- keyIsPressed window Key'Left 190 | r <- keyIsPressed window Key'Right 191 | u <- keyIsPressed window Key'Up 192 | d <- keyIsPressed window Key'Down 193 | directionKeySink (l, r, u, d) 194 | 195 | movePlayer :: Float -> (Bool, Bool, Bool, Bool) -> Bool -> Player -> Player 196 | movePlayer _ _ True player = player 197 | movePlayer increment direction False player 198 | | outsideOfLimits (position (move direction player increment)) playerSize = player 199 | | otherwise = move direction player increment 200 | 201 | outsideOfLimits :: (Float, Float) -> Float -> Bool 202 | outsideOfLimits (xmon, ymon) size = xmon > worldWidth/2 - size/2 || 203 | xmon < ((-worldWidth)/2 + size/2) || 204 | ymon > worldHeight/2 - size/2 || 205 | ymon < ((-worldHeight)/2 + size/2) 206 | 207 | move :: (Bool, Bool, Bool, Bool) -> Player -> Float -> Player 208 | move (True, _, _, _) (Player (xpos, ypos) (Just (PlayerMovement WalkLeft n))) increment = Player (xpos - increment, ypos) (Just $ PlayerMovement WalkLeft (circular n)) 209 | move (True, _, _, _) (Player (xpos, ypos) _) increment = Player (xpos - increment, ypos) $ Just $ PlayerMovement WalkLeft One 210 | move (_, True, _, _) (Player (xpos, ypos) (Just (PlayerMovement WalkRight n))) increment = Player (xpos + increment, ypos) (Just $ PlayerMovement WalkRight (circular n)) 211 | move (_, True, _, _) (Player (xpos, ypos) _) increment = Player (xpos + increment, ypos) $ Just $ PlayerMovement WalkRight One 212 | move (_, _, True, _) (Player (xpos, ypos) (Just (PlayerMovement WalkUp n))) increment = Player (xpos, (ypos + increment)) (Just $ PlayerMovement WalkUp (circular n)) 213 | move (_, _, True, _) (Player (xpos, ypos) _) increment = Player (xpos, (ypos + increment)) $ Just $ PlayerMovement WalkUp One 214 | move (_, _, _, True) (Player (xpos, ypos) (Just (PlayerMovement WalkDown n))) increment = Player (xpos, (ypos - increment)) (Just $ PlayerMovement WalkDown (circular n)) 215 | move (_, _, _, True) (Player (xpos, ypos) _) increment = Player (xpos, (ypos - increment)) $ Just $ PlayerMovement WalkDown One 216 | move (False, False, False, False) (Player (xpos, ypos) _) _ = Player (xpos, ypos) Nothing 217 | 218 | circular :: (Eq x, Enum x, Bounded x) => x -> x 219 | circular x = if x == maxBound then minBound else succ x 220 | 221 | wanderDist :: Int 222 | wanderDist = 45 223 | 224 | huntingDist :: Float 225 | huntingDist = 200 226 | 227 | wanderOrHunt :: RandomGen t => Player -> (Direction, t) -> Bool -> Monster -> Monster 228 | wanderOrHunt _ _ True monster = monster 229 | wanderOrHunt player (r, _) False monster = if close player monster 230 | then hunt player monster 231 | else wander r monster 232 | 233 | close :: Player -> Monster -> Bool 234 | close player monster = distance player monster < huntingDist^2 235 | 236 | distance :: Player -> Monster -> Float 237 | distance (Player (xpos, ypos) _) (Monster (xmon, ymon) _) = (xpos - xmon)^2 + (ypos - ymon)^2 238 | 239 | -- if player is upper left quadrant, diagonal left 240 | -- means xpos > xmon and ypos > ymon 241 | hunt :: Player -> Monster -> Monster 242 | hunt (Player (xpos, ypos) _) (Monster (xmon, ymon) _) = Monster ((xmon + (signum (xpos - xmon))*monsterSpeed), (ymon + (signum (ypos - ymon))*monsterSpeed)) (Hunting $ huntingDirection (signum (xpos - xmon)) (signum (ypos - ymon))) 243 | 244 | huntingDirection :: Float -> Float -> HuntingDirection 245 | huntingDirection (-1) (-1) = HuntingLeft 246 | huntingDirection (-1) 1 = HuntingLeft 247 | huntingDirection 1 (-1) = HuntingRight 248 | huntingDirection 1 1 = HuntingRight 249 | huntingDirection (-1) _ = HuntingLeft 250 | huntingDirection _ _ = HuntingRight 251 | 252 | -- turn in random direction 253 | wander :: Direction -> Monster -> Monster 254 | wander r (Monster (xmon, ymon) (Wander _ 0)) = Monster (xmon, ymon) (Wander r wanderDist) 255 | wander r (Monster (xmon, ymon) (Hunting _)) = Monster (xmon, ymon) (Wander r wanderDist) 256 | -- go straight 257 | wander _ (Monster (xmon, ymon) (Wander direction n)) = do 258 | let currentDirection = continueDirection direction (outsideOfLimits (xmon, ymon) monsterSize) 259 | Monster 260 | (stepInCurrentDirection currentDirection (xmon, ymon) monsterSpeed) 261 | (Wander currentDirection (n-1)) 262 | 263 | continueDirection :: Direction -> Bool -> Direction 264 | continueDirection WalkUp True = WalkDown 265 | continueDirection WalkDown True = WalkUp 266 | continueDirection WalkLeft True = WalkRight 267 | continueDirection WalkRight True = WalkLeft 268 | continueDirection direction False = direction 269 | 270 | stepInCurrentDirection :: Direction -> (Float, Float) -> Float -> (Float, Float) 271 | stepInCurrentDirection WalkUp (xpos, ypos) speed = (xpos, ypos + speed) 272 | stepInCurrentDirection WalkDown (xpos, ypos) speed = (xpos, ypos - speed) 273 | stepInCurrentDirection WalkLeft (xpos, ypos) speed = (xpos - speed, ypos) 274 | stepInCurrentDirection WalkRight (xpos, ypos) speed = (xpos + speed, ypos) 275 | 276 | monitorStatusChange :: Monster -> Monster -> Maybe StatusChange -> Maybe StatusChange 277 | monitorStatusChange (Monster _ (Hunting _)) (Monster _ (Wander _ _)) _ = Just Danger 278 | monitorStatusChange (Monster _ (Wander _ _)) (Monster _ (Hunting _)) _ = Just Safe 279 | monitorStatusChange _ _ _ = Nothing 280 | 281 | -- output functions 282 | outputFunction :: Window 283 | -> State 284 | -> Textures 285 | -> Sounds 286 | -> RenderState 287 | -> SoundState 288 | -> IO () 289 | outputFunction window glossState textures sounds renderState soundState = (renderFrame window glossState textures renderState) >> (playSounds sounds soundState) 290 | 291 | renderFrame :: Window -> State -> Textures -> RenderState -> IO () 292 | renderFrame window glossState textures (RenderState (Player _ playerDir) (Monster (xmon, ymon) status) gameOver viewport) = do 293 | displayPicture (width, height) black glossState (viewPortScale viewport) $ 294 | Pictures $ gameOngoing gameOver 295 | [ uncurry translate (viewPortTranslate viewport) $ tiledBackground (backgroundTexture textures) 296 | , renderPlayer playerDir (playerTexture textures) 297 | , uncurry translate (viewPortTranslate viewport) $ renderMonster status xmon ymon (monsterWalkingTexture textures) (monsterHuntingTexture textures) ] 298 | swapBuffers window 299 | 300 | -- tiling: pictures translated to the appropriate locations to fill up the given width and heights 301 | -- I scaled the tile to the greatest common factor of the width and height, but it should work to fit the actual width and height 302 | -- which potentially means translating the tiles back a bit not to go over the edge 303 | tileSize :: Float 304 | tileSize = 160 305 | 306 | tiledBackground :: Picture -> Picture 307 | tiledBackground texture = Pictures $ map (\a -> ((uncurry translate) a) texture) $ translateMatrix worldWidth worldHeight 308 | 309 | -- what we want: 640, 480 310 | -- -320--x--(-160)--x--0--x--160--x--320 311 | -- -240 -80 80 240 312 | -- -240--x--(-80)--x--80--x--240 313 | -- -160 0 160 314 | translateMatrix :: Float -> Float -> [(Float, Float)] 315 | translateMatrix w h = concat $ map (zip xTiles) 316 | $ map (replicate (length xTiles)) yTiles 317 | where xTiles = [lowerbound w, lowerbound w + tileSize..higherbound w] 318 | yTiles = [lowerbound h, lowerbound h + tileSize..higherbound h] 319 | higherbound size = size/2 - tileSize/2 320 | lowerbound size = -(higherbound size) 321 | 322 | renderPlayer :: Maybe PlayerMovement -> TextureSet -> Picture 323 | renderPlayer (Just (PlayerMovement facing One)) textureSet = neutral $ playerDirectionTexture facing textureSet 324 | renderPlayer (Just (PlayerMovement facing Two)) textureSet = walkLeft $ playerDirectionTexture facing textureSet 325 | renderPlayer (Just (PlayerMovement facing Three)) textureSet = neutral $ playerDirectionTexture facing textureSet 326 | renderPlayer (Just (PlayerMovement facing Four)) textureSet = walkRight $ playerDirectionTexture facing textureSet 327 | renderPlayer Nothing textureSet = neutral $ fronts textureSet 328 | 329 | playerDirectionTexture :: Direction -> TextureSet -> WalkingTexture 330 | playerDirectionTexture WalkUp = backs 331 | playerDirectionTexture WalkDown = fronts 332 | playerDirectionTexture WalkLeft = lefts 333 | playerDirectionTexture WalkRight = rights 334 | 335 | renderMonster :: MonsterStatus -> Float -> Float -> TextureSet -> TextureSet -> Picture 336 | renderMonster (Hunting HuntingLeft) xpos ypos _ textureSet = translate xpos ypos $ left textureSet 337 | renderMonster (Hunting HuntingRight) xpos ypos _ textureSet = translate xpos ypos $ right textureSet 338 | renderMonster (Wander WalkUp _) xpos ypos textureSet _ = translate xpos ypos $ back textureSet 339 | renderMonster (Wander WalkDown _) xpos ypos textureSet _ = translate xpos ypos $ front textureSet 340 | renderMonster (Wander WalkLeft n) xpos ypos textureSet _ = translate xpos ypos $ rotate (16* fromIntegral n) $ left textureSet 341 | renderMonster (Wander WalkRight n) xpos ypos textureSet _ = translate xpos ypos $ rotate (16* fromIntegral n) $ right textureSet 342 | 343 | -- adds gameover text if appropriate 344 | gameOngoing :: Bool -> [Picture] -> [Picture] 345 | gameOngoing gameOver pics = if gameOver then pics ++ [Color black $ translate (-100) 0 $ Scale 0.3 0.3 $ Text "Game Over"] 346 | else pics 347 | 348 | withWindow :: Int -> Int -> String -> (GLFW.Window -> IO ()) -> IO () 349 | withWindow windowWidth windowHeight title f = do 350 | GLFW.setErrorCallback $ Just simpleErrorCallback 351 | r <- GLFW.init 352 | when r $ do 353 | m <- GLFW.createWindow windowWidth windowHeight title Nothing Nothing 354 | case m of 355 | (Just win) -> do 356 | GLFW.makeContextCurrent m 357 | f win 358 | GLFW.setErrorCallback $ Just simpleErrorCallback 359 | GLFW.destroyWindow win 360 | Nothing -> return () 361 | GLFW.terminate 362 | where 363 | simpleErrorCallback e s = 364 | putStrLn $ unwords [show e, show s] 365 | 366 | keyIsPressed :: Window -> Key -> IO Bool 367 | keyIsPressed win key = isPress `fmap` GLFW.getKey win key 368 | 369 | isPress :: KeyState -> Bool 370 | isPress KeyState'Pressed = True 371 | isPress KeyState'Repeating = True 372 | isPress _ = False 373 | 374 | -- sounds 375 | -- music: https://www.freesound.org/people/Thirsk/sounds/121035/ 376 | -- shriek: https://www.freesound.org/people/dan2008ds/sounds/175169/ 377 | -- bite: https://www.freesound.org/people/dan2008ds/sounds/175169/ 378 | backgroundMusic :: Source -> IO () 379 | backgroundMusic source = do 380 | loopingMode source $= Looping 381 | play [source] 382 | 383 | paceToPitch :: StatusChange -> ALfloat 384 | paceToPitch Safe = 1 385 | paceToPitch Danger = 2 386 | 387 | playSounds :: Sounds -> SoundState -> IO () 388 | playSounds (Sounds musicSource shriekSource biteSource) (SoundState mbPace endOfGame hunting) = do 389 | changeBackgroundMusic musicSource mbPace 390 | when endOfGame $ playSound shriekSource 391 | if hunting then playContinuousSound biteSource 392 | else stop [biteSource] 393 | 394 | changeBackgroundMusic :: Source -> Maybe StatusChange -> IO () 395 | changeBackgroundMusic source (Just pace) = pitch source $= (paceToPitch pace) 396 | changeBackgroundMusic _ Nothing = return () 397 | 398 | playContinuousSound :: Source -> IO () 399 | playContinuousSound source = do 400 | state <- get (sourceState source) 401 | unless (state == Playing) $ play [source] 402 | 403 | playSound :: Source -> IO () 404 | playSound source = do 405 | play [source] 406 | -- Normally nothing should go wrong above, but one never knows... 407 | errs <- get alErrors 408 | unless (null errs) $ do 409 | hPutStrLn stderr (concat (intersperse "," [ d | ALError _ d <- errs ])) 410 | return () 411 | -------------------------------------------------------------------------------- /src/Shapes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | import "GLFW-b" Graphics.UI.GLFW as GLFW 3 | import Graphics.Gloss 4 | import Graphics.Gloss.Rendering 5 | import Graphics.Gloss.Data.Color 6 | import Graphics.Gloss.Data.Picture 7 | import System.Exit ( exitSuccess ) 8 | import Control.Concurrent (threadDelay) 9 | import Control.Monad (when, unless) 10 | 11 | windowWidth, windowHeight :: Int 12 | windowWidth = 640 13 | windowHeight = 480 14 | 15 | main :: IO () 16 | main = do 17 | glossState <- initState 18 | withWindow windowWidth windowHeight "Game-Demo" $ \win -> do 19 | loop glossState win 20 | exitSuccess 21 | where loop glossState window = do 22 | threadDelay 20000 23 | pollEvents 24 | renderFrame window glossState 25 | k <- keyIsPressed window Key'Escape 26 | unless k $ loop glossState window 27 | renderFrame :: Window -> State -> IO () 28 | renderFrame window glossState = do 29 | displayPicture (windowWidth, windowHeight) white glossState 1.0 $ 30 | Pictures 31 | [ Color violet $ translate (-300) 100 $ polygon [((-10), 10), ((-10), 70), (20, 20), (20, 30)] 32 | , Color red $ translate (-200) 100 $ line [(-30, -30), (-40, 30), (30, 40), (50, -20)] 33 | , Color (makeColor 0 128 255 1) $ translate (-100) 100 $ lineLoop [(-30, -30), (-40, 30), (30, 40), (50, -20)] 34 | , Color red $ translate 0 100 $ circle 30 35 | , Color green $ translate 100 100 $ thickCircle 30 10 36 | , Color yellow $ translate 200 100 $ circleSolid 30 37 | , Color chartreuse $ translate (-200) (-100) $ thickArc 0 180 30 30 38 | , Color (dark magenta) $ translate (-100) (-100) $ arcSolid 0 90 30 39 | , Color (bright magenta) $ translate 0 (-100) $ scale 0.2 0.2 $ text "Boo!" 40 | , Color (dim cyan) $ translate 100 (-100) $ rotate 30 $ rectangleWire 20 50 41 | , Color (light cyan) $ translate 200 (-100) $ rotate 60 $ rectangleSolid 20 50 ] 42 | swapBuffers window 43 | 44 | withWindow :: Int -> Int -> String -> (GLFW.Window -> IO ()) -> IO () 45 | withWindow width height title f = do 46 | GLFW.setErrorCallback $ Just simpleErrorCallback 47 | r <- GLFW.init 48 | when r $ do 49 | m <- GLFW.createWindow width height title Nothing Nothing 50 | case m of 51 | (Just win) -> do 52 | GLFW.makeContextCurrent m 53 | f win 54 | GLFW.setErrorCallback $ Just simpleErrorCallback 55 | GLFW.destroyWindow win 56 | Nothing -> return () 57 | GLFW.terminate 58 | where 59 | simpleErrorCallback e s = 60 | putStrLn $ unwords [show e, show s] 61 | 62 | keyIsPressed :: Window -> Key -> IO Bool 63 | keyIsPressed win key = isPress `fmap` GLFW.getKey win key 64 | 65 | isPress :: KeyState -> Bool 66 | isPress KeyState'Pressed = True 67 | isPress KeyState'Repeating = True 68 | isPress _ = False 69 | -------------------------------------------------------------------------------- /src/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | import "GLFW-b" Graphics.UI.GLFW as GLFW 3 | import Graphics.Gloss 4 | import Graphics.Gloss.Rendering as RS 5 | import System.Exit ( exitSuccess ) 6 | import Control.Concurrent (threadDelay) 7 | import Control.Monad (when, unless) 8 | import Control.Monad.State.Strict 9 | 10 | width, height :: Int 11 | width = 640 12 | height = 480 13 | 14 | type Pos = Point 15 | data Player = Player {position :: Pos} 16 | 17 | initialPlayer :: Player 18 | initialPlayer = Player (0,0) 19 | 20 | playerSize :: Float 21 | playerSize = 20 22 | 23 | main :: IO () 24 | main = do 25 | glossState <- initState 26 | withWindow width height "Game-Demo" $ \win -> do 27 | _ <- runStateT (loop win glossState) initialPlayer 28 | exitSuccess 29 | 30 | loop :: Window -> RS.State -> StateT Player IO () 31 | loop window glossState = do 32 | lift $ threadDelay 20000 33 | lift $ pollEvents 34 | k <- lift $keyIsPressed window Key'Escape 35 | l <- lift $keyIsPressed window Key'Left 36 | r <- lift $keyIsPressed window Key'Right 37 | u <- lift $keyIsPressed window Key'Up 38 | d <- lift $ keyIsPressed window Key'Down 39 | player <- get 40 | let newState = movePlayer (l,r,u,d) player 10 41 | put newState 42 | lift $ renderFrame newState window glossState 43 | unless k $ loop window glossState 44 | 45 | movePlayer :: (Bool, Bool, Bool, Bool) -> Player -> Float -> Player 46 | movePlayer direction player increment 47 | | outsideOfLimits (position (move direction player increment)) playerSize = player 48 | | otherwise = move direction player increment 49 | 50 | outsideOfLimits :: (Float, Float) -> Float -> Bool 51 | outsideOfLimits (xmon, ymon) size = xmon > fromIntegral width/2 - size/2 || 52 | xmon < (-(fromIntegral width)/2 + size/2) || 53 | ymon > fromIntegral height/2 - size/2 || 54 | ymon < (-(fromIntegral height)/2 + size/2) 55 | 56 | move :: (Bool, Bool, Bool, Bool) -> Player -> Float -> Player 57 | move (True, _, _, _) (Player (xpos, ypos)) increment = Player ((xpos - increment), ypos) 58 | move (_, True, _, _) (Player (xpos, ypos)) increment = Player ((xpos + increment), ypos) 59 | move (_, _, True, _) (Player (xpos, ypos)) increment = Player (xpos, (ypos + increment)) 60 | move (_, _, _, True) (Player (xpos, ypos)) increment = Player (xpos, (ypos - increment)) 61 | move (False, False, False, False) (Player (xpos, ypos)) _ = Player (xpos, ypos) 62 | 63 | renderFrame :: Player -> Window -> RS.State -> IO () 64 | renderFrame (Player (xpos, ypos)) window glossState = do 65 | displayPicture (width, height) white glossState 1.0 $ translate xpos ypos $ rectangleSolid playerSize playerSize 66 | swapBuffers window 67 | 68 | withWindow :: Int -> Int -> String -> (GLFW.Window -> IO ()) -> IO () 69 | withWindow windowWidth windowHeight title f = do 70 | GLFW.setErrorCallback $ Just simpleErrorCallback 71 | r <- GLFW.init 72 | when r $ do 73 | m <- GLFW.createWindow windowWidth windowHeight title Nothing Nothing 74 | case m of 75 | (Just win) -> do 76 | GLFW.makeContextCurrent m 77 | f win 78 | GLFW.setErrorCallback $ Just simpleErrorCallback 79 | GLFW.destroyWindow win 80 | Nothing -> return () 81 | GLFW.terminate 82 | where 83 | simpleErrorCallback e s = 84 | putStrLn $ unwords [show e, show s] 85 | 86 | keyIsPressed :: Window -> Key -> IO Bool 87 | keyIsPressed win key = isPress `fmap` GLFW.getKey win key 88 | 89 | isPress :: KeyState -> Bool 90 | isPress KeyState'Pressed = True 91 | isPress KeyState'Repeating = True 92 | isPress _ = False 93 | -------------------------------------------------------------------------------- /src/StateFRP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports, RecursiveDo #-} 2 | import "GLFW-b" Graphics.UI.GLFW as GLFW 3 | import Graphics.Gloss 4 | import Graphics.Gloss.Rendering 5 | import System.Exit ( exitSuccess ) 6 | import Control.Concurrent (threadDelay) 7 | import Control.Monad (when, unless, join) 8 | import Control.Monad.Fix (fix) 9 | import Control.Applicative ((<*>), (<$>)) 10 | import FRP.Elerea.Simple 11 | import Foreign.C.Types (CDouble(..)) 12 | import System.Random 13 | 14 | type Pos = Point 15 | data Player = Player { position :: Pos } 16 | type Hunting = Bool 17 | data Monster = Monster Pos MonsterStatus 18 | deriving Show 19 | 20 | data MonsterStatus = Wander Direction Int 21 | | Hunting 22 | deriving Show 23 | data Direction = WalkUp | WalkDown | WalkLeft | WalkRight 24 | deriving (Show, Enum, Bounded) 25 | 26 | instance Random Direction where 27 | randomR (a, b) g = case randomR (fromEnum a, fromEnum b) g of 28 | (x, g') -> (toEnum x, g') 29 | random g = randomR (minBound, maxBound) g 30 | 31 | initialPlayer = Player (0, 0) 32 | 33 | initialMonster :: Monster 34 | initialMonster = Monster (200, 200) (Wander WalkUp wanderDist) 35 | width :: Int 36 | width = 640 37 | height :: Int 38 | height = 480 39 | playerSize :: Float 40 | playerSize = 20 41 | monsterSize :: Float 42 | monsterSize = 20 43 | monsterSpeed :: Float 44 | monsterSpeed = 5 45 | 46 | 47 | main :: IO () 48 | main = do 49 | (directionKeyGen, directionKeySink) <- external (False, False, False, False) 50 | randomGenerator <- newStdGen 51 | glossState <- initState 52 | 53 | withWindow width height "Game-Demo" $ \win -> do 54 | network <- start $ do 55 | directionKey <- directionKeyGen 56 | hunted win directionKey randomGenerator glossState 57 | fix $ \loop -> do 58 | readInput win directionKeySink 59 | join network 60 | threadDelay 20000 61 | esc <- keyIsPressed win Key'Escape 62 | unless esc loop 63 | exitSuccess 64 | 65 | hunted win directionKey randomGenerator glossState = mdo 66 | player <- transfer2 initialPlayer (movePlayer 10) directionKey gameOver' 67 | randomNumber <- stateful (undefined, randomGenerator) nextRandom 68 | monster <- transfer3 initialMonster wanderOrHunt player randomNumber gameOver' 69 | gameOver <- memo (playerEaten <$> player <*> monster) 70 | gameOver' <- delay False gameOver 71 | return $ renderFrame win glossState <$> player <*> monster <*> gameOver 72 | where playerEaten player monster = distance player monster < (10^2 :: Float) 73 | nextRandom (a, g) = random g 74 | 75 | readInput :: Window -> ((Bool, Bool, Bool, Bool) -> IO b) -> IO b 76 | readInput window directionKeySink = do 77 | pollEvents 78 | l <- keyIsPressed window Key'Left 79 | r <- keyIsPressed window Key'Right 80 | u <- keyIsPressed window Key'Up 81 | d <- keyIsPressed window Key'Down 82 | directionKeySink (l, r, u, d) 83 | 84 | movePlayer :: Float -> (Bool, Bool, Bool, Bool) -> Bool -> Player -> Player 85 | movePlayer _ _ True player = player 86 | movePlayer increment direction False player 87 | | outsideOfLimits (position (move direction player increment)) playerSize = player 88 | | otherwise = move direction player increment 89 | 90 | outsideOfLimits :: (Float, Float) -> Float -> Bool 91 | outsideOfLimits (xmon, ymon) size = xmon > fromIntegral width/2 - size/2 || 92 | xmon < (-(fromIntegral width)/2 + size/2) || 93 | ymon > fromIntegral height/2 - size/2 || 94 | ymon < (-(fromIntegral height)/2 + size/2) 95 | 96 | move :: (Bool, Bool, Bool, Bool) -> Player -> Float -> Player 97 | move (True, _, _, _) (Player (xpos, ypos)) increment = Player ((xpos - increment), ypos) 98 | move (_, True, _, _) (Player (xpos, ypos)) increment = Player ((xpos + increment), ypos) 99 | move (_, _, True, _) (Player (xpos, ypos)) increment = Player (xpos, (ypos + increment)) 100 | move (_, _, _, True) (Player (xpos, ypos)) increment = Player (xpos, (ypos - increment)) 101 | move (False, False, False, False) (Player (xpos, ypos)) _ = Player (xpos, ypos) 102 | 103 | wanderDist :: Int 104 | wanderDist = 40 105 | huntingDist :: Float 106 | huntingDist = 100 107 | 108 | wanderOrHunt :: Player 109 | -> (Direction, b) -> Bool -> Monster -> Monster 110 | wanderOrHunt _ _ True monster = monster 111 | wanderOrHunt player (r, _) False monster = if close player monster 112 | then hunt player monster 113 | else wander r monster 114 | 115 | close :: Player -> Monster -> Bool 116 | close player monster = distance player monster < huntingDist^2 117 | 118 | distance :: Player -> Monster -> Float 119 | distance (Player (xpos, ypos)) (Monster (xmon, ymon) _) = (xpos - xmon)^2 + (ypos - ymon)^2 120 | 121 | -- if player is upper left quadrant, diagonal left 122 | -- means xpos > xmon and ypos > ymon 123 | hunt :: Player -> Monster -> Monster 124 | hunt (Player (xpos, ypos)) (Monster (xmon, ymon) _) = Monster ((xmon + (signum (xpos - xmon))*monsterSpeed), (ymon + (signum (ypos - ymon))*monsterSpeed)) Hunting 125 | 126 | -- turn in random direction 127 | wander :: Direction -> Monster -> Monster 128 | wander r (Monster (xmon, ymon) (Wander _ 0)) = Monster (xmon, ymon) (Wander r wanderDist) 129 | wander r (Monster (xmon, ymon) Hunting) = Monster (xmon, ymon) (Wander r wanderDist) 130 | -- go straight 131 | wander _ (Monster (xmon, ymon) (Wander direction n)) = do 132 | let currentDirection = continueDirection direction (outsideOfLimits (xmon, ymon) monsterSize) 133 | Monster 134 | (stepInCurrentDirection currentDirection (xmon, ymon) monsterSpeed) 135 | (Wander currentDirection (n-1)) 136 | 137 | continueDirection :: Direction -> Bool -> Direction 138 | continueDirection WalkUp True = WalkDown 139 | continueDirection WalkDown True = WalkUp 140 | continueDirection WalkLeft True = WalkRight 141 | continueDirection WalkRight True = WalkLeft 142 | continueDirection direction False = direction 143 | 144 | stepInCurrentDirection :: Num a => 145 | Direction -> (a, a) -> a -> (a, a) 146 | stepInCurrentDirection WalkUp (xpos, ypos) speed = (xpos, ypos + speed) 147 | stepInCurrentDirection WalkDown (xpos, ypos) speed = (xpos, ypos - speed) 148 | stepInCurrentDirection WalkLeft (xpos, ypos) speed = (xpos - speed, ypos) 149 | stepInCurrentDirection WalkRight (xpos, ypos) speed = (xpos + speed, ypos) 150 | 151 | renderFrame :: Window 152 | -> State -> Player -> Monster -> Bool -> IO () 153 | renderFrame window glossState (Player (xpos, ypos)) (Monster (xmon, ymon) status) gameOver = do 154 | displayPicture (width, height) white glossState 1.0 $ 155 | Pictures $ gameOngoing gameOver 156 | [renderPlayer xpos ypos, 157 | renderMonster status xmon ymon] 158 | swapBuffers window 159 | 160 | renderPlayer :: Float -> Float -> Picture 161 | renderPlayer xpos ypos = Color black $ translate xpos ypos $ rectangleSolid playerSize playerSize 162 | 163 | renderMonster :: MonsterStatus -> Float -> Float -> Picture 164 | renderMonster status xpos ypos = Color (monsterColor status) $ translate xpos ypos $ circleSolid playerSize 165 | where monsterColor Hunting = red 166 | monsterColor (Wander _ _) = green 167 | 168 | -- adds gameover text if appropriate 169 | gameOngoing :: Bool -> [Picture] -> [Picture] 170 | gameOngoing gameOver pics = if gameOver then pics ++ [Color black $ translate (-100) 0 $ Scale 0.3 0.3 $ Text "Game Over"] 171 | else pics 172 | 173 | withWindow :: Int -> Int -> String -> (GLFW.Window -> IO ()) -> IO () 174 | withWindow width height title f = do 175 | GLFW.setErrorCallback $ Just simpleErrorCallback 176 | r <- GLFW.init 177 | when r $ do 178 | m <- GLFW.createWindow width height title Nothing Nothing 179 | case m of 180 | (Just win) -> do 181 | GLFW.makeContextCurrent m 182 | f win 183 | GLFW.setErrorCallback $ Just simpleErrorCallback 184 | GLFW.destroyWindow win 185 | Nothing -> return () 186 | GLFW.terminate 187 | where 188 | simpleErrorCallback e s = 189 | putStrLn $ unwords [show e, show s] 190 | 191 | keyIsPressed :: Window -> Key -> IO Bool 192 | keyIsPressed win key = isPress `fmap` GLFW.getKey win key 193 | 194 | isPress :: KeyState -> Bool 195 | isPress KeyState'Pressed = True 196 | isPress KeyState'Repeating = True 197 | isPress _ = False 198 | -------------------------------------------------------------------------------- /src/Testing/Backend.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | module Testing.Backend ( 3 | withWindow 4 | , readInput 5 | , replayInput 6 | , exitKeyPressed 7 | , swapBuffers 8 | ) where 9 | 10 | import "GLFW-b" Graphics.UI.GLFW as GLFW 11 | import Control.Monad (when) 12 | import Control.Applicative ((<$>), (<*>)) 13 | import Control.Concurrent (MVar, tryTakeMVar) 14 | import Data.Maybe (isJust) 15 | import Testing.GameTypes 16 | import Data.Time.Clock.POSIX 17 | 18 | withWindow :: Int 19 | -> Int 20 | -> ((Int, Int) -> IO ()) 21 | -> String 22 | -> (Window -> IO ()) 23 | -> IO () 24 | withWindow width height windowSizeSink title f = do 25 | GLFW.setErrorCallback $ Just simpleErrorCallback 26 | r <- GLFW.init 27 | when r $ do 28 | m <- GLFW.createWindow width height title Nothing Nothing 29 | case m of 30 | (Just win) -> do 31 | GLFW.makeContextCurrent m 32 | setWindowSizeCallback win $ Just $ resize windowSizeSink 33 | f win 34 | GLFW.setErrorCallback $ Just simpleErrorCallback 35 | GLFW.destroyWindow win 36 | Nothing -> return () 37 | GLFW.terminate 38 | where 39 | simpleErrorCallback e s = 40 | putStrLn $ unwords [show e, show s] 41 | 42 | resize :: ((Int, Int) -> IO()) -> Window -> Int -> Int -> IO() 43 | resize windowSizeSink _ w h = windowSizeSink (w, h) 44 | 45 | keyIsPressed :: Window -> Key -> IO Bool 46 | keyIsPressed win key = isPress `fmap` GLFW.getKey win key 47 | 48 | isPress :: KeyState -> Bool 49 | isPress KeyState'Pressed = True 50 | isPress KeyState'Repeating = True 51 | isPress _ = False 52 | 53 | readInput :: Window 54 | -> ((Bool, Bool, Bool, Bool) -> IO ()) 55 | -> ((Bool, Bool, Bool, Bool) -> IO ()) 56 | -> ((Int, Bool) -> IO ()) 57 | -> ((Int, Bool, Bool) -> IO ()) 58 | -> (Maybe Command -> IO ()) 59 | -> MVar Command 60 | -> IO () 61 | readInput window directionKeySink shootKeySink snapshotSink recordSink commandSink commandVar = do 62 | pollEvents 63 | directionKeySink =<< (,,,) <$> keyIsPressed window Key'Left 64 | <*> keyIsPressed window Key'Right 65 | <*> keyIsPressed window Key'Up 66 | <*> keyIsPressed window Key'Down 67 | shootKeySink =<< (,,,) <$> keyIsPressed window Key'A 68 | <*> keyIsPressed window Key'D 69 | <*> keyIsPressed window Key'W 70 | <*> keyIsPressed window Key'S 71 | 72 | startRecording <- keyIsPressed window Key'R 73 | endRecording <- keyIsPressed window Key'E 74 | timestamp <- round `fmap` getPOSIXTime 75 | 76 | snapshotting <- keyIsPressed window Key'T 77 | snapshotSink (timestamp, snapshotting) 78 | recordSink (timestamp, startRecording, endRecording) 79 | 80 | mbCommand <- tryTakeMVar commandVar 81 | when (isJust mbCommand) $ print mbCommand 82 | commandSink mbCommand 83 | 84 | replayInput :: Window 85 | -> ExternalInput 86 | -> ((Bool, Bool, Bool, Bool) -> IO ()) 87 | -> ((Bool, Bool, Bool, Bool) -> IO ()) 88 | -> ((Int, Bool) -> IO ()) 89 | -> ((Int, Bool, Bool) -> IO ()) 90 | -> (Maybe Command -> IO ()) 91 | -> IO () 92 | replayInput win 93 | (ExternalInput directionKey shootKey) 94 | directionKeySink 95 | shootKeySink 96 | snapshotSink 97 | recordSink 98 | commandSink = do 99 | pollEvents 100 | directionKeySink directionKey 101 | shootKeySink shootKey 102 | snapshotSink (0, False) 103 | recordSink (0, False, False) 104 | commandSink Nothing 105 | 106 | exitKeyPressed :: Window -> IO Bool 107 | exitKeyPressed window = keyIsPressed window Key'Escape 108 | -------------------------------------------------------------------------------- /src/Testing/CommandLine.hs: -------------------------------------------------------------------------------- 1 | module Testing.CommandLine ( 2 | interactiveCommandLine 3 | ) where 4 | 5 | import Testing.GameTypes 6 | import Testing.Internals.CommandParser 7 | import System.Console.Haskeline 8 | import Control.Concurrent (MVar, putMVar) 9 | import Control.Monad.IO.Class 10 | import Data.Text (pack) 11 | 12 | interactiveCommandLine :: MVar Command -> IO () 13 | interactiveCommandLine commandVar = do 14 | runInputT defaultSettings loop 15 | putStrLn "interactive command line loop ended" 16 | where 17 | loop :: InputT IO () 18 | loop = do 19 | minput <- getInputLine "% " 20 | case minput of 21 | Nothing -> return () 22 | Just "quit" -> return () 23 | Just input -> do case parseCommand (pack input) of 24 | Right command -> liftIO $ putMVar commandVar command 25 | Left error -> outputStrLn $ error 26 | loop 27 | -------------------------------------------------------------------------------- /src/Testing/Game.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecursiveDo #-} 2 | {-# LANGUAGE PackageImports #-} 3 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 4 | module Testing.Game ( 5 | defaultStart 6 | , hunted 7 | ) where 8 | 9 | import Testing.Internals.Game 10 | -------------------------------------------------------------------------------- /src/Testing/GameTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 3 | module Testing.GameTypes where 4 | 5 | import System.Random 6 | import Graphics.Gloss.Data.ViewPort 7 | import Data.Monoid 8 | import Data.Aeson 9 | import GHC.Generics 10 | 11 | type Pos = (Int, Int) 12 | data Vec num = Vec num num 13 | 14 | dist :: Pos -> Pos -> Int 15 | dist (x1, y1) (x2, y2) = (x2 - x1)^2 + (y2 - y1)^2 16 | 17 | times :: Int -> Pos -> Pos 18 | times a (x,y) = (a*x, a*y) 19 | infixl 7 `times` 20 | 21 | plus :: Pos -> Pos -> Pos 22 | plus (a,b) (c,d) = getTupleSum $ (Sum a, Sum b) <> (Sum c, Sum d) 23 | where getTupleSum (x, y) = (getSum x, getSum y) 24 | infixl 6 `plus` 25 | 26 | type Health = Int 27 | 28 | data Player = Player { position :: Pos, movement :: Maybe PlayerMovement, shootDirection :: Maybe Direction } 29 | deriving (Show, Generic) 30 | instance FromJSON Player 31 | instance ToJSON Player 32 | 33 | data PlayerMovement = PlayerMovement { dir :: Direction, step :: WalkStage } 34 | deriving (Show, Generic) 35 | instance FromJSON PlayerMovement 36 | instance ToJSON PlayerMovement 37 | 38 | data WalkStage = One | Two | Three | Four 39 | deriving (Show, Eq, Enum, Bounded, Generic) 40 | instance FromJSON WalkStage 41 | instance ToJSON WalkStage 42 | 43 | circular :: (Eq x, Enum x, Bounded x) => x -> x 44 | circular x = if x == maxBound then minBound else succ x 45 | 46 | data Monster = Monster Pos MonsterStatus Health 47 | deriving Show 48 | 49 | data MonsterStatus = Wander Direction Int 50 | | Hunting Direction 51 | deriving Show 52 | data Direction = WalkUp | WalkDown | WalkLeft | WalkRight 53 | deriving (Show, Enum, Bounded, Eq, Generic) 54 | instance FromJSON Direction 55 | instance ToJSON Direction 56 | 57 | instance Random Direction where 58 | randomR (a, b) g = case randomR (fromEnum a, fromEnum b) g of 59 | (x, g') -> (toEnum x, g') 60 | random g = randomR (minBound, maxBound) g 61 | 62 | data RenderState = RenderState { renderState_player :: Player 63 | , renderState_monster :: [Monster] 64 | , renderState_ending :: Maybe Ending 65 | , renderState_viewport :: ViewPort 66 | , renderState_bolts :: [Bolt] 67 | , renderState_lives :: Int 68 | , renderState_score :: Int 69 | , renderState_animation :: Maybe Animation 70 | , renderState_windowSize :: (Int, Int) 71 | , renderState_levelCount :: LevelStatus 72 | , renderState_recording :: Bool } 73 | | StartRenderState (Int, Int) 74 | data SoundState = SoundState { mood :: (Maybe StatusChange) 75 | , playerScreams :: Bool 76 | , hunting :: Bool 77 | , monsterDies :: Bool 78 | , shoot :: Bool 79 | , hit :: Bool } 80 | | StartSoundState 81 | 82 | data GameState = GameState RenderState SoundState 83 | 84 | data StatusChange = Danger | Safe 85 | 86 | type Range = Int 87 | data Bolt = Bolt Pos Direction Range Bool 88 | deriving Show 89 | 90 | data Ending = Win | Lose 91 | deriving (Show, Eq) 92 | 93 | data LevelStatus = Level Int 94 | deriving (Show, Generic) 95 | instance FromJSON LevelStatus 96 | instance ToJSON LevelStatus 97 | 98 | data GameStatus = Start | InGame 99 | deriving (Show, Generic) 100 | instance FromJSON GameStatus 101 | instance ToJSON GameStatus 102 | 103 | data Animation = DeathAnimation Float | NextLevelAnimation LevelStatus Float 104 | deriving (Show, Generic) 105 | instance FromJSON Animation 106 | instance ToJSON Animation 107 | 108 | data StartState = StartState { gameStatusSignal :: GameStatus 109 | , levelCountSignal :: LevelStatus 110 | , livesSignal :: Int 111 | , scoreSignal :: Int 112 | , playerSignal :: Player 113 | , monsterPos :: Maybe [Pos] 114 | , animationSignal :: Maybe Animation 115 | , viewportTranslateSignal :: Pos } 116 | deriving (Show, Generic) 117 | 118 | instance FromJSON StartState 119 | instance ToJSON StartState 120 | 121 | data ExternalInput = ExternalInput (Bool, Bool, Bool, Bool) (Bool, Bool, Bool, Bool) 122 | deriving (Show, Generic) 123 | 124 | instance FromJSON ExternalInput 125 | instance ToJSON ExternalInput 126 | 127 | data Command = LivesCommand Int 128 | | PlayerPosCommand (Int, Int) 129 | deriving (Show, Eq) 130 | -------------------------------------------------------------------------------- /src/Testing/Graphics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE PackageImports #-} 3 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 4 | module Testing.Graphics ( 5 | loadTextures 6 | , initState 7 | , renderFrame 8 | , Textures 9 | ) where 10 | 11 | import Testing.GameTypes 12 | import Testing.Backend (swapBuffers) 13 | import "GLFW-b" Graphics.UI.GLFW as GLFW 14 | import Graphics.Gloss hiding (play) 15 | import Graphics.Gloss.Rendering 16 | import Graphics.Gloss.Data.ViewPort 17 | import Control.Applicative ((<*>), (<$>)) 18 | import qualified Data.Map.Strict as Map 19 | 20 | data TextureSet = TextureSet { front :: Picture, back :: Picture, left :: Picture, right :: Picture } 21 | | PlayerTextureSet { fronts :: WalkingTexture, backs :: WalkingTexture, lefts :: WalkingTexture, rights :: WalkingTexture } 22 | 23 | data WalkingTexture = WalkingTexture { neutral :: ShootingTexture, walkLeft :: ShootingTexture, walkRight :: ShootingTexture } 24 | data ShootingTexture = ShootingTexture { shootDown :: Picture, shootUp :: Picture, shootLeft :: Picture, shootRight :: Picture } 25 | 26 | data Textures = Textures { background :: Picture 27 | , playerTextures :: TextureSet 28 | , monsterWalking :: TextureSet 29 | , monsterHunting :: TextureSet 30 | , deadMonster :: Picture 31 | , texts :: Map.Map String Picture 32 | , boltTextures :: TextureSet } 33 | 34 | loadTextures :: IO Textures 35 | loadTextures = do 36 | playerTextureSet <- PlayerTextureSet <$> loadWalkingTexture "front" 37 | <*> loadWalkingTexture "back" 38 | <*> loadWalkingTexture "left" 39 | <*> loadWalkingTexture "right" 40 | monsterWalkingSet <- TextureSet <$> loadBMP "images/monster-walking-front.bmp" 41 | <*> loadBMP "images/monster-walking-back.bmp" 42 | <*> loadBMP "images/monster-walking-left.bmp" 43 | <*> loadBMP "images/monster-walking-right.bmp" 44 | -- moves diagonally, so only 2 textures needed technically 45 | monsterHuntingSet <- TextureSet <$> loadBMP "images/monster-hunting-left.bmp" 46 | <*> loadBMP "images/monster-hunting-right.bmp" 47 | <*> loadBMP "images/monster-hunting-left.bmp" 48 | <*> loadBMP "images/monster-hunting-right.bmp" 49 | deadMonsterTexture <- loadBMP "images/dead-monster.bmp" 50 | boltSet <- TextureSet <$> loadBMP "images/bolt-down.bmp" 51 | <*> loadBMP "images/bolt-up.bmp" 52 | <*> loadBMP "images/bolt-left.bmp" 53 | <*> loadBMP "images/bolt-right.bmp" 54 | backgroundTexture <- loadBMP "images/background-tile.bmp" 55 | gameOverText <- loadBMP "images/game-over.bmp" 56 | recordingText <- loadBMP "images/recording.bmp" 57 | return Textures { background = backgroundTexture 58 | , playerTextures = playerTextureSet 59 | , monsterWalking = monsterWalkingSet 60 | , monsterHunting = monsterHuntingSet 61 | , deadMonster = deadMonsterTexture 62 | , texts = foldr (\(text, texture) textureMap -> Map.insert text texture textureMap) 63 | Map.empty 64 | [ ("recording", recordingText), 65 | ("game-over", gameOverText) ] 66 | , boltTextures = boltSet } 67 | 68 | loadWalkingTexture :: String -> IO WalkingTexture 69 | loadWalkingTexture facing = do 70 | let pathFn faces shooting animationphase = "images/knight-" ++ faces ++ animationphase ++ "-crossbow-" ++ shooting ++ ".bmp" 71 | paths = map (pathFn facing) ["front", "back", "left", "right"] 72 | shootingTexture [a,b,c,d] = ShootingTexture a b c d 73 | shootingTexture _ = error "no other arrays allowed" 74 | WalkingTexture <$> (shootingTexture <$> (sequence $ map (\p -> loadBMP $ p "") paths)) 75 | <*> (shootingTexture <$> (sequence $ map (\p -> loadBMP $ p "-1") paths)) 76 | <*> (shootingTexture <$> (sequence $ map (\p -> loadBMP $ p "-3") paths)) 77 | 78 | -- again, need to export gloss internal state for this signature, pull request required 79 | renderFrame :: GLFW.Window -> State -> Textures -> (Int, Int) -> RenderState -> IO () 80 | 81 | renderFrame window 82 | glossState 83 | textures 84 | (worldWidth, worldHeight) 85 | (RenderState {..}) = do 86 | displayPicture renderState_windowSize black glossState (viewPortScale renderState_viewport) $ 87 | Pictures $ animation renderState_animation renderState_windowSize 88 | $ gameOngoing renderState_ending renderState_lives (texts textures) 89 | $ gameStats renderState_lives renderState_score renderState_windowSize 90 | $ recordingDisplay renderState_recording (texts textures) renderState_windowSize $ 91 | [ uncurry translate (viewPortTranslate renderState_viewport) $ tiledBackground (background textures) worldWidth worldHeight 92 | , Pictures $ map (uncurry translate (viewPortTranslate renderState_viewport) . (renderBolt (boltTextures textures))) renderState_bolts 93 | , renderPlayer renderState_player (playerTextures textures) 94 | , uncurry translate (viewPortTranslate renderState_viewport) $ Pictures $ map (renderMonster (monsterWalking textures) (monsterHunting textures) (deadMonster textures)) renderState_monster 95 | , uncurry translate (viewPortTranslate renderState_viewport) $ Pictures $ map renderHealthBar renderState_monster ] 96 | swapBuffers window 97 | 98 | renderFrame window glossState _ _ (StartRenderState dimensions) = do 99 | displayPicture dimensions black glossState 1 $ 100 | Pictures [ Color green $ translate (-140) 0 $ scale 0.4 0.4 $ Text "Hunting Season" 101 | , Color green $ translate (-140) (-50) $ scale 0.1 0.1 $ Text "Press s to get started" ] 102 | swapBuffers window 103 | 104 | -- tiling: pictures translated to the appropriate locations to fill up the given width and heights 105 | -- I scaled the tile to the greatest common factor of the width and height, but it should work to fit the actual width and height 106 | -- which potentially means translating the tiles back a bit not to go over the edge 107 | tileSize :: Float 108 | tileSize = 160 109 | 110 | tiledBackground :: Picture -> Int -> Int -> Picture 111 | tiledBackground texture width height = Pictures $ map (\a -> ((uncurry translate) a) texture) $ translateMatrix (fromIntegral width) (fromIntegral height) 112 | 113 | -- what we want: 640, 480 114 | -- -320--x--(-160)--x--0--x--160--x--320 115 | -- -240 -80 80 240 116 | -- -240--x--(-80)--x--80--x--240 117 | -- -160 0 160 118 | translateMatrix :: Float -> Float -> [(Float, Float)] 119 | translateMatrix w h = concat $ map (zip xTiles) 120 | $ map (replicate (length xTiles)) yTiles 121 | where xTiles = [lowerbound w, lowerbound w + tileSize..higherbound w] 122 | yTiles = [lowerbound h, lowerbound h + tileSize..higherbound h] 123 | higherbound size = size/2 - tileSize/2 124 | lowerbound size = -(higherbound size) 125 | 126 | -- put crossbow behind player when he's facing up or profile, otherwise in front 127 | renderPlayer :: Player -> TextureSet -> Picture 128 | renderPlayer (Player _ (Just (PlayerMovement facing One)) shootDir) textureSet = shootDirectionTexture (Just facing) shootDir $ neutral $ playerDirectionTexture facing textureSet 129 | renderPlayer (Player _ (Just (PlayerMovement facing Two)) shootDir) textureSet = shootDirectionTexture (Just facing) shootDir $ walkLeft $ playerDirectionTexture facing textureSet 130 | renderPlayer (Player _ (Just (PlayerMovement facing Three)) shootDir) textureSet = shootDirectionTexture (Just facing) shootDir $ neutral $ playerDirectionTexture facing textureSet 131 | renderPlayer (Player _ (Just (PlayerMovement facing Four)) shootDir) textureSet = shootDirectionTexture (Just facing) shootDir $ walkRight $ playerDirectionTexture facing textureSet 132 | renderPlayer (Player _ Nothing shootDir) textureSet = shootDirectionTexture Nothing shootDir $ neutral $ fronts textureSet 133 | 134 | translateInt :: (Integral a2, Integral a1) => 135 | a1 -> a2 -> Picture -> Picture 136 | translateInt x y = translate (fromIntegral x) (fromIntegral y) 137 | 138 | renderMonster :: TextureSet -> TextureSet -> Picture -> Monster -> Picture 139 | renderMonster _ _ dead (Monster (xpos, ypos) _ 0) = translateInt xpos ypos $ dead 140 | renderMonster _ textureSet _ (Monster (xpos, ypos) (Hunting facing) _) = translateInt xpos ypos $ directionTexture facing textureSet 141 | renderMonster textureSet _ _ (Monster (xpos, ypos) (Wander WalkUp _) _) = translateInt xpos ypos $ back textureSet 142 | renderMonster textureSet _ _ (Monster (xpos, ypos) (Wander WalkDown _) _) = translateInt xpos ypos $ front textureSet 143 | renderMonster textureSet _ _ (Monster (xpos, ypos) (Wander WalkLeft n) _) = translateInt xpos ypos $ rotate (16* fromIntegral n) $ left textureSet 144 | renderMonster textureSet _ _ (Monster (xpos, ypos) (Wander WalkRight n) _) = translateInt xpos ypos $ rotate ((-16)* fromIntegral n) $ right textureSet 145 | 146 | renderBolt :: TextureSet -> Bolt -> Picture 147 | renderBolt textureSet (Bolt (xpos, ypos) facing _ _) = translateInt xpos ypos $ directionTexture facing textureSet 148 | 149 | directionTexture :: Direction -> TextureSet -> Picture 150 | directionTexture WalkUp = back 151 | directionTexture WalkDown = front 152 | directionTexture WalkLeft = left 153 | directionTexture WalkRight = right 154 | 155 | playerDirectionTexture :: Direction -> TextureSet -> WalkingTexture 156 | playerDirectionTexture WalkUp = backs 157 | playerDirectionTexture WalkDown = fronts 158 | playerDirectionTexture WalkLeft = lefts 159 | playerDirectionTexture WalkRight = rights 160 | 161 | shootDirectionTexture :: Maybe Direction -> Maybe Direction -> ShootingTexture -> Picture 162 | shootDirectionTexture _ (Just WalkDown) = shootDown 163 | shootDirectionTexture _ (Just WalkUp) = shootUp 164 | shootDirectionTexture _ (Just WalkLeft) = shootLeft 165 | shootDirectionTexture _ (Just WalkRight) = shootRight 166 | shootDirectionTexture Nothing Nothing = shootDown 167 | shootDirectionTexture facing Nothing = shootDirectionTexture Nothing facing 168 | 169 | -- [x x x x x] 170 | -- [0 0] 171 | -- 1 centered around xmon, size bar 172 | -- 2 centered around xmon - bar/2 + health/2 173 | numberOfLives :: Float 174 | numberOfLives = 4 175 | 176 | healthBarLength :: Float 177 | healthBarLength = 40 178 | 179 | healthBarWidth :: Float 180 | healthBarWidth = 5 181 | 182 | renderHealthBar :: Monster -> Picture 183 | renderHealthBar (Monster _ _ 0) = Pictures [] 184 | renderHealthBar (Monster (xmon, ymon) _ health) = Pictures [ translateInt xmon (ymon + 30) $ Color black $ rectangleSolid healthBarLength healthBarWidth 185 | , translate ((fromIntegral xmon) - healthBarLength/2 + (fromIntegral health)*healthBarLength/(numberOfLives*2)) ((fromIntegral ymon) + 30) $ Color red $ rectangleSolid ((fromIntegral health)*healthBarLength/numberOfLives) healthBarWidth ] 186 | 187 | -- adds gameover text if appropriate 188 | gameOngoing :: Maybe Ending -> Int -> Map.Map String Picture -> [Picture] -> [Picture] 189 | gameOngoing (Just Lose) 1 textTextures pics = pics ++ [translate (-50) 0 $ (textTextures Map.! "game-over")] 190 | gameOngoing (Just Lose) _ _ pics = pics ++ [Color black $ translate (-100) 0 $ Scale 0.3 0.3 $ Text "Aaargh"] 191 | gameOngoing (Just Win) _ _ pics = pics ++ [Color black $ translate (-100) 0 $ Scale 0.3 0.3 $ Text "You win!"] 192 | gameOngoing Nothing _ _ pics = pics 193 | 194 | recordingDisplay :: Bool -> Map.Map String Picture -> (Int, Int) -> [Picture] -> [Picture] 195 | recordingDisplay True textTextures (w,h) pics = pics ++ [ translate ((fromIntegral w)/2 - 200) ((-(fromIntegral h))/2 + 60) $ (textTextures Map.! "recording") ] 196 | recordingDisplay False _ _ pics = pics 197 | 198 | 199 | -- add score and lives 200 | -- lives are reprented by circles 201 | gameStats :: Int -> Int -> (Int, Int) -> [Picture] -> [Picture] 202 | gameStats lives score (w, h) pics = do 203 | let fWidth = fromIntegral w 204 | fHeight = fromIntegral h 205 | pics ++ [ Color black $ translate (fWidth/2 - 80) (fHeight/2 - 50) $ Scale 0.2 0.2 $ Text $ show score 206 | , Color (makeColor 1 1 1 0.5) $ translate ((-fWidth/2) + 80) (fHeight/2 - 40) $ rectangleSolid 250 40 207 | , Color black $ translate ((-fWidth)/2 + 20) (fHeight/2 - 50) $ Scale 0.2 0.2 $ Text "lives: "] 208 | ++ map (\i -> Color red $ translate ((-fWidth)/2 + 90 + 40*i) (fHeight/2 - 40) $ circleSolid 10) [0..(fromIntegral (lives - 1))] 209 | 210 | animation :: Maybe Animation -> (Int, Int) -> [Picture] -> [Picture] 211 | animation Nothing _ pics = pics 212 | animation (Just (DeathAnimation _)) _ pics = pics 213 | animation (Just (NextLevelAnimation l n)) (w, h) pics = pics ++ 214 | [ Color (animationColor n) $ rectangleSolid (fromIntegral w) (fromIntegral h) 215 | , Color white $ translate (-100) 0 $ scale 0.3 0.3 $ Text $ show l ] 216 | where animationColor i 217 | | n > 25 = makeColor 0 0 0 (0.04*(50-i)) 218 | | otherwise = makeColor 0 0 0 (0.04*i) 219 | -------------------------------------------------------------------------------- /src/Testing/Internals/CommandParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Testing.Internals.CommandParser where 3 | 4 | import Testing.GameTypes 5 | import Data.Attoparsec.Text 6 | import Data.Text 7 | import Control.Applicative ((<$>),(<*>), (*>), (<*), (<|>)) 8 | 9 | commandParser :: Parser Command 10 | commandParser = livesCommandParser <|> playerPosCommandParser 11 | 12 | livesCommandParser :: Parser Command 13 | livesCommandParser = LivesCommand <$> ("lives" *> skipSpace *> "=" *> skipSpace *> decimal) 14 | 15 | playerPosCommandParser :: Parser Command 16 | playerPosCommandParser = PlayerPosCommand <$>((,) 17 | <$> ("playerPos" *> skipSpace *> "=" *> skipSpace *> "(" *> signed decimal <* skipSpace <* ",") 18 | <*> (skipSpace *> signed decimal <* skipSpace <* ")")) 19 | 20 | parseCommand :: Text -> Either String Command 21 | parseCommand = parseOnly commandParser 22 | -------------------------------------------------------------------------------- /src/Testing/Internals/Game.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecursiveDo #-} 2 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 3 | {-# LANGUAGE PackageImports #-} 4 | module Testing.Internals.Game ( 5 | hunted 6 | , monsterHits 7 | , worldWidth 8 | , worldHeight 9 | , playerSpeed 10 | , playerSize 11 | , outsideOfLimits 12 | , movePlayer 13 | , defaultStart 14 | , initialViewport 15 | ) where 16 | import "GLFW-b" Graphics.UI.GLFW as GLFW 17 | import Graphics.Gloss() 18 | import Graphics.Gloss.Rendering 19 | import Testing.GameTypes 20 | import Testing.Sound 21 | import Testing.Graphics 22 | import FRP.Elerea.Simple as Elerea 23 | import Control.Monad (when) 24 | import Control.Applicative ((<$>), (<*>), liftA2, pure) 25 | import Data.Maybe (mapMaybe) 26 | import Data.Foldable (foldl') 27 | import Graphics.Gloss.Data.ViewPort 28 | import System.Random (random, RandomGen(..), randomRs) 29 | import Data.Maybe (fromMaybe) 30 | import Data.Aeson 31 | import Data.Time.Clock() 32 | import qualified Data.ByteString.Lazy as B (appendFile, writeFile, concat) 33 | import qualified Data.ByteString.Lazy.Char8 as BC (singleton) 34 | 35 | 36 | initialPlayer :: Player 37 | initialPlayer = Player (0, 0) Nothing Nothing 38 | 39 | initialMonster :: (Int, Int) -> Monster 40 | initialMonster pos = Monster pos (Wander WalkUp wanderDist) 4 41 | 42 | initialViewport :: Pos -> ViewPort 43 | initialViewport (x, y) = ViewPort { viewPortTranslate = (fromIntegral x, fromIntegral y), viewPortRotate = 0, viewPortScale = viewportScale } 44 | 45 | worldWidth :: Int 46 | worldWidth = 2560 47 | 48 | worldHeight :: Int 49 | worldHeight = 1920 50 | 51 | viewportScale :: Float 52 | viewportScale = 4 53 | 54 | playerSpeed :: Int 55 | playerSpeed = 10 56 | 57 | playerSize :: Int 58 | playerSize = 20 59 | 60 | monsterSize :: Int 61 | monsterSize = 20 62 | 63 | monsterSpeed :: Int 64 | monsterSpeed = 5 65 | 66 | wanderDist :: Int 67 | wanderDist = 45 68 | 69 | huntingDist :: Int 70 | huntingDist = 200 71 | 72 | boltRange :: Range 73 | boltRange = 20 74 | 75 | boltSpeed :: Int 76 | boltSpeed = 20 77 | 78 | initialLevel :: LevelStatus 79 | initialLevel = Level 1 80 | 81 | initialLives :: Int 82 | initialLives = 3 83 | 84 | defaultStart :: StartState 85 | defaultStart = StartState { gameStatusSignal = Start 86 | , levelCountSignal = initialLevel 87 | , livesSignal = initialLives 88 | , scoreSignal = 0 89 | , playerSignal = initialPlayer 90 | , monsterPos = Nothing 91 | , animationSignal = Nothing 92 | , viewportTranslateSignal = (0, 0) } 93 | 94 | {- 95 | -- GlossState needs to be exported 96 | -- Graphics.Gloss.Internals.Rendering.State 97 | -- pull request required 98 | -} 99 | -- expected: 100 | 101 | hunted :: (Show a, RandomGen p) => 102 | GLFW.Window 103 | -> Signal (Int, Int) 104 | -> Signal (Bool, Bool, Bool, Bool) 105 | -> Signal (Bool, Bool, Bool, Bool) 106 | -> p 107 | -> Testing.Graphics.Textures 108 | -> State 109 | -> Sounds 110 | -> StartState 111 | -> Signal (Int, Bool) 112 | -> Signal (a, Bool, Bool) 113 | -> Signal (Maybe Command) 114 | -> SignalGen (Signal (IO ())) 115 | 116 | 117 | hunted win windowSize directionKey shootKey randomGenerator textures glossState sounds startState snapshotSig recordKey commands = mdo 118 | let mkGame = playGame windowSize directionKey shootKey randomGenerator startState commands (snd <$> recordingData) 119 | (gameState, gameTrigger) <- switcher $ mkGame <$> gameStatus' 120 | gameStatus <- transfer (gameStatusSignal startState) gameProgress gameTrigger 121 | gameStatus' <- delay (gameStatusSignal startState) gameStatus 122 | 123 | snapshot <- edge (snd <$> snapshotSig) 124 | -- transform startRecording and endRecording in an recording signal 125 | startRecording <- edge ((\(_,s,_) -> s) <$> recordKey) 126 | endRecording <- edge ((\(_,_,s) -> s) <$> recordKey) 127 | let ts = (\(s, _, _) -> "data/log-" ++ show s) <$> recordKey 128 | recordingData <- transfer3 ("", False) isItRecording startRecording endRecording ts 129 | let snapshotData = (,) <$> (fst <$> snapshotSig) <*> ((||) <$> snapshot <*> startRecording) 130 | 131 | return $ outputFunction win glossState textures sounds <$> gameState <*> snapshotData <*> recordingData <*> directionKey <*> shootKey 132 | where gameProgress False s = s 133 | gameProgress True Start = InGame 134 | gameProgress True InGame = Start 135 | isItRecording True _ newName (_, False) = (newName, True) -- start recording 136 | isItRecording _ True _ (name, True) = (name, False) -- end recording 137 | isItRecording _ _ _ (name, current) = (name, current) -- ongoing 138 | 139 | 140 | playGame :: RandomGen t => 141 | Signal (Int, Int) 142 | -> Signal (Bool, Bool, Bool, Bool) 143 | -> Signal (Bool, Bool, Bool, Bool) 144 | -> t 145 | -> StartState 146 | -> Signal (Maybe Command) 147 | -> Signal Bool 148 | -> GameStatus 149 | -> SignalGen (Signal GameState, Signal Bool) 150 | -- start game when pressing s 151 | playGame windowSize _ shootKey _ _ _ _ Start = mdo 152 | let startGame = sIsPressed <$> shootKey 153 | renderState = StartRenderState <$> windowSize 154 | return (GameState <$> renderState <*> pure StartSoundState, startGame) 155 | where sIsPressed (_,_,_,s) = s 156 | 157 | -- bool should be gameOver 158 | playGame windowSize directionKey shootKey randomGenerator startState commands recording InGame = mdo 159 | (gameState, levelTrigger) <- switcher $ playLevel windowSize directionKey shootKey randomGenerator startState commands recording <$> levelCount' <*> score' <*> lives' 160 | levelCount <- transfer2 (levelCountSignal startState) levelProgression gameState levelTrigger 161 | levelCount' <- delay (levelCountSignal startState) levelCount 162 | lives <- transfer3 (livesSignal startState) decrementLives gameState levelTrigger commands 163 | lives' <- delay (livesSignal startState) lives 164 | score <- memo (stateScore <$> gameState) 165 | score' <- delay (scoreSignal startState) score 166 | let gameOver = isGameOver <$> gameState 167 | return (gameState, gameOver) 168 | where isGameOver (GameState (RenderState {renderState_lives = l}) _) = l == 0 169 | isGameOver (GameState (StartRenderState _) _) = False 170 | stateScore (GameState (RenderState {renderState_score = s}) _) = s 171 | stateScore (GameState (StartRenderState _) _) = 0 172 | decrementLives _ _ (Just (LivesCommand num)) l = num -- override 173 | decrementLives (GameState (RenderState {renderState_ending = Just Lose}) _) True _ l = l - 1 174 | decrementLives (GameState _ _) _ _ l = l 175 | 176 | 177 | 178 | -- level progression if triggered AND the player won 179 | levelProgression :: GameState -> Bool -> LevelStatus -> LevelStatus 180 | levelProgression _ False level = level 181 | levelProgression (GameState (RenderState {renderState_ending = Just Win}) _) True (Level n) = Level (n + 1) 182 | levelProgression (GameState (RenderState {renderState_ending = Just Lose}) _) True level = level 183 | levelProgression (GameState (RenderState {renderState_ending = Nothing}) _) True level = level 184 | levelProgression (GameState (StartRenderState _) _) _ level = level 185 | 186 | switcher :: Signal (SignalGen (Signal GameState, Signal Bool)) -> SignalGen (Signal GameState, Signal Bool) 187 | switcher levelGen = mdo 188 | trigger <- memo (snd =<< gameSignal) 189 | trigger' <- delay True trigger 190 | maybeSignal <- generator (toMaybe <$> trigger' <*> levelGen) 191 | gameSignal <- transfer undefined store maybeSignal 192 | return (fst =<< gameSignal, trigger) 193 | where store (Just x) _ = x 194 | store Nothing x = x 195 | toMaybe bool x = if bool then Just <$> x else pure Nothing 196 | 197 | playLevel :: RandomGen t => 198 | Signal (Int, Int) 199 | -> Signal (Bool, Bool, Bool, Bool) 200 | -> Signal (Bool, Bool, Bool, Bool) 201 | -> t 202 | -> StartState 203 | -> Signal (Maybe Command) 204 | -> Signal Bool 205 | -> LevelStatus 206 | -> Int 207 | -> Int 208 | -> SignalGen (Signal GameState, Signal Bool) 209 | playLevel windowSize directionKey shootKey randomGenerator startState commands recording level@(Level n) currentScore lives = mdo 210 | -- render signals 211 | let worldDimensions = (worldWidth, worldHeight) 212 | randomWidths = take n $ randomRs ((-worldWidth) `quot` 2 + monsterSize `quot` 2, (worldWidth `quot` 2) - monsterSize `quot` 2) randomGenerator :: [Int] 213 | randomHeights = take n $ randomRs ((-worldWidth) `quot` 2 + monsterSize `quot` 2, (worldWidth `quot` 2) - monsterSize `quot` 2) randomGenerator :: [Int] 214 | monsterPositions = zip randomWidths randomHeights 215 | startMonsterPositions = fromMaybe monsterPositions (monsterPos startState) 216 | player <- transfer4 initialPlayer (movePlayer playerSpeed worldDimensions) directionKey levelOver' shootKey commands 217 | randomNumber <- stateful (undefined, randomGenerator) nextRandom 218 | hits <- memo (fmap <$> (monsterHits <$> bolts') <*> monsters') 219 | monsters <- transfer4 (fmap initialMonster startMonsterPositions) (monsterWanderings worldDimensions) player randomNumber levelOver' hits 220 | monsters' <- delay (map initialMonster startMonsterPositions) monsters 221 | score <- transfer currentScore accumulateScore hits 222 | levelOver <- memo (levelEnds <$> player <*> monsters) 223 | levelOver' <- delay Nothing levelOver 224 | animation <- transfer (animationSignal startState) (endAnimation level) levelOver 225 | viewport <- transfer (initialViewport (viewportTranslateSignal startState)) viewPortMove player 226 | 227 | shoot <- edgify shootKey 228 | let bolt direction range startPosition = stateful (Bolt startPosition direction range False) moveBolt 229 | mkShot shot currentPlayer = if hasAny shot 230 | then (:[]) <$> bolt (dirFrom shot) boltRange (position currentPlayer) 231 | else return [] 232 | newBolts <- generator (mkShot <$> shoot <*> player) 233 | bolts <- collection newBolts (boltIsAlive worldDimensions <$> monsters) 234 | bolts' <- delay [] bolts 235 | 236 | -- sound signals 237 | statusChange <- transfer3 Nothing safeOrDanger monsters monsters' levelOver 238 | playerScreams <- Elerea.till ((== (Just Lose)) <$> levelOver) 239 | monsterScreams <- Elerea.till ((== (Just Win)) <$> levelOver) 240 | 241 | let actualLives = overridingLives lives <$> commands <*> actualLives' 242 | overridingLives lives (Just (LivesCommand num)) _ = num 243 | overridingLives _ _ previousLives = previousLives 244 | actualLives' <- delay lives actualLives 245 | let monsterIsHunting = (foldr (||) False) <$> (fmap <$> (stillHunting <$> levelOver) <*> monsters) 246 | renderState = RenderState <$> player 247 | <*> monsters 248 | <*> levelOver 249 | <*> viewport 250 | <*> bolts 251 | <*> actualLives 252 | <*> score 253 | <*> animation 254 | <*> windowSize 255 | <*> pure level 256 | <*> recording 257 | soundState = SoundState <$> statusChange 258 | <*> playerScreams 259 | <*> monsterIsHunting 260 | <*> monsterScreams 261 | <*> (hasAny <$> shoot) 262 | <*> (boltHit <$> monsters <*> bolts) 263 | 264 | return (GameState <$> renderState <*> soundState, animationEnd <$> animation) 265 | where playerEaten player monsters 266 | | any (\monster -> distance player monster < playerSize^2) monsters = Just Lose 267 | | otherwise = Nothing 268 | monstersDead monsters 269 | | all monsterDead monsters = Just Win 270 | | otherwise = Nothing 271 | monsterDead (Monster _ _ health) = health == 0 272 | levelEnds player monsters = maybe (monstersDead monsters) Just (playerEaten player monsters) 273 | nextRandom (_, g) = random g 274 | 275 | -- FRP 276 | 277 | collection :: (Signal [Signal Bolt]) -> Signal (Bolt -> Bool) -> SignalGen (Signal [Bolt]) 278 | collection source isAlive = mdo 279 | boltSignals <- delay [] (map snd <$> boltsAndSignals') 280 | -- bolts: SignalGen [Signal Bolt]) 281 | -- add new bolt signals 282 | bolts <- memo (liftA2 (++) source boltSignals) 283 | -- boltsAndSignals type: SignalGen (Signal [Bolt], [Signal Bolt]) 284 | let boltsAndSignals = zip <$> (sequence =<< bolts) <*> bolts 285 | -- filter out 286 | boltsAndSignals' <- memo (filter <$> ((.fst) <$> isAlive) <*> boltsAndSignals) 287 | -- return 288 | return $ map fst <$> boltsAndSignals' 289 | 290 | -- FRP 291 | 292 | hasAny :: (Bool, Bool, Bool, Bool) -> Bool 293 | hasAny (l, r, u, d) = l || r || u || d 294 | 295 | endAnimation :: LevelStatus -> Maybe Ending -> Maybe Animation -> Maybe Animation 296 | endAnimation _ _ (Just (DeathAnimation 0)) = Just (DeathAnimation 0) 297 | endAnimation _ _ (Just (NextLevelAnimation l 0)) = Just (NextLevelAnimation l 0) 298 | endAnimation _ _ (Just (DeathAnimation n)) = Just (DeathAnimation (n - 1)) 299 | endAnimation _ _ (Just (NextLevelAnimation l n)) = Just (NextLevelAnimation l (n - 1)) 300 | endAnimation _ (Just Lose) _ = Just $ DeathAnimation 50 301 | endAnimation (Level n) (Just Win) _ = Just $ NextLevelAnimation (Level (n+1)) 50 302 | endAnimation _ _ Nothing = Nothing 303 | 304 | animationEnd :: Maybe Animation -> Bool 305 | animationEnd (Just (DeathAnimation 0)) = True 306 | animationEnd (Just (NextLevelAnimation _ 0)) = True 307 | animationEnd _ = False 308 | 309 | moveBolt :: Bolt -> Bolt 310 | moveBolt (Bolt (xpos, ypos) direction range alreadyHit) = Bolt (boltSpeed `times` (stepInDirection direction) `plus` (xpos, ypos)) direction (range - 1) alreadyHit 311 | 312 | boltIsAlive :: (Int, Int) -> [Monster] -> Bolt -> Bool 313 | boltIsAlive worldDimensions monsters bolt = (not (any (\monster -> hasHit monster bolt) monsters)) && boltStillGoing worldDimensions bolt 314 | 315 | -- let it come closer so that the hit can be registered before removing the bolt 316 | hasHit :: Monster -> Bolt -> Bool 317 | hasHit (Monster (xmon, ymon) _ _) (Bolt (x, y) _ _ _) 318 | | dist (xmon, ymon) (x, y) < ((monsterSize `quot` 4)^2) = True 319 | | otherwise = False 320 | 321 | edge :: Signal Bool 322 | -> SignalGen (Signal Bool) 323 | edge s = do 324 | s' <- delay False s 325 | return $ s' >>= \x -> if x then return False else s 326 | 327 | edgify :: Signal (Bool, Bool, Bool, Bool) 328 | -> SignalGen (Signal (Bool, Bool, Bool, Bool)) 329 | edgify s = do 330 | s' <- delay (False, False, False, False) s 331 | return $ s' >>= \x -> throttle x s 332 | 333 | throttle :: (Bool, Bool, Bool, Bool) -> Signal (Bool, Bool, Bool, Bool) -> Signal (Bool, Bool, Bool, Bool) 334 | throttle shot sig 335 | | hasAny shot = return (False, False, False, False) 336 | | otherwise = sig 337 | 338 | -- boltStillGoing depends on the bolt range and on whether it hit the monster 339 | boltStillGoing :: (Int, Int) -> Bolt -> Bool 340 | boltStillGoing (width, height) (Bolt (x, y) _ range alreadyHit) = 341 | (not alreadyHit) && (range > 0) && x < width `quot` 2 && y < height `quot` 2 342 | 343 | stillHunting :: Maybe Ending -> Monster -> Bool 344 | stillHunting (Just _) _ = False 345 | stillHunting _ (Monster _ (Hunting _) 0) = False 346 | stillHunting Nothing (Monster _ (Hunting _) _) = True 347 | stillHunting Nothing _ = False 348 | 349 | viewPortMove :: Player -> ViewPort -> ViewPort 350 | viewPortMove (Player (x,y) _ _) (ViewPort { viewPortTranslate = _, viewPortRotate = rotation, viewPortScale = scaled }) = 351 | ViewPort { viewPortTranslate = (fromIntegral (-x), fromIntegral (-y)), viewPortRotate = rotation, viewPortScale = scaled } 352 | 353 | movePlayer :: Int 354 | -> (Int, Int) 355 | -> (Bool, Bool, Bool, Bool) 356 | -> Maybe Ending 357 | -> (Bool, Bool, Bool, Bool) 358 | -> Maybe Command 359 | -> Player 360 | -> Player 361 | movePlayer _ _ _ _ _ (Just (PlayerPosCommand pos)) player = player {position = pos} -- override 362 | movePlayer _ _ _ (Just _) _ _ player = player 363 | movePlayer increment dimensions direction Nothing shootDir _ player 364 | | outsideOfLimits dimensions (position (move direction shootDir player increment)) playerSize = player 365 | | otherwise = move direction shootDir player increment 366 | 367 | outsideOfLimits :: (Int, Int) -> (Int, Int) -> Int -> Bool 368 | outsideOfLimits (width, height) (xmon, ymon) size = xmon > width `quot` 2 - size `quot` 2 || 369 | xmon < (-(width) `quot` 2 + size `quot` 2) || 370 | ymon > height `quot` 2 - size `quot` 2 || 371 | ymon < (-(height) `quot` 2 + size `quot` 2) 372 | 373 | move :: (Bool, Bool, Bool, Bool) -> (Bool, Bool, Bool, Bool) -> Player -> Int -> Player 374 | move (False, False, False, False) sK (Player (xpos, ypos) _ _) _ = Player (xpos, ypos) Nothing (crossbowPointed sK) 375 | move keys sK (Player (xpos, ypos) (Just (PlayerMovement direction n)) _) increment 376 | | dirFrom keys == direction = Player ((xpos, ypos) `plus` increment `times` stepInDirection direction) (Just $ PlayerMovement direction (circular n)) (crossbowPointed sK) 377 | | otherwise = Player ((xpos, ypos) `plus` increment `times` stepInDirection (dirFrom keys)) (Just $ PlayerMovement (dirFrom keys) One) (crossbowPointed sK) 378 | move keys sK (Player (xpos, ypos) Nothing _) increment = Player ((xpos, ypos) `plus` increment `times` stepInDirection (dirFrom keys)) (Just $ PlayerMovement (dirFrom keys) One) (crossbowPointed sK) 379 | 380 | crossbowPointed :: (Bool, Bool, Bool, Bool) -> Maybe Direction 381 | crossbowPointed (a,d,w,s) 382 | | w = Just WalkUp 383 | | s = Just WalkDown 384 | | a = Just WalkLeft 385 | | d = Just WalkRight 386 | | otherwise = Nothing 387 | 388 | dirFrom :: (Bool, Bool, Bool, Bool) -> Direction 389 | dirFrom (l, r, u, d) 390 | | l = WalkLeft 391 | | r = WalkRight 392 | | u = WalkUp 393 | | d = WalkDown 394 | | otherwise = error "no direction from keys" 395 | 396 | stepInDirection :: Direction -> (Int, Int) 397 | stepInDirection WalkLeft = (-1, 0) 398 | stepInDirection WalkRight = (1, 0) 399 | stepInDirection WalkUp = (0, 1) 400 | stepInDirection WalkDown = (0, -1) 401 | 402 | hitOrMiss :: Int -> Monster -> Monster 403 | hitOrMiss hits (Monster (xmon, ymon) status health) = 404 | Monster (xmon, ymon) status (health - hits) 405 | 406 | monsterHits :: [Bolt] -> Monster -> Int 407 | monsterHits bolts monster = fromIntegral $ length 408 | $ filter (<= (monsterSize `quot` 2)^2) (boltDistances monster (filter notCounted bolts)) 409 | where notCounted (Bolt _ _ _ alreadyHit) = not alreadyHit 410 | 411 | accumulateScore :: [Int] -> Int -> Int 412 | accumulateScore hits score = score + sum hits 413 | 414 | boltDistances :: Monster -> [Bolt] -> [Int] 415 | boltDistances (Monster (xmon, ymon) _ _) bolts = 416 | map (\(Bolt (xbolt, ybolt) _ _ _) -> dist (xmon, ymon) (xbolt, ybolt)) bolts 417 | 418 | boltHit :: [Monster] -> [Bolt] -> Bool 419 | boltHit monsters bolts = any (== True) $ concat $ map (\monster -> map (< (monsterSize `quot` 2)^2) (boltDistances monster bolts)) monsters 420 | 421 | monsterWanderings :: RandomGen t => (Int, Int) -> Player -> (Direction, t) -> Maybe Ending -> [Int] -> [Monster] -> [Monster] 422 | monsterWanderings dim p gen ending hits monsters = map (wanderOrHunt dim p gen ending) (zip hits monsters) 423 | 424 | wanderOrHunt :: System.Random.RandomGen t => 425 | (Int, Int) 426 | -> Player 427 | -> (Direction, t) 428 | -> Maybe Ending 429 | -> (Int, Monster) 430 | -> Monster 431 | -- game ended 432 | wanderOrHunt _ _ _ (Just _) (_, monster) = monster 433 | 434 | -- no health left: dead 435 | wanderOrHunt _ _ _ _ (_, monster@(Monster _ _ 0)) = monster 436 | 437 | -- normal game 438 | wanderOrHunt dimensions player (r, _) Nothing (hits, monster) = do 439 | let monsterHit = hitOrMiss hits monster 440 | if close player monsterHit 441 | then hunt player monsterHit 442 | else wander r monsterHit dimensions 443 | 444 | close :: Player -> Monster -> Bool 445 | close player monster = distance player monster < huntingDist^2 446 | 447 | distance :: Player -> Monster -> Int 448 | distance (Player (xpos, ypos) _ _) (Monster (xmon, ymon) _ _) = dist (xpos, ypos) (xmon, ymon) 449 | 450 | -- if player is upper left quadrant, diagonal left 451 | -- means xpos > xmon and ypos > ymon 452 | hunt :: Player -> Monster -> Monster 453 | hunt (Player (xpos, ypos) _ _) (Monster (xmon, ymon) _ health) = Monster ((xmon + (signum (xpos - xmon))*monsterSpeed), (ymon + (signum (ypos - ymon))*monsterSpeed)) (Hunting $ huntingDirection (signum (xpos - xmon)) (signum (ypos - ymon))) health 454 | 455 | huntingDirection :: Int -> Int -> Direction 456 | huntingDirection (-1) (-1) = WalkLeft 457 | huntingDirection (-1) 1 = WalkLeft 458 | huntingDirection 1 (-1) = WalkRight 459 | huntingDirection 1 1 = WalkRight 460 | huntingDirection (-1) _ = WalkLeft 461 | huntingDirection _ _ = WalkRight 462 | 463 | -- turn in random direction 464 | wander :: Direction -> Monster -> (Int, Int) -> Monster 465 | wander r (Monster (xmon, ymon) (Wander _ 0) health) _ = Monster (xmon, ymon) (Wander r wanderDist) health 466 | wander r (Monster (xmon, ymon) (Hunting _) health) _ = Monster (xmon, ymon) (Wander r wanderDist) health 467 | -- go straight 468 | wander _ (Monster (xmon, ymon) (Wander direction n) health) dimensions = do 469 | let currentDirection = continueDirection direction (outsideOfLimits dimensions (xmon, ymon) monsterSize) 470 | Monster 471 | (stepInCurrentDirection currentDirection (xmon, ymon) monsterSpeed) 472 | (Wander currentDirection (n-1)) 473 | health 474 | 475 | continueDirection :: Direction -> Bool -> Direction 476 | continueDirection WalkUp True = WalkDown 477 | continueDirection WalkDown True = WalkUp 478 | continueDirection WalkLeft True = WalkRight 479 | continueDirection WalkRight True = WalkLeft 480 | continueDirection direction False = direction 481 | 482 | stepInCurrentDirection :: Direction -> (Int, Int) -> Int -> Pos 483 | stepInCurrentDirection direction (xpos, ypos) speed = speed `times` (stepInDirection direction) `plus` (xpos, ypos) 484 | 485 | safeOrDanger :: [Monster] -> [Monster] -> Maybe Ending -> Maybe StatusChange -> Maybe StatusChange 486 | safeOrDanger _ _ (Just _) _ = Just Safe 487 | safeOrDanger monsters monsters' _ _ = do 488 | let statusChanges = mapMaybe monitorStatusChange (zip monsters monsters') 489 | foldl' dominatingChanges Nothing statusChanges 490 | where dominatingChanges _ Danger = Just Danger 491 | dominatingChanges (Just Danger) Safe = Just Danger 492 | dominatingChanges _ Safe = Just Safe 493 | 494 | monitorStatusChange :: (Monster, Monster) -> Maybe StatusChange 495 | monitorStatusChange ((Monster _ _ num), (Monster _ _ 0)) = if num > 0 then Just Safe else Nothing 496 | monitorStatusChange ((Monster _ (Hunting _) _), (Monster _ (Wander _ _) _)) = Just Danger 497 | monitorStatusChange ((Monster _ (Wander _ _) _), (Monster _ (Hunting _) _)) = Just Safe 498 | monitorStatusChange _ = Nothing 499 | 500 | -- output functions 501 | outputFunction :: GLFW.Window 502 | -> State 503 | -> Testing.Graphics.Textures 504 | -> Sounds 505 | -> GameState 506 | -> (Int, Bool) 507 | -> (String, Bool) 508 | -> (Bool, Bool, Bool, Bool) 509 | -> (Bool, Bool, Bool, Bool) 510 | -> IO () 511 | outputFunction window glossState textures sounds (GameState renderState soundState) snapshot record directionKey shootKey = 512 | (renderFrame window glossState textures (worldWidth, worldHeight) renderState) >> 513 | playSounds sounds soundState >> 514 | recordState snapshot renderState >> 515 | recordEvents record directionKey shootKey 516 | 517 | recordState :: (Int, Bool) -> RenderState -> IO () 518 | recordState (_, False) _ = return () 519 | recordState (ts, True) renderState = 520 | B.writeFile ("data/start-" ++ show ts) $ 521 | encode $ renderToStartState renderState 522 | 523 | renderToStartState :: RenderState -> StartState 524 | renderToStartState (StartRenderState _) = defaultStart 525 | renderToStartState (RenderState player monsters _ viewport _ lives score animation _ levelCount _) = 526 | StartState { gameStatusSignal = InGame 527 | , levelCountSignal = levelCount 528 | , livesSignal = lives 529 | , scoreSignal = score 530 | , playerSignal = player 531 | , monsterPos = Just $ map (\(Monster p _ _) -> p) monsters 532 | , animationSignal = animation 533 | , viewportTranslateSignal = (\(x,y) -> (round x, round y)) $ viewPortTranslate viewport } 534 | 535 | recordEvents :: (String, Bool) 536 | -> (Bool, Bool, Bool, Bool) 537 | -> (Bool, Bool, Bool, Bool) 538 | -> IO () 539 | recordEvents (name, recording) directionKey shootKey = when recording $ do 540 | B.appendFile name $ 541 | B.concat [encode (ExternalInput directionKey shootKey), BC.singleton '\n'] 542 | -------------------------------------------------------------------------------- /src/Testing/Main.hs: -------------------------------------------------------------------------------- 1 | import Testing.Sound 2 | import Testing.Backend 3 | import Testing.Graphics 4 | import Testing.Game 5 | import Testing.CommandLine 6 | 7 | import System.Exit ( exitSuccess ) 8 | import System.Random 9 | import Control.Concurrent (threadDelay) 10 | import Control.Monad (unless, join, when) 11 | import Control.Monad.Fix (fix) 12 | import FRP.Elerea.Simple as Elerea 13 | import Testing.GameTypes 14 | import Options 15 | import Control.Applicative ((<*>), pure) 16 | import Control.Concurrent (forkIO, newEmptyMVar) 17 | import Data.Aeson 18 | import Data.Maybe (fromMaybe, isJust, fromJust) 19 | import qualified Data.ByteString.Lazy as B (readFile) 20 | import qualified Data.ByteString.Lazy.Char8 as BC (lines) 21 | 22 | width :: Int 23 | width = 640 24 | 25 | height :: Int 26 | height = 480 27 | 28 | data MainOptions = MainOptions { 29 | optStartFile :: Maybe String 30 | , optInteractive :: Bool 31 | , optLog :: Maybe String 32 | } deriving Show 33 | 34 | instance Options.Options MainOptions where 35 | defineOptions = pure MainOptions 36 | <*> simpleOption "start-state" Nothing 37 | "file containing start state" 38 | <*> simpleOption "interactive" False 39 | "start an interactive session" 40 | <*> simpleOption "log" Nothing 41 | "file containing input logs" 42 | 43 | getStartState :: MainOptions -> IO StartState 44 | getStartState opts = if (isJust (optStartFile opts)) 45 | then fmap (\mb -> fromMaybe defaultStart mb) $ fmap decode $ B.readFile (fromJust (optStartFile opts)) 46 | else return defaultStart 47 | 48 | main :: IO () 49 | main = runCommand $ \opts _ -> do 50 | print opts 51 | startState <- getStartState opts 52 | commandVar <- newEmptyMVar 53 | when (optInteractive opts) $ do 54 | _ <- forkIO (interactiveCommandLine commandVar) 55 | return () 56 | (snapshotGen, snapshotSink) <- external (0,False) 57 | (recordGen, recordSink) <- external (0, False, False) 58 | (commandsGen, commandSink) <- external Nothing 59 | (directionKeyGen, directionKeySink) <- external (False, False, False, False) 60 | (shootKeyGen, shootKeySink) <- external (False, False, False, False) 61 | (windowSizeGen,windowSizeSink) <- external (fromIntegral width, fromIntegral height) 62 | randomGenerator <- newStdGen 63 | glossState <- initState 64 | textures <- loadTextures 65 | withWindow width height windowSizeSink "Game-Demo" $ \win -> do 66 | withSound $ \_ _ -> do 67 | sounds <- loadSounds 68 | backgroundMusic (backgroundTune sounds) 69 | network <- start $ do 70 | snapshot <- snapshotGen 71 | record <- recordGen 72 | commands <- commandsGen 73 | directionKey <- directionKeyGen 74 | shootKey <- shootKeyGen 75 | windowSize <- windowSizeGen 76 | hunted win 77 | windowSize 78 | directionKey 79 | shootKey 80 | randomGenerator 81 | textures 82 | glossState 83 | sounds 84 | startState 85 | snapshot 86 | record 87 | commands 88 | if (isJust (optLog opts)) 89 | then do 90 | inputs <- externalInputs (fromJust (optLog opts)) 91 | (flip mapM_) inputs $ \input -> do 92 | replayInput win input directionKeySink shootKeySink snapshotSink recordSink commandSink 93 | join network 94 | threadDelay 20000 95 | else 96 | fix $ \loop -> do 97 | readInput win directionKeySink shootKeySink snapshotSink recordSink commandSink commandVar 98 | join network 99 | threadDelay 20000 100 | esc <- exitKeyPressed win 101 | unless esc loop 102 | exitSuccess 103 | 104 | externalInputs :: String 105 | -> IO [ExternalInput] 106 | externalInputs file = fmap (map decodeOrThrow) $ fmap BC.lines $ B.readFile file 107 | where decodeOrThrow string = case (decode string :: Maybe ExternalInput) of 108 | Just x -> x 109 | Nothing -> error $ "Log file contains line that can't be decoded: " ++ show string 110 | -------------------------------------------------------------------------------- /src/Testing/Sound.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Testing.Sound ( 3 | withSound 4 | , loadSounds 5 | , backgroundMusic 6 | , playSounds 7 | , Sounds(..) 8 | ) where 9 | 10 | import Testing.GameTypes 11 | 12 | import Sound.ALUT hiding (Static) 13 | import System.IO ( hPutStrLn, stderr ) 14 | import Data.List (intersperse) 15 | import Control.Monad (when, unless) 16 | import Control.Monad.IO.Class (MonadIO(..)) 17 | import Control.Applicative ((<$>), (<*>)) 18 | 19 | data Sounds = Sounds { backgroundTune :: Source 20 | , shriek :: Source 21 | , bite :: Source 22 | , groan :: Source 23 | , twang :: Source 24 | , thump :: Source } 25 | 26 | -- convenience function to abstract the ALUT context 27 | withSound :: forall a. Runner IO a 28 | withSound = withProgNameAndArgs runALUT 29 | 30 | -- sounds 31 | -- music: https://www.freesound.org/people/Thirsk/sounds/121035/ 32 | -- shriek: https://www.freesound.org/people/dan2008ds/sounds/175169/ 33 | -- bite: https://www.freesound.org/people/dan2008ds/sounds/175169/ 34 | -- twang https://www.freesound.org/people/cubic.archon/sounds/44192/ 35 | -- thump https://www.freesound.org/people/fons/sounds/101362/ 36 | -- groan https://www.freesound.org/people/dag451/sounds/118336/ 37 | 38 | loadSounds :: IO Sounds 39 | loadSounds = do 40 | biteSource <- loadSound "sounds/bite.wav" 41 | sourceGain biteSource $= 0.5 42 | Sounds <$> loadSound "sounds/oboe-loop.wav" 43 | <*> loadSound "sounds/shriek.wav" 44 | <*> return biteSource 45 | <*> loadSound "sounds/groan.wav" 46 | <*> loadSound "sounds/twang.wav" 47 | <*> loadSound "sounds/thump.wav" 48 | 49 | loadSound :: FilePath -> IO Source 50 | loadSound path = do 51 | buf <- createBuffer (File path) 52 | source <- genObjectName 53 | buffer source $= Just buf 54 | return source 55 | 56 | backgroundMusic :: Source -> IO () 57 | backgroundMusic source = do 58 | loopingMode source $= Looping 59 | play [source] 60 | 61 | -- ALUT internal float format 62 | paceToPitch :: StatusChange -> ALfloat 63 | paceToPitch Safe = 1 64 | paceToPitch Danger = 2 65 | 66 | playSounds :: Sounds -> SoundState -> IO () 67 | playSounds _ StartSoundState = return () 68 | playSounds sounds soundState = do 69 | changeBackgroundMusic (backgroundTune sounds) (mood soundState) 70 | when (playerScreams soundState) $ playSound (shriek sounds) 71 | when (monsterDies soundState) $ playSound (groan sounds) 72 | when (shoot soundState) $ playSound (twang sounds) 73 | when (hit soundState) $ playSound (thump sounds) 74 | if (hunting soundState) then playContinuousSound (bite sounds) 75 | else stop [bite sounds] 76 | 77 | changeBackgroundMusic :: Source -> Maybe StatusChange -> IO () 78 | changeBackgroundMusic source (Just pace) = pitch source $= (paceToPitch pace) 79 | changeBackgroundMusic _ Nothing = return () 80 | 81 | playContinuousSound :: Source -> IO () 82 | playContinuousSound source = do 83 | state <- get (sourceState source) 84 | unless (state == Playing) $ play [source] 85 | 86 | playSound :: Source -> IO () 87 | playSound source = do 88 | play [source] 89 | -- Normally nothing should go wrong above, but one never knows... 90 | errs <- get alErrors 91 | unless (null errs) $ do 92 | hPutStrLn stderr (concat (intersperse "," [ d | ALError _ d <- errs ])) 93 | return () 94 | -------------------------------------------------------------------------------- /test/HUnit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main where 4 | 5 | import Test.HUnit hiding (test) 6 | import Test.Framework.Providers.HUnit 7 | import Test.Framework.TH 8 | import Test.Framework 9 | 10 | -- actual code 11 | import Testing.Internals.Game 12 | import Testing.GameTypes 13 | import Testing.Internals.CommandParser 14 | 15 | main = $defaultMainGenerator 16 | 17 | case_NoBolts = 0 @=? monsterHits [] 18 | (Monster (0,0) (Wander WalkUp 2) 2) 19 | 20 | case_NoHits = 0 @=? monsterHits [ Bolt (100, 100) WalkUp 4 False 21 | , Bolt (200, 200) WalkDown 3 False ] 22 | (Monster (0,0) (Hunting WalkUp) 2) 23 | 24 | case_OneHit = 1 @=? monsterHits [ Bolt (100, 100) WalkUp 4 False 25 | , Bolt (5,5) WalkDown 3 False ] 26 | (Monster (0,0) (Hunting WalkUp) 2) 27 | 28 | case_AlreadyHit = 0 @=? monsterHits [ Bolt (100, 100) WalkUp 4 False 29 | , Bolt (5,5) WalkDown 3 True ] 30 | (Monster (0,0) (Hunting WalkUp) 2) 31 | 32 | case_LivesCommand = Right (LivesCommand 5) @=? parseCommand "lives = 5" 33 | 34 | case_playerPosCommand = Right (PlayerPosCommand (100,100)) @=? parseCommand "playerPos = (100, 100)" 35 | case_playerPosCommand_neg = Right (PlayerPosCommand ((-100),(-100))) @=? parseCommand "playerPos = (-100, -100)" 36 | -------------------------------------------------------------------------------- /test/Properties.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | import Test.QuickCheck 4 | import Test.QuickCheck.Function 5 | import Test.Framework.TH 6 | import Test.Framework.Providers.QuickCheck2 7 | 8 | import Control.Applicative ((<$>), (<*>)) 9 | 10 | import Testing.GameTypes 11 | import Testing.Internals.Game 12 | 13 | -- movePlayer always stays inside the playing field 14 | 15 | 16 | prop_insideLimits move player@(Player (x,y) _ _) = 17 | (x > ((-worldWidth) `quot` 2 + playerSize `quot` 2)) && 18 | (x < (worldWidth `quot` 2 - playerSize `quot` 2)) && 19 | (y > ((-worldHeight) `quot` 2 + playerSize `quot` 2)) && 20 | (y < (worldHeight `quot` 2 - playerSize `quot` 2)) ==> 21 | not $ (\p -> outsideOfLimits (worldWidth, worldHeight) p playerSize) 22 | $ position 23 | $ movePlayer playerSpeed (worldWidth, worldHeight) move Nothing (False, False, False, False) Nothing player 24 | 25 | instance Arbitrary Player where 26 | arbitrary = Player <$> arbitrary 27 | <*> arbitrary 28 | <*> arbitrary 29 | 30 | instance Arbitrary PlayerMovement where 31 | arbitrary = PlayerMovement <$> arbitrary 32 | <*> arbitrary 33 | instance Arbitrary Direction where 34 | arbitrary = elements [WalkUp, WalkDown, WalkLeft, WalkRight] 35 | 36 | instance Arbitrary WalkStage where 37 | arbitrary = elements [One, Two, Three, Four] 38 | 39 | main :: IO () 40 | main = $defaultMainGenerator 41 | -------------------------------------------------------------------------------- /test/hlint.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import Language.Haskell.HLint 5 | import System.Environment 6 | import System.Exit 7 | 8 | main :: IO () 9 | main = do 10 | args <- getArgs 11 | hints <- hlint $ ["src", "--cpp-define=HLINT", "--cpp-ansi"] ++ args 12 | unless (null hints) exitFailure 13 | --------------------------------------------------------------------------------