cadence (empty) → 0.1.0.0
raw patch · 24 files changed
+3408/−0 lines, 24 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HUnit, QuickCheck, aeson, apecs, base, bytestring, cadence, containers, exceptions, hspec, hspec-contrib, linear, random, random-shuffle, sdl2, sdl2-image, sdl2-ttf, template-haskell, text, vector
Files
- CHANGELOG.md +11/−0
- LICENSE +26/−0
- README.md +27/−0
- Setup.hs +2/−0
- cadence.cabal +144/−0
- examples/hungeon/Combat.hs +256/−0
- examples/hungeon/Dungeon.hs +121/−0
- examples/hungeon/Enemy.hs +62/−0
- examples/hungeon/GameMap.hs +421/−0
- examples/hungeon/Input.hs +63/−0
- examples/hungeon/Main.hs +28/−0
- examples/hungeon/Menu.hs +67/−0
- examples/hungeon/Settings.hs +81/−0
- examples/hungeon/Systems.hs +320/−0
- examples/hungeon/Types.hs +279/−0
- examples/hungeon/Utils.hs +154/−0
- examples/noughts-and-crosses.lhs +587/−0
- src/Cadence.hs +22/−0
- src/Cadence/Draw.hs +207/−0
- src/Cadence/Font.hs +34/−0
- src/Cadence/Systems.hs +167/−0
- src/Cadence/Texture.hs +57/−0
- src/Cadence/Types.hs +138/−0
- test/Spec.hs +134/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `cadence`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2026 Author name here++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,27 @@+# Cadence++`cadence` is a video game framework built on-top Apecs and SDL, providing tools to allow people to get up and running easily with `apecs` and `sdl2` for 2D game development in Haskell. More specifically, the package provides tools to minimise the boilerplate of SDL, and allow users to cleanly do rendering using a Type system. Additionally, since under the hood the package uses `sdl2`, users are able to freely control the window, renderer, etc. through utilising `sdl2`'s API.++## High-Level Overview++Below is a high-level overview of what `cadence` currently provides:+- Built-in rendering - through using a Type system and `apecs` Component system, users are able to avoid manually doing rendering calls in SDL by calling a single function to do it for them, allowing for layered rendering, camera manipulation, and more. This rendering is also optimised, such as employing frustum culling.+- Automated frame handling and running of game loop - `cadence` exposes a `run` function which handles frame deltas, exact time deltas, and more to accurately run your game loop to the desired frame rate, with frame-independent time deltas.+- Automated animation handling - textures simply need to be specified as an Animation, and `cadence` will handle the progressing of animations through sprite sheets for you, as well as the displaying of them during the rendering pipeline.+- Streamlined asset loading - textures and fonts can be loaded easily into corresponding maps, making use of the flyweight pattern for optimised memory usage, and reducing errors on your end.++## Links++Below are links to help people get familiar with the package and what it provides, as well as Apecs and SDL:+- [Documentation](https://hackage.haskell.org/package/cadence/docs/Cadence.html)+- [Tutorial](https://github.com/NicholasMason-Apps/cadence/blob/main/examples/noughts-and-crosses.md)+- [Apecs hackage page](https://hackage.haskell.org/package/apecs)+- [SDL2 hackage page](https://hackage.haskell.org/package/sdl2)+- [SDL2 TTF hackage page](https://hackage.haskell.org/package/sdl2-ttf)+- [SDL2 Image hackage page](https://hackage.haskell.org/package/sdl2-image)++## Examples++Two examples are currently bundled with Cadence. To run them, clone the repository and execute either of the following:+- `stack run noughts-and-crosses`+- `stack run hungeon`
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cadence.cabal view
@@ -0,0 +1,144 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name: cadence+version: 0.1.0.0+synopsis: An ECS-based 2D game framework+description: Please see the README on GitHub at <https://github.com/NicholasMason-Apps/cadence#readme>+category: Game, Game Engine+homepage: https://github.com/NicholasMason-Apps/cadence#readme+bug-reports: https://github.com/NicholasMason-Apps/cadence/issues+author: Nicholas Mason-Apps+maintainer: nicholas.masonapps1@gmail.com+copyright: 2026 Nicholas Mason-Apps+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/NicholasMason-Apps/cadence++library+ exposed-modules:+ Cadence+ Cadence.Draw+ Cadence.Font+ Cadence.Systems+ Cadence.Texture+ Cadence.Types+ other-modules:+ Paths_cadence+ autogen-modules:+ Paths_cadence+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+ build-depends:+ apecs >=0.9.6 && <0.10+ , base >=4.7 && <5+ , containers >=0.6.7 && <0.7+ , linear >=1.22 && <1.24+ , sdl2 >=2.5.5 && <2.6+ , sdl2-image >=2.1.0 && <2.2+ , sdl2-ttf >=2.1.3 && <2.2+ , template-haskell >=2.20.0 && <2.21+ , text >=2.0.2 && <2.1+ , vector >=0.13.1 && <0.14+ default-language: Haskell2010++executable hungeon+ main-is: Main.hs+ other-modules:+ Combat+ Dungeon+ Enemy+ GameMap+ Input+ Menu+ Settings+ Systems+ Types+ Utils+ Paths_cadence+ autogen-modules:+ Paths_cadence+ hs-source-dirs:+ examples/hungeon+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=--nonmoving-gc+ build-depends:+ aeson >=2.1.2.1 && <2.3+ , apecs >=0.9.6 && <0.10+ , base >=4.7 && <5+ , bytestring >=0.11.5 && <0.12+ , cadence+ , containers >=0.6.7 && <0.7+ , linear >=1.22 && <1.24+ , random >=1.2.1.3 && <1.4+ , random-shuffle >=0.0.4 && <0.1+ , sdl2 >=2.5.5 && <2.6+ , sdl2-image >=2.1.0 && <2.2+ , sdl2-ttf >=2.1.3 && <2.2+ , template-haskell >=2.20.0 && <2.21+ , text >=2.0.2 && <2.1+ , vector >=0.13.1 && <0.14+ default-language: Haskell2010++executable noughts-and-crosses+ main-is: noughts-and-crosses.lhs+ other-modules:+ Paths_cadence+ autogen-modules:+ Paths_cadence+ hs-source-dirs:+ examples+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ apecs >=0.9.6 && <0.10+ , base >=4.7 && <5+ , cadence+ , containers >=0.6.7 && <0.7+ , linear >=1.22 && <1.24+ , random >=1.2.1.3 && <1.4+ , sdl2 >=2.5.5 && <2.6+ , sdl2-image >=2.1.0 && <2.2+ , sdl2-ttf >=2.1.3 && <2.2+ , template-haskell >=2.20.0 && <2.21+ , text >=2.0.2 && <2.1+ , vector >=0.13.1 && <0.14+ default-language: Haskell2010++test-suite cadence-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_cadence+ autogen-modules:+ Paths_cadence+ hs-source-dirs:+ test+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ HUnit+ , QuickCheck+ , apecs >=0.9.6 && <0.10+ , base >=4.7 && <5+ , cadence+ , containers >=0.6.7 && <0.7+ , exceptions+ , hspec+ , hspec-contrib+ , linear >=1.22 && <1.24+ , sdl2 >=2.5.5 && <2.6+ , sdl2-image >=2.1.0 && <2.2+ , sdl2-ttf >=2.1.3 && <2.2+ , template-haskell >=2.20.0 && <2.21+ , text >=2.0.2 && <2.1+ , vector >=0.13.1 && <0.14+ default-language: Haskell2010
+ examples/hungeon/Combat.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Combat where++import Apecs+import Linear+import Types+import Utils+import Control.Monad+import Data.Maybe ( isJust, fromMaybe, isNothing )+import qualified Data.Set as Set+import qualified Data.Map as Map+import Cadence++playerKnifeAttackFrames :: Set.Set Int+playerKnifeAttackFrames = Set.fromList [7]++playerMagicAttackFrames :: Set.Set Int+playerMagicAttackFrames = Set.fromList [6]++enemySkeletonAttackFrames :: Set.Set Int+enemySkeletonAttackFrames = Set.fromList [7]++enemyVampireAttackFrames :: Set.Set Int+enemyVampireAttackFrames = Set.fromList [11]++enemyReaperAttackFrames :: Set.Set Int+enemyReaperAttackFrames = Set.fromList [6, 11]++enemyGoldenReaperAttackFrames :: Set.Set Int+enemyGoldenReaperAttackFrames = Set.fromList [6, 11]++playerShieldFrames :: Set.Set Int+playerShieldFrames = Set.fromList [1,2,3]++playerDamage :: Int+playerDamage = 20++enemyDamage :: Int+enemyDamage = 5++bossDamage :: Int+bossDamage = 15++stepPlayerTurn :: Float -> System' ()+stepPlayerTurn dT = do+ KeysPressed ks <- get global+ uiState <- get global :: System' UIState+ case uiState of+ CombatAttackSelectUI -> do+ when (GkSpace `Set.member` ks) $ do+ set global $ KeysPressed (GkSpace `Set.delete` ks)+ set global $ CombatTurn PlayerAttacking+ cmapM_ $ \(CombatPlayer, s) -> do+ set s (Texture RenTexture { textureRef = "player-knife-attack", animationFrame = Just 0 })+ set s (Position (combatEnemyPos - V2 tileSize 0))+ parryUI+ when (GkE `Set.member` ks) $ do+ set global CombatMagicSelectUI+ cmap $ \(CombatUI, r) -> case r of+ Texture rt -> Texture rt { textureRef = "combat-magic-select-ui" }+ _ -> r+ set global $ KeysPressed (GkE `Set.delete` ks)+ CombatMagicSelectUI -> do+ when (GkE `Set.member` ks) $ do+ set global $ CombatTurn PlayerAttacking+ set global CombatAttackSelectUI+ set global $ KeysPressed (GkE `Set.delete` ks)+ cmapM_ $ \(CombatPlayer, s) -> set s (Texture RenTexture { textureRef = "player-fire-attack", animationFrame = Just 0 })+ parryUI+ when (GkQ `Set.member` ks) $ do+ set global $ CombatTurn PlayerAttacking+ set global CombatAttackSelectUI+ set global $ KeysPressed (GkQ `Set.delete` ks)+ cmapM_ $ \(CombatPlayer, s) -> set s (Texture RenTexture { textureRef = "player-prismatic-attack", animationFrame = Just 0 })+ parryUI+ when (GkEsc `Set.member` ks) $ do+ set global CombatAttackSelectUI+ attackUI+ set global $ KeysPressed (GkEsc `Set.delete` ks)++parryUI :: System' ()+parryUI = cmap $ \(CombatUI, r) -> case r of+ Texture rt -> Texture rt { textureRef = "combat-parry-ui" }+ _ -> r++attackUI :: System' ()+attackUI = cmap $ \(CombatUI, r) -> case r of+ Texture rt -> Texture rt { textureRef = "combat-attack-select-ui" }+ _ -> r++stepPlayerAttack :: Float -> System' ()+stepPlayerAttack dT = do+ cmapM_ $ \(CombatPlayer, r, e) -> case r of+ Texture rt -> do+ particle <- cfold (\_ (CombatAttackParticle e) -> Just e) Nothing+ when (isNothing particle && (textureRef rt == "player-fire-attack" || textureRef rt == "player-prismatic-attack") && (fromMaybe 0 (animationFrame rt) `Set.member` playerMagicAttackFrames)) $ do+ if textureRef rt == "player-fire-attack" then do+ particle <- spawnParticle (Position (combatPlayerPos + V2 (tileSize/2) 16)) (Position combatEnemyPos) "particle-fire" 11+ void $ newEntity (CombatAttackParticle particle)+ else when (textureRef rt == "player-prismatic-attack") $ do+ particle <- spawnParticle (Position (combatPlayerPos + V2 (tileSize/2) 16)) (Position combatEnemyPos) "particle-prismatic" 13+ void $ newEntity (CombatAttackParticle particle)+ Particle (Position destPos) <- case particle of+ Just p -> get p :: System' Particle+ Nothing -> return $ Particle (Position (V2 0 0))+ Position currPos <- case particle of+ Just p -> do+ Position pos <- get p :: System' Position+ return $ Position pos+ Nothing -> return $ Position (V2 100 100)+ let attackHitCondition = (fromMaybe 0 (animationFrame rt) `Set.member` playerKnifeAttackFrames && textureRef rt == "player-knife-attack")+ || (norm (destPos - currPos) < 20)+ when attackHitCondition $ cmapM_ $ \(CombatEnemy e', r', ce) -> case r' of+ Texture rt' -> do+ enemy <- get e' :: System' Enemy+ Health hp <- get e' :: System' Health+ when (textureRef rt' == "skeleton-idle" || textureRef rt' == "vampire-idle" || textureRef rt' == "reaper-idle" || textureRef rt' == "golden-reaper-idle") $ do+ if hp - playerDamage > 0 then+ case enemyType enemy of+ Reaper -> when (textureRef rt' /= "reaper-hit") $ do+ modify e' $ \(Health hp) -> Health (hp - playerDamage)+ set ce (Texture rt { textureRef = "reaper-hit", animationFrame = Just 1 })+ Vampire -> when (textureRef rt' /= "vampire-hit") $ do+ modify e' $ \(Health hp) -> Health (hp - playerDamage)+ set ce (Texture rt { textureRef = "vampire-hit", animationFrame = Just 1 })+ Skeleton -> when (textureRef rt' /= "skeleton-hit") $ do+ modify e' $ \(Health hp) -> Health (hp - playerDamage)+ set ce (Texture rt { textureRef = "skeleton-hit", animationFrame = Just 1 })+ GoldenReaper -> when (textureRef rt' /= "golden-reaper-hit") $ do+ modify e' $ \(Health hp) -> Health (hp - playerDamage)+ set ce (Texture rt { textureRef = "golden-reaper-hit", animationFrame = Just 1 })+ else+ case enemyType enemy of+ Reaper -> when (textureRef rt' /= "reaper-death") $ do+ set ce (Texture rt { textureRef = "reaper-death", animationFrame = Just 1 })+ set global $ CombatTurn PlayerWin+ Vampire -> when (textureRef rt' /= "vampire-death") $ do+ set ce (Texture rt { textureRef = "vampire-death", animationFrame = Just 1 })+ set global $ CombatTurn PlayerWin+ Skeleton -> when (textureRef rt' /= "skeleton-death") $ do+ set ce (Texture rt { textureRef = "skeleton-death", animationFrame = Just 1 })+ set global $ CombatTurn PlayerWin+ GoldenReaper -> when (textureRef rt' /= "golden-reaper-death") $ do+ set ce (Texture rt { textureRef = "golden-reaper-death", animationFrame = Just 1 })+ set global $ CombatTurn PlayerWin+ _ -> return ()+ when (textureRef rt == "player-idle" && isNothing particle) $ do+ set global $ CombatTurn EnemyTurn+ set e (Position combatPlayerPos)+ _ -> return ()++stepEnemyAttack :: Float -> System' ()+stepEnemyAttack dT = do+ cmapM_ $ \(CombatEnemy e', r, e) -> case r of+ Texture rt -> do+ when (textureRef rt == "skeleton-idle" || textureRef rt == "vampire-idle" || textureRef rt == "reaper-idle" || textureRef rt == "golden-reaper-idle") $ do+ set global $ CombatTurn PlayerTurn+ attackUI+ set e (Position combatEnemyPos)+ enemy <- get e' :: System' Enemy+ KeysPressed ks <- get global+ cmapM_ $ \(CombatPlayer, r', cp) -> case r' of+ Texture rt' -> do+ when (textureRef rt' == "player-idle" && (GkF `Set.member` ks)) $ do+ set cp (Texture rt' { textureRef = "player-shield", animationFrame = Just 0 })+ set global $ ShieldCooldown 1.0+ _ -> return ()+ case enemyType enemy of+ Skeleton -> when (fromMaybe 0 (animationFrame rt) `Set.member` enemySkeletonAttackFrames) hitPlayer+ Vampire -> when (fromMaybe 0 (animationFrame rt) `Set.member` enemyVampireAttackFrames) hitPlayer+ Reaper -> when (fromMaybe 0 (animationFrame rt) `Set.member` enemyReaperAttackFrames) hitPlayer+ GoldenReaper -> when (fromMaybe 0 (animationFrame rt) `Set.member` enemyGoldenReaperAttackFrames) hitPlayer+ where+ hitPlayer = cmapM_ $ \(CombatPlayer, r', cp) -> case r' of+ Texture rt' -> do+ when (textureRef rt' /= "player-hit") $ do+ if textureRef rt' == "player-shield" && fromMaybe 0 (animationFrame rt') `Set.member` playerShieldFrames then do+ modify global $ \(ShieldCooldown _) -> ShieldCooldown 0+ void $ newEntity (FloatingText 0 1.0, Position (combatPlayerPos + V2 0 20), Text RenText { fontRef = "Roboto-Regular", displayText = "Blocked!" }, Colour (V4 255 255 255 255), Layer 3, IsVisible True, Velocity (V2 0 20))+ else cmapM_ $ \(Player, Health hp) -> if hp - enemyDamage > 0 then do+ cmap $ \(Player, Health hp) -> Health (hp - enemyDamage)+ set cp (Texture rt' { textureRef = "player-hit", animationFrame = Just 1 })+ else do+ set cp (Texture rt' { textureRef = "player-hit", animationFrame = Just 1 })+ set global $ CombatTurn EnemyWin+ _ -> return ()+ _ -> return ()+stepEnemyTurn :: Float -> System' ()+stepEnemyTurn dT = do+ cmapM_ $ \(CombatEnemy _, r, e) -> case r of+ Texture rt -> do+ case textureRef rt of+ "skeleton-idle" -> do+ set e (Texture rt { textureRef = "skeleton-attack", animationFrame = Just 0 })+ set e (Position (combatPlayerPos + V2 tileSize 0))+ set global $ CombatTurn EnemyAttacking+ "vampire-idle" -> do+ set e (Texture rt { textureRef = "vampire-attack", animationFrame = Just 0 })+ set e (Position (combatPlayerPos + V2 tileSize 0))+ set global $ CombatTurn EnemyAttacking+ "reaper-idle" -> do+ set e (Texture rt { textureRef = "reaper-attack", animationFrame = Just 0 })+ set e (Position (combatPlayerPos + V2 tileSize 0))+ set global $ CombatTurn EnemyAttacking+ "golden-reaper-idle" -> do+ set e (Texture rt { textureRef = "golden-reaper-attack", animationFrame = Just 0 })+ set e (Position (combatPlayerPos + V2 tileSize 0))+ set global $ CombatTurn EnemyAttacking+ _ -> return ()+ _ -> return ()++stepPlayerWin :: Float -> System' ()+stepPlayerWin dT = cmapM_ $ \(CombatEnemy _, r) -> case r of+ Texture rt -> do+ cmapIf (\(CombatPlayer, r') -> case r' of+ Texture rt' -> textureRef rt' == "player-idle"+ _ -> False+ ) (\CombatPlayer -> Position combatPlayerPos)+ when (textureRef rt == "vampire-death" || textureRef rt == "skeleton-death" || textureRef rt == "reaper-death" || textureRef rt == "golden-reaper-death") $ do+ TextureMap tmap <- get global+ let TextureData t ma = tmap Map.! textureRef rt+ anim = fromMaybe (error "No animation data for this texture") ma+ existsTransition <- cfold (\_ (Transition {}) -> Just ()) Nothing+ when (fromMaybe 0 (animationFrame rt) + 1 >= frameCount anim && isNothing existsTransition) $ startTransition (pi / 4) 1.0 ToDungeon+ _ -> return ()++stepEnemyWin :: Float -> System' ()+stepEnemyWin dT = do+ existsTransition <- cfold (\_ (Transition {}) -> Just ()) Nothing+ when (isNothing existsTransition) $ startTransition (pi / 4) 1.0 ToMenu++stepCombat :: Float -> System' ()+stepCombat dT = do+ ce <- cfold (\_ (CombatEnemy ce) -> Just ce) Nothing+ CombatTurn turn <- get global+ playerHealth <- cfold (\_ (Player, Health hp) -> Just hp) Nothing+ when (isJust playerHealth && fromMaybe 0 playerHealth <= 0) $ liftIO $ putStrLn "Player has been defeated!"+ stepPosition dT+ case ce of+ Nothing -> return ()+ Just e -> case turn of+ PlayerTurn -> stepPlayerTurn dT+ EnemyTurn -> stepEnemyTurn dT+ PlayerAttacking -> stepPlayerAttack dT+ EnemyAttacking -> stepEnemyAttack dT+ PlayerWin -> stepPlayerWin dT+ EnemyWin -> stepEnemyWin dT
+ examples/hungeon/Dungeon.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Dungeon (stepDungeon) where++import Apecs+import Linear+import Types+import qualified Data.Set as Set+import Utils+import Data.Foldable (foldl')+import Data.Maybe+import Control.Monad+import Enemy+import Cadence++handleEnemyCollisions :: Float -> System' ()+handleEnemyCollisions dT = cmapM_ $ \(Player, Position posP, v, bbp) -> do+ enemyRes <- cfold (\acc (Enemy _, Position posE, bbE, e) ->+ let+ (Position tempPosP) = stepPositionFormula dT (Position posP) v+ in+ if checkBoundaryBoxIntersection tempPosP bbp posE bbE && isNothing acc then+ Just e+ else+ acc) Nothing+ case enemyRes of+ Just e -> do+ ce <- cfold (\_ (CombatEnemy ce) -> Just ce) Nothing+ case ce of+ Just _ -> return ()+ Nothing -> do+ et <- get e :: System' Enemy+ let t = case enemyType et of+ Reaper -> Texture RenTexture { textureRef = "reaper-idle", animationFrame = Just 0 }+ Vampire -> Texture RenTexture { textureRef = "vampire-idle", animationFrame = Just 0 }+ Skeleton -> Texture RenTexture { textureRef = "skeleton-idle", animationFrame = Just 0 }+ GoldenReaper -> Texture RenTexture { textureRef = "golden-reaper-idle", animationFrame = Just 0 }+ _ <- newEntity (CombatEnemy e, Position combatEnemyPos, t, Layer 2, IsVisible True)+ set global $ CombatTurn PlayerTurn+ startTransition (pi / 4) 1.0 ToCombat+ Nothing -> return ()++updatePlayerMovement :: System' ()+updatePlayerMovement = do+ KeysPressed ks <- get global+ -- liftIO $ putStrLn $ "Camera angle: " ++ show ca+ mTr <- cfold (\_ (Transition {}) -> Just ()) Nothing+ if isNothing mTr then+ cmapM_ $ \(Player, Velocity _, r, e) -> case r of+ Texture rt -> do+ let (V2 vx vy) = foldl' (\(V2 ax ay) dir -> case dir of+ GkLeft -> V2 (ax - playerSpeed) ay+ GkRight-> V2 (ax + playerSpeed) ay+ GkUp -> V2 ax (ay + playerSpeed)+ GkDown -> V2 ax (ay - playerSpeed)+ _ -> V2 ax ay) (V2 0 0) (Set.toList ks)+ newSprite+ | vx == 0 && vy == 0 && textureRef rt /= "player-idle" = Texture rt { textureRef = "player-idle", animationFrame = Just 0 }+ | (vx /= 0 || vy /= 0) && textureRef rt /= "player-walk" = Texture rt { textureRef = "player-walk", animationFrame = Just 0 }+ | otherwise = Texture rt+ set e (Velocity (V2 vx vy))+ set e newSprite+ _ -> return ()+ else+ cmapM_ $ \(Player, r, e) -> case r of+ Texture rt -> do+ set e (Velocity (V2 0 0))+ set e (Texture rt { textureRef = "player-idle", animationFrame = Just 0 })+ _ -> return ()++ladderCollision :: System' ()+ladderCollision = cmapM_ $ \(Player, Position posP, bbP) -> do+ cmapM_ $ \(Ladder, Position posL, bbL) -> when (checkBoundaryBoxIntersection posP bbP posL bbL) $ do+ mTr <- cfold (\_ (Transition {}) -> Just ()) Nothing+ case mTr of+ Nothing -> startTransition (pi / 4) 1.0 ToNextLevel+ Just _ -> return ()++heartCollision :: System' ()+heartCollision = cmapM_ $ \(Player, Position posP, bbP, Health hp, ep) -> do+ cmapM_ $ \(Heart, Position posH, bbH, eh) -> when (checkBoundaryBoxIntersection posP bbP posH bbH) $ do+ set ep $ Health $ min 100 (hp + 50)+ destroy eh (Proxy @(Heart, Position, BoundaryBox, Item, Renderable, Layer, IsVisible))++stepDungeon :: Float -> System' ()+stepDungeon dT = do+ updatePlayerMovement+ stepEnemyAI+ blockPlayer dT+ stepPosition dT+ handleEnemyCollisions dT+ ladderCollision+ heartCollision++-- Block the player from moving into walls+blockPlayer :: Float -> System' ()+blockPlayer t = cmapM $ \(Player, Position posP, Velocity (V2 vx vy), bbp) -> do+ -- Get the next position for the player+ let (Position tempPos) = stepPositionFormula t (Position posP) (Velocity (V2 vx vy))+ -- For each wall, check for collision and adjust velocity accordingly+ cfoldM (\acc (Wall, Position posW, bbw) -> do+ let+ top = checkBoundaryBoxTopIntersection tempPos bbp posW bbw+ bottom = checkBoundaryBoxBottomIntersection tempPos bbp posW bbw+ left = checkBoundaryBoxLeftIntersection tempPos bbp posW bbw+ right = checkBoundaryBoxRightIntersection tempPos bbp posW bbw+ (Velocity (V2 avx avy)) = acc+ if (top && vy < 0) || (bottom && vy > 0) then+ return $ Velocity (V2 avx 0)+ else if (left && vx > 0) || (right && vx < 0) then+ return $ Velocity (V2 0 avy)+ else+ return acc) (Velocity (V2 vx vy))
+ examples/hungeon/Enemy.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Enemy where++import Apecs+import System.Random+import Linear+import Types+import Utils+import Data.Maybe ( isNothing )+import Cadence++enemyAggroRange :: Float+enemyAggroRange = 175.0++makeEnemy :: Enemy -> Position -> System' Entity+makeEnemy enemy pos = do+ let+ (sref, bbox) = case enemyType enemy of+ Reaper -> (Texture RenTexture { textureRef = "reaper-idle", animationFrame = Just 0 }, BoundaryBox (16, 26) (-1, -12))+ Vampire -> (Texture RenTexture { textureRef = "vampire-idle", animationFrame = Just 0 }, BoundaryBox (16, 30) (-6, -11))+ Skeleton -> (Texture RenTexture { textureRef = "skeleton-idle", animationFrame = Just 0 }, BoundaryBox (24, 26) (-2, -11))+ GoldenReaper -> (Texture RenTexture { textureRef = "golden-reaper-idle", animationFrame = Just 0 }, BoundaryBox (16, 26) (-1, -12))+ n <- case enemyType enemy of+ GoldenReaper -> liftIO $ randomRIO (150, 200)+ _ -> liftIO $ randomRIO (35, 50)+ newEntity (enemy, pos, Velocity (V2 0 0), sref, bbox, Health n, Layer 2, IsVisible True)++stepEnemyAI :: System' ()+stepEnemyAI = cmapM_ $ \(Player, Position posP) -> do+ cmapM $ \(Enemy _, Position posE, r) -> case r of+ Texture rt -> do+ let isInRange = distance posP posE <= enemyAggroRange+ ce <- cfold (\_ (CombatEnemy ce) -> Just ce) Nothing+ if isInRange && isNothing ce then do+ let dir = normalize (posP - posE)+ newVel = dir ^* enemySpeed+ sref' = case textureRef rt of+ "reaper-idle" -> rt { textureRef = "reaper-walk", animationFrame = Just 0 }+ "vampire-idle" -> rt { textureRef = "vampire-walk", animationFrame = Just 0 }+ "skeleton-idle" -> rt { textureRef = "skeleton-walk", animationFrame = Just 0 }+ "golden-reaper-idle" -> rt { textureRef = "golden-reaper-walk", animationFrame = Just 0 }+ _ -> rt+ return (Velocity newVel, Texture sref')+ else+ let sref' = case textureRef rt of+ "reaper-walk" -> rt { textureRef = "reaper-idle", animationFrame = Just 0 }+ "vampire-walk" -> rt { textureRef = "vampire-idle", animationFrame = Just 0 }+ "skeleton-walk" -> rt { textureRef = "skeleton-idle", animationFrame = Just 0 }+ "golden-reaper-walk" -> rt { textureRef = "golden-reaper-idle", animationFrame = Just 0 }+ _ -> rt+ in+ return (Velocity (V2 0 0), Texture sref')+ r' -> return (Velocity (V2 0 0), r')
+ examples/hungeon/GameMap.hs view
@@ -0,0 +1,421 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GameMap ( generateMap ) where++import Apecs+import System.Random+import Linear+import Control.Monad+import Types+import Data.Tree+import Data.List ( maximumBy, minimumBy )+import Data.Ord ( comparing )+import System.Random.Shuffle ( shuffleM )+import Data.Maybe ( listToMaybe, isJust )+import Data.Foldable ( foldl' )+import Data.Char (intToDigit)+import System.IO.Unsafe ( unsafePerformIO )+import Utils+import Enemy (makeEnemy)+import Cadence++getRoomSize :: [String] -> (Float, Float)+getRoomSize layout = (fromIntegral (length (head layout)) * tileSize, fromIntegral (length layout) * tileSize)++startRoomLayout :: [String]+startRoomLayout =+ [ "WWWWW1WWWW"+ , "WTTTTTTTT2"+ , "4TTTTTTTTW"+ , "WTTTTTTTTW"+ , "WW3WWWWWWW"+ ]++bossRoomLayout :: [String]+bossRoomLayout =+ [ "WWWW1WWWW"+ , "WTTTTTTTW"+ , "4TTTTTTT2"+ , "WTTTTTTTW"+ , "WWWW3WWWW"+ ]++ladderRoomLayout :: [String]+ladderRoomLayout =+ [ "WWWW1WWWW"+ , "WTTTTTTTW"+ , "4TTTLTTT2"+ , "WTTTTTTTW"+ , "WWWW3WWWW"+ ]++heartRoomLayout :: [String]+heartRoomLayout =+ [ "WWWW1WWWW"+ , "WTTTTTTTW"+ , "4TTTHTTT2"+ , "WTTTTTTTW"+ , "WWWW3WWWW"+ ]++gameRoomLayouts :: [[String]]+gameRoomLayouts = [+ [ "WWWWWWW1WWWWWWW"+ , "WTTTTTTTTTTTTTW"+ , "WTTTTTTTTTTTTTW"+ , "4TTTTTTTTTTTTT2"+ , "WTTTTTTTTTTTTTW"+ , "WTTTTTTTTTTTTTW"+ , "WWWWWWW3WWWWWWW"+ ],+ [ "____WWW1WWW____"+ , "____WTTTTTW____"+ , "____WTTTTTW____"+ , "WWWWWTTTTTWWWWW"+ , "WTTTTTTTTTTTTTW"+ , "4TTTTTTTTTTTTT2"+ , "WTTTTTTTTTTTTTW"+ , "WWWWWTTTTTWWWWW"+ , "____WTTTTTW____"+ , "____WTTTTTW____"+ , "____WWW3WWW____"+ ],+ [ "WWW1WWW"+ , "WTTTTTW"+ , "WTTTTTW"+ , "WTTTTTW"+ , "WTTTTTW"+ , "4TTTTT2"+ , "WTTTTTW"+ , "WTTTTTW"+ , "WTTTTTW"+ , "WTTTTTW"+ , "WWW3WWW"+ ]+ ]++-- Generate a random abstract game map tree+generateMapTree :: IO (Tree RoomType)+generateMapTree = do+ depth <- randomRIO (4, 6) :: IO Int+ t <- recursiveGenerate (Node { rootLabel = StartRoom, subForest = [] }) depth hubRoomCount+ return $ addHeartRoom $ addBossRoom t+ where+ hubRoomCount = 1++-- Add a given room as a child to a tree+addRoom :: Tree RoomType -> Tree RoomType -> Tree RoomType+addRoom t rt = Node { rootLabel = rootLabel t, subForest = subForest t ++ [rt] }++addHeartRoom :: Tree RoomType -> Tree RoomType+addHeartRoom tree =+ let+ leaves = collectLeavesWithDepth tree+ (_, shallowestPath) = minimumBy (comparing fst) leaves+ heartNode = Node HeartRoom []+ in+ updateAtPath shallowestPath (\leaf -> leaf { subForest = subForest leaf ++ [heartNode] }) tree++-- Reursively generate a tree of rooms+recursiveGenerate :: Tree RoomType -> Int -> Int -> IO (Tree RoomType)+recursiveGenerate t 0 _ = -- Base case when depth counter is 0+ case rootLabel t of -- Pattern match on the current room type+ HubRoom -> do -- If it's a hub room, add 2-3 normal rooms as children+ n <- randomRIO (2, 3) :: IO Int+ foldM (\acc _ -> do+ let newRoom = Node { rootLabel = NormalRoom, subForest = [] }+ child <- recursiveGenerate newRoom 0 0+ return (addRoom acc child)) t [1..n]+ _ -> return t -- Otherwise, just return the current tree+recursiveGenerate t depth hubRoomCount = do+ newRoom <- randomRoomType -- Generate a random room type+ let newNode = Node { rootLabel = newRoom, subForest = []}+ case rootLabel newNode of+ HubRoom -> do -- If the new room is a hub room, then add 2 normal rooms as children (if we have hub rooms left to add)+ if hubRoomCount > 0 then do+ children <- replicateM 2 $ recursiveGenerate (Node { rootLabel = NormalRoom, subForest = [] }) (depth - 1) (hubRoomCount - 1)+ let hubNode = newNode { subForest = children }+ return $ addRoom t hubNode+ else do+ child <- recursiveGenerate (Node { rootLabel = NormalRoom, subForest = [] }) (depth - 1) 0+ return $ addRoom t child+ _ -> do+ child <- recursiveGenerate newNode (depth - 1) hubRoomCount+ return $ addRoom t child+ where+ randomRoomType :: IO RoomType+ randomRoomType = do+ r <- randomRIO (1, 10) :: IO Int+ return $ if r <= 6 then NormalRoom else HubRoom++-- Given a Tree, collect into a list the depth of each leaf, and their path+collectLeavesWithDepth :: Tree a -> [(Int, [Int])]+collectLeavesWithDepth = go [] 0+ where+ go path depth node+ | null (subForest node) = [(depth, path)]+ | otherwise = concat [go (path ++ [i]) (depth + 1) child | (i, child) <- zip [0..] (subForest node)]++-- Update a node at a given path+updateAtPath :: [Int] -> (Tree a -> Tree a) -> Tree a -> Tree a+updateAtPath [] f node = f node+updateAtPath (i:is) f node = node { subForest = [ if j == i then updateAtPath is f child else child | (j, child) <- zip [0..] (subForest node) ] }++-- Adds a single boss room at the deepest leaf+addBossRoom :: Tree RoomType -> Tree RoomType+addBossRoom tree =+ let+ leaves = collectLeavesWithDepth tree+ (_, deepestPath) = maximumBy (\(d1, _) (d2, _) -> compare d1 d2) leaves+ ladderRoom = Node LadderRoom []+ in+ updateAtPath deepestPath (\leaf -> leaf { subForest = [Node BossRoom [ladderRoom]] }) tree++generateMap :: System' ()+generateMap = do+ tree <- liftIO generateMapTree+ bfsM insertGameRoom tree+ err <- cfold (\_ (_ :: MapError) -> Just ()) Nothing+ case err of+ Just _ -> do -- Since an error occurred, delete all rooms and regenerate the map+ cmapM_ $ \(GameRoom {}, e) -> destroy e (Proxy @(GameRoom, Position))+ generateMap+ Nothing -> gameRoomToSprites+ where+ insertGameRoom :: Maybe Entity -> Tree RoomType -> System' Entity+ insertGameRoom parent node = do+ n <- randomRIO (0, length gameRoomLayouts - 1)+ exits' <- generateRandomExitOrder+ case parent of+ Nothing -> do+ let gr = roomTypeToGameRoom (rootLabel node) startRoomLayout exits'+ newEntity (gr, Position (V2 0 0))+ Just p -> do+ case p of+ -1 -> return p -- Invalid parent means error occurred, so do nothing+ _ -> do+ Position (V2 px py) <- get p+ grP <- get p :: System' GameRoom+ -- Attempt to find the first direction which does not intersect+ let newLayout = case rootLabel node of+ StartRoom -> startRoomLayout+ BossRoom -> bossRoomLayout+ LadderRoom -> ladderRoomLayout+ HeartRoom -> heartRoomLayout+ _ -> getRoomLayout n+ intersections <- mapM (\dir -> checkRoomIntersectionInDirection p dir newLayout) (exits grP)+ let res = foldl' (\acc (intersects, dir) ->+ case acc of+ Just _ -> acc+ Nothing -> if not intersects then+ Just (dir, Position (V2 (px + fst (connectionPosition dir (roomLayout grP) newLayout)) (py + snd (connectionPosition dir (roomLayout grP) newLayout))))+ else Nothing) Nothing (zip intersections (exits grP))+ case res of+ Just (dir, finalPos) -> do+ let newGr = roomTypeToGameRoom (rootLabel node) newLayout (filter (/= oppositeDirection dir) exits')+ -- Update parent room to remove the used exit+ set p (grP { exits = filter (/= dir) (exits grP) })+ _ <- case rootLabel node of+ BossRoom -> makeEnemy (Enemy GoldenReaper) finalPos+ LadderRoom -> return 0+ HeartRoom -> return 0+ _ -> do+ enemyNum <- randomRIO (1, 3)+ makeEnemy (Enemy $ toEnum (enemyNum - 1)) finalPos+ newEntity (newGr, finalPos)+ Nothing -> do+ -- If all directions intersect, place it in the first direction by shifting it in that direction until it doesn't intersect+ liftIO $ print $ zip intersections (exits grP)+ _ <- newEntity MapError -- Create a dummy entity to indicate error+ return (-1) -- Invalid entity to indicate error++gameRoomToSprites :: System' ()+gameRoomToSprites = cmapM_ $ \(gr, Position (V2 grx gry), e) -> do+ let layout = roomLayout gr+ w = length $ head layout+ h = length layout+ -- Given a character that represents a tile, and its position within a room layout, select an appropriate sprite+ selectSprite :: Char -> (Int,Int) -> IO (String, Char)+ selectSprite c (x,y)+ | c == 'W' || c == '1' || c == '2' || c == '3' || c == '4' = do+ if (c == '1' && UpDir `notElem` exits gr) ||+ (c == '2' && RightDir `notElem` exits gr) ||+ (c == '3' && DownDir `notElem` exits gr) ||+ (c == '4' && LeftDir `notElem` exits gr) then do -- Not blocked exit+ n <- randomRIO (1, tileCount) :: IO Integer+ return ("tile" ++ show n, 'T')+ else if fromIntegral x <= midW && fromIntegral y <= midH then do -- Top left+ if layout !! (y+1) !! x == '4' && LeftDir `notElem` exits gr then do -- Left Elbow+ n <- randomRIO (1, wallTopCount) :: IO Integer+ return ("wall-top" ++ show n, 'W')+ else if y > 0 && layout !! (y-1) !! x == '4' && LeftDir `notElem` exits gr then do -- Left Up Elbow+ n <- randomRIO (1, wallBottomLeftElbowCount) :: IO Integer+ return ("wall-bottom-left-elbow" ++ show n, 'W')+ else if layout !! (y+1) !! x == 'W' || (layout !! (y+1) !! x == '4' && LeftDir `elem` exits gr) then do -- Left Wall + n <- randomRIO (1, wallLeftCount) :: IO Integer+ return ("wall-left" ++ show n, 'W')+ else do -- Top Wall+ n <- randomRIO (1, wallTopCount) :: IO Integer+ return ("wall-top" ++ show n, 'W')+ else if fromIntegral x > midW && fromIntegral y <= midH then do -- Top right+ if layout !! (y+1) !! x == '2' && RightDir `notElem` exits gr then do -- Right Elbow+ n <- randomRIO (1, wallTopCount) :: IO Integer+ return ("wall-top" ++ show n, 'W')+ else if y > 0 && layout !! (y-1) !! x == '2' && RightDir `notElem` exits gr then do -- Right Up Elbow+ n <- randomRIO (1, wallBottomRightElbowCount) :: IO Integer+ return ("wall-bottom-right-elbow" ++ show n, 'W')+ else if layout !! (y+1) !! x == 'W' || (layout !! (y+1) !! x == '2' && RightDir `elem` exits gr) then do -- Right Wall+ n <- randomRIO (1, wallRightCount) :: IO Integer+ return ("wall-right" ++ show n, 'W')+ else do -- Top Wall+ n <- randomRIO (1, wallTopCount) :: IO Integer+ return ("wall-top" ++ show n, 'W')+ else if fromIntegral x <= midW && fromIntegral y > midH then do -- Bottom left+ if (layout !! (y-1) !! x == '4' && LeftDir `notElem` exits gr) ||+ (layout !! y !! (x+1) == '3' && DownDir `notElem` exits gr) ||+ (layout !! (y-1) !! x == 'T' && layout !! y !! (x+1) == 'T') then do -- Left Elbow+ n <- randomRIO (1, wallBottomLeftElbowCount) :: IO Integer+ return ("wall-bottom-left-elbow" ++ show n, 'W')+ else if x > 0 && layout !! y !! (x-1) == '3' && DownDir `notElem` exits gr then do -- Right elbow+ n <- randomRIO (1, wallBottomRightElbowCount) :: IO Integer+ return ("wall-bottom-right-elbow" ++ show n, 'W')+ else if layout !! (y-1) !! x == 'W' && layout !! y !! (x+1) == 'W' then do -- Bottom Left Corner+ return ("wall-bottom-left", 'W')+ else if layout !! (y-1) !! x == 'W' || (layout !! (y-1) !! x == '4' && LeftDir `elem` exits gr) then do -- Left Wall+ n <- randomRIO (1, wallLeftCount) :: IO Integer+ return ("wall-left" ++ show n, 'W')+ else do -- Bottom Wall+ n <- randomRIO (1, wallBottomCount) :: IO Integer+ return ("wall-bottom" ++ show n, 'W')+ else -- Bottom right+ if (layout !! (y-1) !! x == '2' && RightDir `notElem` exits gr) ||+ (layout !! y !! (x-1) == '3' && DownDir `notElem` exits gr) ||+ (layout !! (y-1) !! x == 'T' && layout !! y !! (x-1) == 'T') then do -- Right Elbow+ n <- randomRIO (1, wallBottomRightElbowCount) :: IO Integer+ return ("wall-bottom-right-elbow" ++ show n, 'W')+ else if x < (w - 1) && layout !! y !! (x+1) == '3' && DownDir `notElem` exits gr then do -- Left Elbow+ n <- randomRIO (1, wallBottomLeftElbowCount) :: IO Integer+ return ("wall-bottom-left-elbow" ++ show n, 'W')+ else if layout !! (y-1) !! x == 'W' && layout !! y !! (x-1) == 'W' then do -- Bottom Right Corner+ return ("wall-bottom-right", 'W')+ else if layout !! (y-1) !! x == 'W' || (layout !! (y-1) !! x == '2' && RightDir `elem` exits gr) then do -- Right Wall+ n <- randomRIO (1, wallRightCount) :: IO Integer+ return ("wall-right" ++ show n, 'W')+ else do -- Bottom Wall+ n <- randomRIO (1, wallBottomCount) :: IO Integer+ return ("wall-bottom" ++ show n, 'W')+ | c == 'L' = return ("ladder", c)+ | c == 'H' = return ("heart", c)+ | otherwise = do+ n <- randomRIO (1, tileCount) :: IO Integer+ return ("tile" ++ show n, 'T')+ where+ midW :: Float+ midW = fromIntegral (w - 1) / 2+ midH :: Float+ midH = fromIntegral (h - 1) / 2+ tileCheck :: Char -> Bool+ tileCheck c = c `notElem` " _"+ halfAdjust v = if even v then tileSize / 2 else 0+ offsetX = grx - (fromIntegral w * tileSize / 2) + halfAdjust w + tileSize / 2+ offsetY = gry - (fromIntegral h * tileSize / 2) + halfAdjust h + tileSize / 2+ spriteList <- liftIO $ sequence [ do+ (s,t) <- selectSprite c (x,y)+ let sref = Texture RenTexture { textureRef = s, animationFrame = Nothing }+ pos = Position (V2 (offsetX + fromIntegral x * tileSize) (offsetY + fromIntegral (h - 1 - y) * tileSize))+ return (sref, pos, t)+ | (y, row) <- zip [0..] layout, (x, c) <- zip [0..] row, tileCheck c ]+ forM_ spriteList $ \(s, p, t) -> do+ case t of+ 'T' -> void $ newEntity (Floor, Tile, p, s, Layer 1, IsVisible True)+ 'L' -> void $ newEntity (Ladder, Tile, p, s, BoundaryBox (32,32) (0,0), Layer 1, IsVisible True)+ 'H' -> do+ void $ newEntity (Floor, Tile, p, Texture RenTexture { textureRef = "tile1", animationFrame = Nothing }, Layer 0, IsVisible True ) -- Add a floor tile under the heart so it doesn't look weird when the heart is on top of a wall tile+ void $ newEntity (Heart, Item, p, s, BoundaryBox (32,32) (0,0), Layer 1, IsVisible True)+ _ -> void $ newEntity (Wall, Tile, p, s, BoundaryBox (64,64) (0,0), Layer 1, IsVisible True)+ destroy e (Proxy @(GameRoom, Position))++-- Given a direction and two room layouts, finds the position for the new layout relative to the current layout+connectionPosition :: Direction -> [[Char]] -> [[Char]] -> (Float, Float)+connectionPosition dir layout newLayout = case (directionCoord, oppDirectionCoord) of+ (Just (rA, cA), Just (rB, cB)) -> let+ wA = length (head layout)+ hA = length layout+ wB = length (head newLayout)+ hB = length newLayout+ (offXA, offYA) = tileToWorld wA hA cA rA tileSize+ (offXB, offYB) = tileToWorld wB hB cB rB tileSize+ cxB = offXA - offXB+ cyB = offYA - offYB+ in+ case dir of+ UpDir -> (cxB, cyB + tileSize)+ DownDir -> (cxB, cyB - tileSize)+ LeftDir -> (cxB - tileSize, cyB)+ RightDir -> (cxB + tileSize, cyB)+ _ -> error $ "No connection found for direction " ++ show dir ++ " in layouts: " ++ show layout ++ " and " ++ show newLayout+ where+ directionCoord = listToMaybe [ (r,c) | (r, row) <- zip [0..] layout, (c, ch) <- zip [0..] row, ch == intToDigit (fromEnum dir) ]+ oppDirectionCoord = listToMaybe [ (r,c) | (r, row) <- zip [0..] newLayout, (c, ch) <- zip [0..] row, ch == intToDigit (fromEnum (oppositeDirection dir)) ]+ tileToWorld w h tx ty size = let+ halfAdjust v = if even v then size / 2 else 0+ offsetX = (fromIntegral tx - fromIntegral (w - 1) / 2) * size + halfAdjust w+ offsetY = (fromIntegral (h - 1) / 2 - fromIntegral ty) * size + halfAdjust h+ in+ (offsetX, offsetY)++-- Checks if placing a room in a given direction would intersect with any existing rooms+checkRoomIntersectionInDirection :: Entity -> Direction -> [[Char]] -> System' Bool+checkRoomIntersectionInDirection e dir newLayout = do+ Position (V2 x y) <- get e :: System' Position+ gr <- get e :: System' GameRoom+ let+ (cx, cy) = connectionPosition dir (roomLayout gr) newLayout+ (nx, ny) = (x + cx, y + cy)+ (rw, rh) = getRoomSize newLayout+ cfold (\acc (gr', Position (V2 xgr ygr), e') ->+ if e' == e then+ acc+ else+ let+ (rw', rh') = getRoomSize (roomLayout gr')+ intersectsX = abs (nx - xgr) < (rw/2 + rw'/2)+ intersectsY = abs (ny - ygr) < (rh/2 + rh'/2)+ in+ acc || (intersectsX && intersectsY)) False++roomTypeToGameRoom :: RoomType -> [String] -> [Direction] -> GameRoom+roomTypeToGameRoom rt layout exits' = GameRoom { roomType = rt, roomLayout = layout, exits = exits' }++getRoomLayout :: Int -> [String]+getRoomLayout n = gameRoomLayouts !! (n `mod` length gameRoomLayouts)++generateRandomExitOrder :: SystemT World IO [Direction]+generateRandomExitOrder = liftIO $ shuffleM [UpDir, DownDir, LeftDir, RightDir]++oppositeDirection :: Direction -> Direction+oppositeDirection UpDir = DownDir+oppositeDirection DownDir = UpDir+oppositeDirection LeftDir = RightDir+oppositeDirection RightDir = LeftDir++-- BFS which keeps track of the parent node, and applies a monadic function to each node+-- The monadic function takes Maybe b as the parent node, and Tree a as the current node+-- and returns m b as the result for the current node+-- b is the type of value to be passed down the tree (e.g., Entity)+bfsM :: Monad m => (Maybe b -> Tree a -> m b) -> Tree a -> m ()+bfsM f tree = go [(Nothing, tree)]+ where+ go [] = return ()+ go ((parent, node):xs) = do+ b <- f parent node+ let children = map (\child -> (Just b, child)) (subForest node)+ go (xs ++ children)
+ examples/hungeon/Input.hs view
@@ -0,0 +1,63 @@+module Input where++import qualified Data.Map as M+import qualified Data.Set as Set+import Types+import qualified SDL+import Linear+import Apecs+import qualified Data.Map as Map++-- Bool in type is True for pressed, False for released+updateKeySet :: Ord rawKey => KeyBindings rawKey -> rawKey -> Bool -> Set.Set GameKey -> Set.Set GameKey+updateKeySet (KeyBindings m) rk pressed s = case M.lookup rk m of+ Nothing -> s+ Just key -> if pressed then+ Set.insert key s+ else+ Set.delete key s++inputBindings :: KeyBindings SDL.Keycode+inputBindings = KeyBindings $ Map.fromList [+ (SDL.KeycodeW, GkUp),+ (SDL.KeycodeS, GkDown),+ (SDL.KeycodeA, GkLeft),+ (SDL.KeycodeD, GkRight),+ (SDL.KeycodeSpace, GkSpace),+ (SDL.KeycodeEscape, GkEsc),+ (SDL.KeycodeE, GkE),+ (SDL.KeycodeQ, GkQ),+ (SDL.KeycodeF, GkF)+ ]++handlePayload :: [SDL.EventPayload] -> System' ()+handlePayload = mapM_ handleEvent++handleEvent :: SDL.EventPayload -> System' ()+handleEvent (SDL.KeyboardEvent ev) = handleKeyEvent ev+handleEvent (SDL.MouseMotionEvent ev) = handleMouseMotionEvent ev+handleEvent (SDL.MouseButtonEvent ev) = handleMouseButtonEvent ev+handleEvent _ = return ()++handleMouseButtonEvent :: SDL.MouseButtonEventData -> System' ()+handleMouseButtonEvent ev+ | SDL.mouseButtonEventMotion ev == SDL.Pressed && SDL.mouseButtonEventButton ev == SDL.ButtonLeft = modify global $ \(KeysPressed ks) -> KeysPressed $ Set.insert GkLMB ks+ | SDL.mouseButtonEventMotion ev == SDL.Released && SDL.mouseButtonEventButton ev == SDL.ButtonLeft = modify global $ \(KeysPressed ks) -> KeysPressed $ Set.delete GkLMB ks+ | otherwise = return ()++handleMouseMotionEvent :: SDL.MouseMotionEventData -> System' ()+handleMouseMotionEvent ev = let+ (SDL.P (V2 x y)) = SDL.mouseMotionEventPos ev+ in do+ Viewport (w, h) <- get global+ -- Normalise mouse coordinates to be relative to the center of the screen, and invert y-axis to match game coordinate system+ -- along with normalising for fullscreen applications relative to the base resolution of 1280x720+ let nx = fromIntegral x * (1280 / fromIntegral w)+ ny = (- fromIntegral y) * (720 / fromIntegral h)+ modify global $ \(MousePosition _) -> MousePosition (V2 nx ny)++handleKeyEvent :: SDL.KeyboardEventData -> System' ()+handleKeyEvent ev+ | SDL.keyboardEventKeyMotion ev == SDL.Pressed = modify global $ \(KeysPressed ks) -> KeysPressed $ updateKeySet inputBindings (SDL.keysymKeycode (SDL.keyboardEventKeysym ev)) True ks+ | SDL.keyboardEventKeyMotion ev == SDL.Released = modify global $ \(KeysPressed ks) -> KeysPressed $ updateKeySet inputBindings (SDL.keysymKeycode (SDL.keyboardEventKeysym ev)) False ks+ | otherwise = return ()
+ examples/hungeon/Main.hs view
@@ -0,0 +1,28 @@+module Main (main) where++import Apecs+import Types+import Systems+import Linear+import qualified SDL+import Control.Monad (when)+import Input+import Cadence++main :: IO ()+main = do+ w <- initWorld+ (window, renderer) <- initialise w (defaultConfig { windowDimensions = (1280, 720), windowTitle = "Hungeon", backgroundColor = V4 37 19 26 255, targetFPS = Limited 60, showFPS = Just "Roboto-Regular" })+ runWith w (initialize renderer)+ runSystem (do+ settings <- get global :: System' Settings+ when (fullscreen settings) $ do+ liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop+ viewport <- SDL.get (SDL.rendererViewport renderer)+ let (w',h') = case viewport of+ Just (SDL.Rectangle _ (SDL.V2 w h)) -> (w, h)+ Nothing -> (1280, 720)+ (SDL.$=) (SDL.rendererScale renderer) (V2 (fromIntegral w' / 1280) (fromIntegral h' / 720))+ modify global $ \(Viewport _) -> Viewport (fromIntegral w', fromIntegral h')+ ) w+ run w renderer window step handlePayload draw
+ examples/hungeon/Menu.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}++module Menu (stepMenu, buttonActions, posCheck) where++import Apecs+import Types+import Utils (startTransition)+import Control.Monad (when)+import qualified Data.Set as Set+import Linear+import qualified Data.Map as Map+import Data.List (isInfixOf)+import Data.Aeson+import qualified SDL+import qualified Data.ByteString.Lazy as BL+import Cadence++stepMenu :: Float -> System' ()+stepMenu dT = do+ stepButtons+ -- KeysPressed ks <- get global+ -- when (GkSpace `Set.member` ks) $ do+ -- startTransition (pi / 4) 1.0 StartDungeon++stepButtons :: System' ()+stepButtons = do+ MousePosition (V2 mx my) <- get global+ KeysPressed ks <- get global+ TextureMap tmap <- get global+ cmapM_ $ \(MainMenuUIElement, Button action, Position (V2 x y), r :: Renderable, e) -> case r of+ Texture rt -> do+ let+ TextureData t ma = tmap Map.! textureRef rt+ baseRef = (if "-hover" `isInfixOf` textureRef rt then take (length (textureRef rt) - 6) (textureRef rt) else textureRef rt)+ info <- liftIO $ SDL.queryTexture t+ let w = fromIntegral $ SDL.textureWidth info+ h = fromIntegral $ SDL.textureHeight info+ if posCheck mx my x y w h then+ set e $ Texture rt { textureRef = baseRef ++ "-hover" }+ else+ set e $ Texture rt { textureRef = baseRef }+ when (posCheck mx my x y w h && GkLMB `Set.member` ks) $ buttonActions action+ _ -> return ()++buttonActions :: ButtonAction -> System' ()+buttonActions StartGameButton = startTransition (pi / 4) 1.0 StartDungeon+buttonActions SettingsButton = startTransition (pi / 4) 1.0 ToSettings+buttonActions BackToTitleButton = startTransition (pi / 4) 1.0 ToMenu+buttonActions FullscreenButton = do+ settings <- get global :: System' Settings+ set global (settings { fullscreen = True })+ liftIO $ BL.writeFile "settings.json" (encode settings { fullscreen = True })+buttonActions WindowedButton = do+ settings <- get global :: System' Settings+ set global (settings { fullscreen = False })+ liftIO $ BL.writeFile "settings.json" (encode settings { fullscreen = False })+-- buttonActions _ = return ()++posCheck :: (Fractional a1, Fractional a2, Integral a3, Integral a4, Ord a1, Ord a2) => a1 -> a2 -> a1 -> a2 -> a3 -> a4 -> Bool+posCheck mx my x y w h = mx >= x && mx <= x + fromIntegral w &&+ my >= y - fromIntegral h && my <= y
+ examples/hungeon/Settings.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}++module Settings (stepSettings) where++import Apecs+import Types+import qualified Data.Set as Set+import Linear+import qualified Data.Map as Map+import qualified Data.Vector as V+import Menu (buttonActions, posCheck)+import Control.Monad (when)+import Data.List (isInfixOf)+import Utils (startTransition)+import qualified SDL+import Data.Maybe (isJust)+import Cadence++stepSettings :: Float -> System' ()+stepSettings dT = do+ stepButtonGroups+ stepButtons+ KeysPressed ks <- get global+ when (GkEsc `Set.member` ks) $ do+ startTransition (pi / 4) 1.0 ToMenu++stepButtonGroups :: System' ()+stepButtonGroups = do+ MousePosition (V2 mx my) <- get global+ KeysPressed ks <- get global+ TextureMap tmap <- get global+ cmapM_ $ \(SettingsUIElement, ButtonGroup group active, e) -> do+ V.mapM_ (\e' -> do+ Position (V2 x y) <- get e'+ r <- get e'+ case r of+ Texture rt -> do+ let TextureData t _ = tmap Map.! textureRef rt+ baseRef = (if "-hover" `isInfixOf` textureRef rt then take (length (textureRef rt) - 6) (textureRef rt) else textureRef rt)+ info <- liftIO $ SDL.queryTexture t+ let w = fromIntegral $ SDL.textureWidth info+ h = fromIntegral $ SDL.textureHeight info+ when (posCheck mx my x y w h && GkLMB `Set.member` ks) $ set e $ ButtonGroup group e'+ _ -> return ()+ ) group+ r <- get active+ case r of+ Texture rt -> do+ let baseRefA = (if "-hover" `isInfixOf` textureRef rt then take (length (textureRef rt) - 6) (textureRef rt) else textureRef rt)+ set active $ Texture rt { textureRef = baseRefA ++ "-hover" }+ _ -> return ()++stepButtons :: System' ()+stepButtons = do+ MousePosition (V2 mx my) <- get global+ KeysPressed ks <- get global+ TextureMap tmap <- get global+ cmapM_ $ \(SettingsUIElement, Button action, Position (V2 x y), r, e) -> case r of+ Texture rt -> do+ let+ TextureData t _ = tmap Map.! textureRef rt+ baseRef = (if "-hover" `isInfixOf` textureRef rt then take (length (textureRef rt) - 6) (textureRef rt) else textureRef rt)+ info <- liftIO $ SDL.queryTexture t+ let w = fromIntegral $ SDL.textureWidth info+ h = fromIntegral $ SDL.textureHeight info+ if posCheck mx my x y w h then+ set e $ Texture rt { textureRef = baseRef ++ "-hover" }+ else do+ isActive <- cfold (\_ (SettingsUIElement, ButtonGroup _ active) -> if active == e then Just () else Nothing) Nothing+ if isJust isActive then+ set e $ Texture rt { textureRef = baseRef ++ "-hover" }+ else+ set e $ Texture rt { textureRef = baseRef }+ when (posCheck mx my x y w h && GkLMB `Set.member` ks) $ buttonActions action+ _ -> return ()
+ examples/hungeon/Systems.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Systems where++import Apecs+import System.Random hiding (next)+import System.Exit+import Linear+import Control.Monad+import Types+import GameMap+import Data.Set (Set)+import qualified Data.Set as Set+import Utils+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import System.IO.Unsafe ( unsafePerformIO )+import Combat+import Dungeon+import Menu+import Settings+import qualified Data.Vector as V+import Data.Functor+import Data.Foldable+import Data.Aeson+import qualified Data.ByteString.Lazy as BL+import qualified SDL+import Cadence++-- Initialise the game state by creating a player entity+initialize :: SDL.Renderer -> System' ()+initialize r = do+ loadTexture r "examples/hungeon/assets/player/idle.png" "player-idle" (Just Animation { frameCount = 6, frameSpeed = 0.3, next = "player-idle" })+ loadTexture r "examples/hungeon/assets/player/walk.png" "player-walk" (Just Animation { frameCount = 10, frameSpeed = 0.1, next = "player-walk" })+ loadTexture r "examples/hungeon/assets/player/knife-attack.png" "player-knife-attack" (Just Animation { frameCount = 9, frameSpeed = 0.1, next = "player-idle" })+ loadTexture r "examples/hungeon/assets/player/fire-attack.png" "player-fire-attack" (Just Animation { frameCount = 11, frameSpeed = 0.1, next = "player-idle" })+ loadTexture r "examples/hungeon/assets/player/electric-attack.png" "player-electric-attack" (Just Animation { frameCount = 11, frameSpeed = 0.1, next = "player-idle" })+ loadTexture r "examples/hungeon/assets/player/prismatic-attack.png" "player-prismatic-attack" (Just Animation { frameCount = 11, frameSpeed = 0.1, next = "player-idle" })+ loadTexture r "examples/hungeon/assets/player/hit.png" "player-hit" (Just Animation { frameCount = 5, frameSpeed = 0.1, next = "player-idle" })+ loadTexture r "examples/hungeon/assets/player/shield.png" "player-shield" (Just Animation { frameCount = 6, frameSpeed = 0.1, next = "player-idle" })+ loadTexture r "examples/hungeon/assets/enemies/skeleton/idle.png" "skeleton-idle" (Just Animation { frameCount = 6, frameSpeed = 0.3, next = "skeleton-idle" })+ loadTexture r "examples/hungeon/assets/enemies/skeleton/walk.png" "skeleton-walk" (Just Animation { frameCount = 10, frameSpeed = 0.1, next = "skeleton-walk" })+ loadTexture r "examples/hungeon/assets/enemies/skeleton/attack.png" "skeleton-attack" (Just Animation { frameCount = 9, frameSpeed = 0.1, next = "skeleton-idle" })+ loadTexture r "examples/hungeon/assets/enemies/skeleton/hit.png" "skeleton-hit" (Just Animation { frameCount = 5, frameSpeed = 0.1, next = "skeleton-idle" })+ loadTexture r "examples/hungeon/assets/enemies/skeleton/death.png" "skeleton-death" (Just Animation { frameCount = 17, frameSpeed = 0.1, next = "" })+ loadTexture r "examples/hungeon/assets/enemies/reaper/idle.png" "reaper-idle" (Just Animation { frameCount = 6, frameSpeed = 0.3, next = "reaper-idle" })+ loadTexture r "examples/hungeon/assets/enemies/reaper/walk.png" "reaper-walk" (Just Animation { frameCount = 10, frameSpeed = 0.1, next = "reaper-walk" })+ loadTexture r "examples/hungeon/assets/enemies/reaper/attack.png" "reaper-attack" (Just Animation { frameCount = 15, frameSpeed = 0.1, next = "reaper-idle" })+ loadTexture r "examples/hungeon/assets/enemies/reaper/hit.png" "reaper-hit" (Just Animation { frameCount = 5, frameSpeed = 0.1, next = "reaper-idle" })+ loadTexture r "examples/hungeon/assets/enemies/reaper/death.png" "reaper-death" (Just Animation { frameCount = 15, frameSpeed = 0.1, next = "" })+ loadTexture r "examples/hungeon/assets/enemies/vampire/idle.png" "vampire-idle" (Just Animation { frameCount = 6, frameSpeed = 0.3, next = "vampire-idle" })+ loadTexture r "examples/hungeon/assets/enemies/vampire/walk.png" "vampire-walk" (Just Animation { frameCount = 8, frameSpeed = 0.1, next = "vampire-walk" })+ loadTexture r "examples/hungeon/assets/enemies/vampire/attack.png" "vampire-attack" (Just Animation { frameCount = 16, frameSpeed = 0.1, next = "vampire-idle" })+ loadTexture r "examples/hungeon/assets/enemies/vampire/hit.png" "vampire-hit" (Just Animation { frameCount = 5, frameSpeed = 0.1, next = "vampire-idle" })+ loadTexture r "examples/hungeon/assets/enemies/vampire/death.png" "vampire-death" (Just Animation { frameCount = 14, frameSpeed = 0.1, next = "" })+ loadTexture r "examples/hungeon/assets/enemies/golden-reaper/idle.png" "golden-reaper-idle" (Just Animation { frameCount = 6, frameSpeed = 0.3, next = "golden-reaper-idle" })+ loadTexture r "examples/hungeon/assets/enemies/golden-reaper/walk.png" "golden-reaper-walk" (Just Animation { frameCount = 8, frameSpeed = 0.1, next = "golden-reaper-walk" })+ loadTexture r "examples/hungeon/assets/enemies/golden-reaper/attack.png" "golden-reaper-attack" (Just Animation { frameCount = 15, frameSpeed = 0.1, next = "golden-reaper-idle" })+ loadTexture r "examples/hungeon/assets/enemies/golden-reaper/hit.png" "golden-reaper-hit" (Just Animation { frameCount = 5, frameSpeed = 0.1, next = "golden-reaper-idle" })+ loadTexture r "examples/hungeon/assets/enemies/golden-reaper/death.png" "golden-reaper-death" (Just Animation { frameCount = 15, frameSpeed = 0.1, next = "" })+ loadTexture r "examples/hungeon/assets/particles/fire.png" "particle-fire" (Just Animation { frameCount = 75, frameSpeed = 1/60, next = "" })+ loadTexture r "examples/hungeon/assets/particles/prismatic.png" "particle-prismatic" (Just Animation { frameCount = 81, frameSpeed = 1/60, next = "" })+ loadTexture r "examples/hungeon/assets/tiles/wall-bottom-right.png" "wall-bottom-right" Nothing+ loadTexture r "examples/hungeon/assets/tiles/wall-bottom-left.png" "wall-bottom-left" Nothing+ loadTexture r "examples/hungeon/assets/ui/combat-ui.png" "combat-attack-select-ui" Nothing+ loadTexture r "examples/hungeon/assets/ui/combat-ui-magic.png" "combat-magic-select-ui" Nothing+ loadTexture r "examples/hungeon/assets/ui/combat-ui-parry.png" "combat-parry-ui" Nothing+ loadTexture r "examples/hungeon/assets/ui/transition.png" "transition" Nothing+ loadTexture r "examples/hungeon/assets/tiles/ladder.png" "ladder" Nothing+ loadTexture r "examples/hungeon/assets/items/heart.png" "heart" Nothing+ loadTexture r "examples/hungeon/assets/ui/title-screen.png" "title-screen" Nothing+ loadTexture r "examples/hungeon/assets/ui/settings-screen.png" "settings-screen" Nothing+ loadTexture r "examples/hungeon/assets/ui/start-game/button.png" "start-game-button" Nothing+ loadTexture r "examples/hungeon/assets/ui/start-game/hover.png" "start-game-button-hover" Nothing+ loadTexture r "examples/hungeon/assets/ui/settings/button.png" "settings-button" Nothing+ loadTexture r "examples/hungeon/assets/ui/settings/hover.png" "settings-button-hover" Nothing+ loadTexture r "examples/hungeon/assets/ui/windowed/button.png" "windowed-button" Nothing+ loadTexture r "examples/hungeon/assets/ui/windowed/hover.png" "windowed-button-hover" Nothing+ loadTexture r "examples/hungeon/assets/ui/fullscreen/button.png" "fullscreen-button" Nothing+ loadTexture r "examples/hungeon/assets/ui/fullscreen/hover.png" "fullscreen-button-hover" Nothing+ loadTexture r "examples/hungeon/assets/ui/back/button.png" "back-button" Nothing+ loadTexture r "examples/hungeon/assets/ui/back/hover.png" "back-button-hover" Nothing+ let tiles = [ (ident, path)+ | n <- [1..tileCount]+ , let ident = "tile" ++ show n+ , let path = "examples/hungeon/assets/tiles/tile" ++ show n ++ ".png"+ ] +++ [ (ident, path)+ | n <- [1..wallTopCount]+ , let ident = "wall-top" ++ show n+ , let path = "examples/hungeon/assets/tiles/wall-top" ++ show n ++ ".png"+ ] +++ [ (ident, path)+ | n <- [1..wallBottomCount]+ , let ident = "wall-bottom" ++ show n+ , let path = "examples/hungeon/assets/tiles/wall-bottom" ++ show n ++ ".png"+ ] +++ [ (ident, path)+ | n <- [1..wallLeftCount]+ , let ident = "wall-left" ++ show n+ , let path = "examples/hungeon/assets/tiles/wall-left" ++ show n ++ ".png"+ ] +++ [ (ident, path)+ | n <- [1..wallRightCount]+ , let ident = "wall-right" ++ show n+ , let path = "examples/hungeon/assets/tiles/wall-right" ++ show n ++ ".png"+ ] +++ [ (ident, path)+ | n <- [1..wallBottomLeftElbowCount]+ , let ident = "wall-bottom-left-elbow" ++ show n+ , let path = "examples/hungeon/assets/tiles/wall-bottom-left-elbow" ++ show n ++ ".png"+ ] +++ [ (ident, path)+ | n <- [1..wallBottomRightElbowCount]+ , let ident = "wall-bottom-right-elbow" ++ show n+ , let path = "examples/hungeon/assets/tiles/wall-bottom-right-elbow" ++ show n ++ ".png"+ ]+ mapM_ (\(ident, path) -> loadTexture r path ident Nothing) tiles+ loadFont "examples/hungeon/assets/Roboto-Regular.ttf" "Roboto-Regular" 24+ settings <- liftIO (BL.readFile "examples/hungeon/settings.json" <&> decode) :: System' (Maybe Settings)+ liftIO $ print settings+ forM_ settings (set global)+ createMenuButtons+ createSettingsButtons+ void $ newEntity (TitleScreen, Texture RenTexture { textureRef = "title-screen", animationFrame = Nothing }, Position (V2 0 0), Layer 0, IsVisible True)++createSettingsButtons :: System' ()+createSettingsButtons = do+ settings <- get global+ windowedButton <- newEntity (SettingsUIElement, Button WindowedButton, Position (V2 (-132) 124), Texture RenTexture { textureRef="windowed-button", animationFrame = Nothing }, Layer 1, IsVisible False)+ fullscreenButton <- newEntity (SettingsUIElement, Button FullscreenButton, Position (V2 135 124), Texture RenTexture { textureRef="fullscreen-button", animationFrame = Nothing }, Layer 1, IsVisible False)+ _ <- newEntity (SettingsUIElement, Button BackToTitleButton, Position (V2 (-450) 300), Texture RenTexture { textureRef="back-button", animationFrame = Nothing }, Layer 1, IsVisible False)+ let startActiveButton = case settings of+ Just (Settings { fullscreen = True }) -> fullscreenButton+ _ -> windowedButton+ void $ newEntity (SettingsUIElement, ButtonGroup (V.fromList [windowedButton, fullscreenButton]) startActiveButton)++createMenuButtons :: System' ()+createMenuButtons = do+ _ <- newEntity (MainMenuUIElement, Button StartGameButton, Position (V2 (1280/2 - 50 - 100) (-400)), Texture RenTexture { textureRef="start-game-button", animationFrame = Nothing }, Layer 1, IsVisible True)+ void $ newEntity (MainMenuUIElement, Button SettingsButton, Position (V2 (1280/2 - 100) (-500)), Texture RenTexture { textureRef="settings-button", animationFrame = Nothing }, Layer 1, IsVisible True)++incrementTime :: Float -> System' ()+incrementTime dT = do+ modify global $ \(ShieldCooldown sc) -> ShieldCooldown (max 0 (sc - dT))++-- Remove Velocity component from particles whose destination position has been reached+-- When a particle finishes its animation, remove it from the world+stepParticles :: Float -> System' ()+stepParticles dT = cmapM_ $ \(Particle (Position destP), Position currP, r, e) -> case r of+ Texture rt -> do+ TextureMap tmap <- get global+ when (norm (destP - currP) < 5) $ do+ destroy e (Proxy @Velocity)+ let TextureData _ rs = tmap Map.! textureRef rt+ case rs of+ Just a -> when (fromMaybe 0 (animationFrame rt) + 1 >= frameCount a) $ do+ destroy e (Proxy @(Particle, Renderable, Position, IsVisible, Layer))+ cmapM_ $ \(CombatAttackParticle _, e') -> destroy e' (Proxy @CombatAttackParticle)+ Nothing -> return ()+ _ -> return ()+++triggerEvery :: Float -> Float -> Float -> System' a -> System' ()+triggerEvery dT period offset sys = do+ Time t <- get global+ let t' = t + offset+ trigger = floor (t'/period) /= floor ((t'+dT)/period)+ when trigger $ void sys++toDungeonAction :: System' ()+toDungeonAction = do+ ce <- cfold (\_ (CombatEnemy ce) -> Just ce) Nothing+ case ce of+ Nothing -> return ()+ Just e -> do+ destroy e (Proxy @(Enemy, Renderable, Position, Velocity, Health, Layer, IsVisible))+ cmapM_ $ \(CombatEnemy _, e') -> destroy e' (Proxy @(CombatEnemy, Renderable, Position, Layer, IsVisible))+ set global DungeonState+ cmap $ \(Player, IsVisible _) -> IsVisible True+ cmap $ \(Enemy _, IsVisible _) -> IsVisible True+ cmap $ \(Tile, IsVisible _) -> IsVisible True+ cmap $ \(Wall, IsVisible _) -> IsVisible True+ cmap $ \(Ladder, IsVisible _) -> IsVisible True+ cmap $ \(Heart, IsVisible _) -> IsVisible True+ cmap $ \(CombatPlayer, IsVisible _) -> IsVisible False+ cmap $ \(CombatWall, IsVisible _) -> IsVisible False+ cmap $ \(CombatTile, IsVisible _) -> IsVisible False+ cmapM_ $ \(CombatUI, e) -> destroy e (Proxy @(CombatUI, Position, Renderable, Layer, IsVisible))++toCombatAction :: System' ()+toCombatAction = do+ cmap $ \(Player, IsVisible _) -> IsVisible False+ cmap $ \(Enemy _, IsVisible _) -> IsVisible False+ cmap $ \(Tile, IsVisible _) -> IsVisible False+ cmap $ \(Wall, IsVisible _) -> IsVisible False+ cmap $ \(Ladder, IsVisible _) -> IsVisible False+ cmap $ \(Heart, IsVisible _) -> IsVisible False+ cmap $ \(CombatPlayer, IsVisible _) -> IsVisible True+ cmap $ \(CombatWall, IsVisible _) -> IsVisible True+ cmap $ \(CombatTile, IsVisible _) -> IsVisible True+ _ <- newEntity (CombatUI, Position (V2 0 0), Texture RenTexture { textureRef = "combat-attack-select-ui", animationFrame = Nothing }, Layer 3, IsVisible True)+ set global CombatState++toNextLevelAction :: System' ()+toNextLevelAction = do+ -- Destroy all Walls, Floors, etc.+ cmapM_ $ \(Wall, e) -> destroy e (Proxy @(Wall, Tile, Position, Renderable, BoundaryBox, Layer, IsVisible))+ cmapM_ $ \(Ladder, e) -> destroy e (Proxy @(Ladder, Tile, Position, Renderable, BoundaryBox, Layer, IsVisible))+ cmapM_ $ \(Tile, e) -> destroy e (Proxy @(Tile, Position, Renderable, Layer, IsVisible))+ cmapM_ $ \(Enemy _, e) -> destroy e (Proxy @(Enemy, Position, Velocity, Health, Renderable, BoundaryBox, Layer, IsVisible))+ cmapM_ $ \(Heart, Item, e) -> destroy e (Proxy @(Heart, Item, Position, Renderable, BoundaryBox, Layer, IsVisible))+ cmap $ \(Player, Position _) -> Position playerPos+ generateMap++startDungeonAction :: System' ()+startDungeonAction = do+ _ <- newEntity (Player, Position playerPos, Velocity (V2 0 0), Texture RenTexture { textureRef = "player-idle", animationFrame = Just 0 }, BoundaryBox (16, 26) (0, -11), Health 100, Layer 2, IsVisible True)+ _ <- newEntity (CombatPlayer, Position combatPlayerPos, Texture RenTexture { textureRef = "player-idle", animationFrame = Just 0 }, Layer 2, IsVisible False)+ generateMap+ let offsetX = tileSize / 2 - 1280/2+ offsetY = tileSize / 2 - 720/2+ getTileSprite :: IO String+ getTileSprite = do+ n <- randomRIO (1,tileCount) :: IO Integer+ return $ "tile" ++ show n+ tileList <- liftIO $ sequence [ do+ t <- getTileSprite+ let sref = Texture RenTexture { textureRef = t, animationFrame = Nothing }+ pos = Position (V2 (fromIntegral x * tileSize) (- fromIntegral y * tileSize))++ return (sref, pos)+ | x <- [0..ceiling (1280 / tileSize)], y <- [0..ceiling (720 / tileSize)] ]+ forM_ tileList $ \(s, p) -> void $ newEntity (CombatTile, p, s, Layer 0, IsVisible False)+ cmap $ \(TitleScreen, IsVisible _) -> IsVisible False+ cmap $ \(MainMenuUIElement, IsVisible _) -> IsVisible False+ cmap $ \(SettingsUIElement, IsVisible _) -> IsVisible False+ set global DungeonState++toMenuAction :: System' ()+toMenuAction = do+ -- Destroy all entities except the transition+ -- Destroy all map entities+ cmapM_ $ \(Wall, e) -> destroy e (Proxy @(Wall, Tile, Position, Renderable, BoundaryBox, Layer, IsVisible))+ cmapM_ $ \(Ladder, e) -> destroy e (Proxy @(Ladder, Tile, Position, Renderable, BoundaryBox, Layer, IsVisible))+ cmapM_ $ \(Tile, e) -> destroy e (Proxy @(Tile, Position, Renderable, Layer, IsVisible))+ cmapM_ $ \(Enemy _, e) -> destroy e (Proxy @(Enemy, Position, Velocity, Health, Renderable, BoundaryBox, Layer, IsVisible))+ cmapM_ $ \(Heart, Item, e) -> destroy e (Proxy @(Heart, Item, Position, Renderable, BoundaryBox, Layer, IsVisible))+ -- Destroy player entity+ cmapM_ $ \(Player, e) -> destroy e (Proxy @(Player, Position, Velocity, Renderable, BoundaryBox, Health, Layer, IsVisible))+ -- Destroy combat entities+ cmapM_ $ \(CombatPlayer, e) -> destroy e (Proxy @(CombatPlayer, Position, Renderable, Layer, IsVisible))+ cmapM_ $ \(CombatEnemy _, e) -> destroy e (Proxy @(CombatEnemy, Position, Renderable, Layer, IsVisible))+ -- Destroy Settings menu entities+ cmap $ \(SettingsUIElement, IsVisible _) -> IsVisible False+ cmap $ \(MainMenuUIElement, IsVisible _) -> IsVisible True+ cmap $ \(TitleScreen, IsVisible _) -> IsVisible True+ cmapM_ $ \(CombatUI, e) -> destroy e (Proxy @(CombatUI, Position, Renderable, Layer, IsVisible))+ set global MenuState++stepTransition :: Float -> System' ()+stepTransition dT = cmapM_ $ \(Transition p ang spd fired event, e) -> do+ let p' = p + dT * spd+ when (not fired && p' >= 0.5) $ case event of+ ToCombat -> toCombatAction+ ToDungeon -> toDungeonAction+ ToNextLevel -> toNextLevelAction+ StartDungeon -> startDungeonAction+ ToMenu -> toMenuAction+ ToSettings -> do+ cmap $ \(MainMenuUIElement, IsVisible _) -> IsVisible False+ cmap $ \(SettingsUIElement, IsVisible _) -> IsVisible True+ set global SettingsState+ if p' >= 1 then+ destroy e (Proxy @(Transition, Position, Renderable, Layer, IsVisible))+ else do+ set e Transition { trProgress = p', trAngle = ang, trSpeed = spd, trCoverEventFired = fired || p' >= 0.5, trEvent = event }+ let t = easeInOut (min 1 p)+ dist = Utils.lerp (-2000) 2000 t+ dx = dist * cos ang+ dy = dist * sin ang+ player <- cfold (\_ (Player, Position p, IsVisible r) -> if r then Just p else Nothing) Nothing+ let pos = case player of+ Just (V2 px py) -> V2 (dx - 1300 + px - 1280/2 + 32) (dy + 1200 - (- py - 720/2 + 32))+ Nothing -> V2 (dx - 1300) (dy + 1200)+ set e $ Position pos++stepFloatingText :: Float -> System' ()+stepFloatingText dt = cmapM_ $ \(ft, e) -> if currLifetime ft + dt >= lifetime ft then+ destroy e (Proxy @(FloatingText, Position, Renderable, Velocity, Layer, IsVisible))+ else+ set e $ ft { currLifetime = currLifetime ft + dt }++step :: Float -> System' ()+step dT = do+ gs <- get global+ player <- cfold (\_ (Player, Position p, IsVisible r) -> if r then Just p else Nothing) Nothing+ let func (V2 x y) = case player of+ Just (V2 px py) -> V2 (x - px + 1280/2 - 32) ((-y) + py + 720/2 - 32)+ Nothing -> V2 x (-y)+ set global $ Camera func+ incrementTime dT+ stepParticles dT+ stepTransition dT+ stepFloatingText dT+ case gs of+ DungeonState -> stepDungeon dT+ CombatState -> stepCombat dT+ MenuState -> stepMenu dT+ SettingsState -> stepSettings dT+ _ -> return ()
+ examples/hungeon/Types.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# LANGUAGE DeriveGeneric #-}++module Types where++import Cadence+import Apecs+import Linear+import qualified Data.Set as Set+import qualified Data.Map as Map+import GHC.Generics (Generic)+import Data.Aeson+import qualified Data.Vector as V ++data Settings = Settings {+ fullscreen :: Bool+} deriving (Generic, Show)+instance ToJSON Settings where+ toEncoding = genericToEncoding defaultOptions+instance FromJSON Settings where+ parseJSON = genericParseJSON defaultOptions+instance Semigroup Settings where+ (Settings f1) <> (Settings f2) = Settings f2+instance Monoid Settings where+ mempty = Settings False+instance Component Settings where type Storage Settings = Global Settings++newtype Viewport = Viewport (Int, Int) deriving Show+instance Semigroup Viewport where+ (Viewport (w1, h1)) <> (Viewport (w2, h2)) = Viewport (w1 + w2, h1 + h2)+instance Monoid Viewport where+ mempty = Viewport (1280, 720)+instance Component Viewport where type Storage Viewport = Global Viewport++data UIState = CombatAttackSelectUI | CombatMagicSelectUI deriving (Show, Eq)+instance Semigroup UIState where+ (<>) :: UIState -> UIState -> UIState+ _ <> u2 = u2+instance Monoid UIState where+ mempty :: UIState+ mempty = CombatAttackSelectUI+instance Component UIState where type Storage UIState = Global UIState++data GameState = MenuState | DungeonState | PauseState | CombatState | SettingsState deriving (Show, Eq)+instance Semigroup GameState where+ (<>) :: GameState -> GameState -> GameState+ _ <> gs2 = gs2+instance Monoid GameState where+ mempty :: GameState+ mempty = MenuState+instance Component GameState where type Storage GameState = Global GameState++-- Input key components and types+data GameKey = GkUp + | GkDown + | GkLeft + | GkRight+ | GkEsc+ | GkE+ | GkSpace+ | GkQ+ | GkF+ | GkLMB+ deriving (Show, Eq, Ord)+newtype KeyBindings rawKey = KeyBindings (Map.Map rawKey GameKey)++newtype KeysPressed = KeysPressed (Set.Set GameKey)+instance Semigroup KeysPressed where+ (KeysPressed ks1) <> (KeysPressed ks2) = KeysPressed (ks1 <> ks2)+instance Monoid KeysPressed where+ mempty = KeysPressed Set.empty+instance Component KeysPressed where type Storage KeysPressed = Global KeysPressed++newtype Velocity = Velocity (V2 Float) deriving (Show)+instance Component Velocity where type Storage Velocity = Map Velocity++newtype MoveDirection = MoveDirection (Set.Set Direction) deriving (Show)+instance Component MoveDirection where type Storage MoveDirection = Map MoveDirection++data Direction = UpDir | DownDir | LeftDir | RightDir deriving (Show, Eq, Ord)+instance Enum Direction where+ fromEnum :: Direction -> Int+ fromEnum UpDir = 1+ fromEnum RightDir = 2+ fromEnum DownDir = 3+ fromEnum LeftDir = 4+ toEnum :: Int -> Direction+ toEnum 1 = UpDir+ toEnum 2 = RightDir+ toEnum 3 = DownDir+ toEnum 4 = LeftDir+ toEnum _ = error "Invalid enum value for Direction"++-- Visible components+data Player = Player deriving Show+instance Component Player where type Storage Player = Unique Player++data EnemyType = Reaper | Vampire | Skeleton | GoldenReaper deriving (Show, Enum)++data Enemy = Enemy { enemyType :: EnemyType } deriving Show+instance Component Enemy where type Storage Enemy = Map Enemy++data Floor = Floor deriving Show+instance Component Floor where type Storage Floor = Map Floor++data Wall = Wall deriving Show+instance Component Wall where type Storage Wall = Map Wall++data Tile = Tile deriving Show+instance Component Tile where type Storage Tile = Map Tile++data Ladder = Ladder deriving Show+instance Component Ladder where type Storage Ladder = Map Ladder++-- BoundaryBox (width, height) (offsetX, offsetY) from centre+data BoundaryBox = BoundaryBox (Int, Int) (Int, Int) deriving (Show)+instance Component BoundaryBox where type Storage BoundaryBox = Map BoundaryBox++-- Dungeon components+data RoomType = StartRoom | NormalRoom | BossRoom | HubRoom | LadderRoom | HeartRoom deriving (Show, Eq)++data GameRoom = GameRoom { roomType :: RoomType,+ roomLayout :: [[Char]],+ exits :: [Direction]+ } deriving (Show)+instance Component GameRoom where type Storage GameRoom = Map GameRoom++newtype Health = Health Int deriving (Show, Num)+instance Component Health where type Storage Health = Map Health++data MapError = MapError deriving (Show)+instance Component MapError where type Storage MapError = Unique MapError ++data Heart = Heart deriving (Show)+instance Component Heart where type Storage Heart = Map Heart++data Item = Item deriving (Show)+instance Component Item where type Storage Item = Map Item++-- Combat components+newtype CombatEnemy = CombatEnemy Entity deriving (Show)+instance Component CombatEnemy where type Storage CombatEnemy = Unique CombatEnemy++data CombatPlayer = CombatPlayer deriving (Show)+instance Component CombatPlayer where type Storage CombatPlayer = Unique CombatPlayer++data CombatAttackParticle = CombatAttackParticle Entity deriving (Show)+instance Component CombatAttackParticle where type Storage CombatAttackParticle = Unique CombatAttackParticle++data CombatTurn = CombatTurn TurnState deriving (Show, Eq)+instance Semigroup CombatTurn where+ (<>) :: CombatTurn -> CombatTurn -> CombatTurn+ _ <> t2 = t2+instance Monoid CombatTurn where+ mempty :: CombatTurn+ mempty = CombatTurn PlayerTurn+instance Component CombatTurn where type Storage CombatTurn = Global CombatTurn++data TurnState = PlayerTurn | EnemyTurn | PlayerAttacking | EnemyAttacking | PlayerWin | EnemyWin deriving (Show, Eq)++data CombatTile = CombatTile deriving (Show)+instance Component CombatTile where type Storage CombatTile = Map CombatTile++data CombatWall = CombatWall deriving (Show)+instance Component CombatWall where type Storage CombatWall = Map CombatWall++newtype ShieldCooldown = ShieldCooldown Float deriving (Show, Num)+instance Semigroup ShieldCooldown where+ (<>) :: ShieldCooldown -> ShieldCooldown -> ShieldCooldown+ (ShieldCooldown sc1) <> (ShieldCooldown sc2) = ShieldCooldown (sc1 + sc2) +instance Monoid ShieldCooldown where+ mempty :: ShieldCooldown+ mempty = ShieldCooldown 0+instance Component ShieldCooldown where type Storage ShieldCooldown = Global ShieldCooldown+++data TransitionEvent = ToCombat | ToDungeon | ToNextLevel | StartDungeon | ToMenu | ToSettings deriving (Show, Eq)++-- Transition Components+data Transition = Transition {+ trProgress :: Float, -- 0 to 1+ trAngle :: Float, -- angle in radians+ trSpeed :: Float,+ trCoverEventFired :: Bool,+ trEvent :: TransitionEvent+} deriving (Show)+instance Component Transition where type Storage Transition = Unique Transition++newtype Particle = Particle Position deriving (Show)+instance Component Particle where type Storage Particle = Map Particle++newtype MousePosition = MousePosition (V2 Float) deriving Show+instance Semigroup MousePosition where+ (MousePosition pos1) <> (MousePosition pos2) = MousePosition (pos1 + pos2)+instance Monoid MousePosition where+ mempty = MousePosition (V2 0 0)+instance Component MousePosition where type Storage MousePosition = Global MousePosition++-- UI Components+data ButtonAction = StartGameButton | FullscreenButton | SettingsButton | WindowedButton | BackToTitleButton deriving (Show, Eq)++newtype Button = Button ButtonAction+instance Component Button where type Storage Button = Map Button++data ButtonGroup = ButtonGroup (V.Vector Entity) Entity deriving Show+instance Component ButtonGroup where type Storage ButtonGroup = Map ButtonGroup++newtype TextLabel = TextLabel String deriving Show+instance Component TextLabel where type Storage TextLabel = Map TextLabel++data FloatingText = FloatingText {+ currLifetime :: Float,+ lifetime :: Float+} deriving Show+instance Component FloatingText where type Storage FloatingText = Map FloatingText++data MainMenuUIElement = MainMenuUIElement deriving Show+instance Component MainMenuUIElement where type Storage MainMenuUIElement = Map MainMenuUIElement++data SettingsUIElement = SettingsUIElement deriving Show+instance Component SettingsUIElement where type Storage SettingsUIElement = Map SettingsUIElement++data TitleScreen = TitleScreen deriving Show+instance Component TitleScreen where type Storage TitleScreen = Unique TitleScreen++data CombatUI = CombatUI deriving Show+instance Component CombatUI where type Storage CombatUI = Unique CombatUI++makeWorld' [ ''Settings,+ ''Viewport,+ ''UIState,+ ''GameState,+ ''KeysPressed,+ ''Velocity,+ ''MoveDirection,+ ''Player,+ ''Enemy,+ ''Floor,+ ''Wall,+ ''Tile,+ ''Ladder,+ ''BoundaryBox,+ ''GameRoom,+ ''Health,+ ''MapError,+ ''Heart,+ ''Item,+ ''CombatEnemy,+ ''CombatPlayer,+ ''CombatAttackParticle,+ ''CombatTurn,+ ''CombatTile,+ ''CombatWall,+ ''ShieldCooldown,+ ''Transition,+ ''Particle,+ ''MousePosition,+ ''Button,+ ''ButtonGroup,+ ''TextLabel,+ ''FloatingText,+ ''MainMenuUIElement,+ ''SettingsUIElement,+ ''TitleScreen,+ ''CombatUI+ ]++type System' a = System World a+type Kinetic = (Position, Velocity)
+ examples/hungeon/Utils.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Utils where++import Types+import Linear+import qualified Data.Map as Map+import qualified Data.Vector as V+import Apecs+import Control.Monad+import Data.Maybe ( fromMaybe )+import Cadence++combatPlayerPos :: V2 Float+combatPlayerPos = V2 213 (-360)++combatEnemyPos :: V2 Float+combatEnemyPos = V2 (640 + 1280 / 3) (-360)++playerSpeed, bulletSpeed, enemySpeed, xmin, xmax :: Float+playerSpeed = 250+bulletSpeed = 500+enemySpeed = 275+xmin = -640+xmax = 640++hitBonus, missPenalty :: Int+hitBonus = 100+missPenalty = 40++playerPos, scorePos :: V2 Float+playerPos = V2 0 0+scorePos = V2 xmin (-170)++tileSize :: Num a => a+tileSize = 64++tileCount :: Integer+tileCount = 12++wallBottomCount :: Integer+wallBottomCount = 4++wallLeftCount :: Integer+wallLeftCount = 2++wallRightCount :: Integer+wallRightCount = 2++wallBottomLeftElbowCount :: Integer+wallBottomLeftElbowCount = 2++wallBottomRightElbowCount :: Integer+wallBottomRightElbowCount = 2++wallTopCount :: Integer+wallTopCount = 3++roomOffset :: Num a => a+roomOffset = 4 * tileSize++stepPositionFormula :: Float -> Position -> Velocity -> Position+stepPositionFormula dT (Position p) (Velocity v) = Position (p + dT *^ v)++checkBoundaryBoxIntersection :: V2 Float -> BoundaryBox -> V2 Float -> BoundaryBox -> Bool+checkBoundaryBoxIntersection v1 bb1 v2 bb2 = checkBoundaryBoxTopIntersection v1 bb1 v2 bb2 ||+ checkBoundaryBoxBottomIntersection v1 bb1 v2 bb2 ||+ checkBoundaryBoxLeftIntersection v1 bb1 v2 bb2 ||+ checkBoundaryBoxRightIntersection v1 bb1 v2 bb2++-- Note: Sprite positions are centered based on their Position component+checkBoundaryBoxTopIntersection :: V2 Float -> BoundaryBox -> V2 Float -> BoundaryBox -> Bool+checkBoundaryBoxTopIntersection (V2 x1 y1) (BoundaryBox (w1, h1) (box1, boy1)) (V2 x2 y2) (BoundaryBox (w2, h2) (box2, boy2)) =+ bottom1 < top2 && top1 > top2 && right1 > left2 && left1 < right2+ where+ left1 = x1 + fromIntegral box1 - fromIntegral w1/2+ right1 = x1 + fromIntegral box1 + fromIntegral w1/2+ top1 = y1 + fromIntegral boy1 + fromIntegral h1/2+ bottom1 = y1 + fromIntegral boy1 - fromIntegral h1/2+ left2 = x2 + fromIntegral box2 - fromIntegral w2/2+ right2 = x2 + fromIntegral box2 + fromIntegral w2/2+ top2 = y2 + fromIntegral boy2 + fromIntegral h2/2+checkBoundaryBoxBottomIntersection :: V2 Float -> BoundaryBox -> V2 Float -> BoundaryBox -> Bool+checkBoundaryBoxBottomIntersection (V2 x1 y1) (BoundaryBox (w1, h1) (box1, boy1)) (V2 x2 y2) (BoundaryBox (w2, h2) (box2, boy2)) =+ top1 > bottom2 && bottom1 < bottom2 && right1 > left2 && left1 < right2+ where+ left1 = x1 + fromIntegral box1 - fromIntegral w1/2+ right1 = x1 + fromIntegral box1 + fromIntegral w1/2+ top1 = y1 + fromIntegral boy1 + fromIntegral h1/2+ bottom1 = y1 + fromIntegral boy1 - fromIntegral h1/2+ left2 = x2 + fromIntegral box2 - fromIntegral w2/2+ right2 = x2 + fromIntegral box2 + fromIntegral w2/2+ bottom2 = y2 + fromIntegral boy2 - fromIntegral h2/2+checkBoundaryBoxLeftIntersection :: V2 Float -> BoundaryBox -> V2 Float -> BoundaryBox -> Bool+checkBoundaryBoxLeftIntersection (V2 x1 y1) (BoundaryBox (w1, h1) (box1, boy1)) (V2 x2 y2) (BoundaryBox (w2, h2) (box2, boy2)) =+ right1 > left2 && left1 < left2 && bottom1 < top2 && top1 > bottom2+ where+ left1 = x1 + fromIntegral box1 - fromIntegral w1/2+ right1 = x1 + fromIntegral box1 + fromIntegral w1/2+ top1 = y1 + fromIntegral boy1 + fromIntegral h1/2+ bottom1 = y1 + fromIntegral boy1 - fromIntegral h1/2+ left2 = x2 + fromIntegral box2 - fromIntegral w2/2+ top2 = y2 + fromIntegral boy2 + fromIntegral h2/2+ bottom2 = y2 + fromIntegral boy2 - fromIntegral h2/2+checkBoundaryBoxRightIntersection :: V2 Float -> BoundaryBox -> V2 Float -> BoundaryBox -> Bool+checkBoundaryBoxRightIntersection (V2 x1 y1) (BoundaryBox (w1, h1) (box1, boy1)) (V2 x2 y2) (BoundaryBox (w2, h2) (box2, boy2)) =+ left1 < right2 && right1 > right2 && bottom1 < top2 && top1 > bottom2+ where+ left1 = x1 + fromIntegral box1 - fromIntegral w1/2+ right1 = x1 + fromIntegral box1 + fromIntegral w1/2+ top1 = y1 + fromIntegral boy1 + fromIntegral h1/2+ bottom1 = y1 + fromIntegral boy1 - fromIntegral h1/2+ right2 = x2 + fromIntegral box2 + fromIntegral w2/2+ top2 = y2 + fromIntegral boy2 + fromIntegral h2/2+ bottom2 = y2 + fromIntegral boy2 - fromIntegral h2/2++-- Transition easing+easeInOut :: Float -> Float+easeInOut t = t*t*(3 - 2*t)++lerp :: Float -> Float -> Float -> Float+lerp a b t = a + t * (b - a)++startTransition :: Float -> Float -> TransitionEvent -> System' ()+startTransition angle speed event = do+ cmapM_ $ \(Transition {}, e) -> destroy e (Proxy @(Transition, Position, Renderable))+ void $ newEntity (Transition { trProgress = 0, trAngle = angle, trSpeed = speed, trCoverEventFired = False, trEvent = event }+ , Texture RenTexture { textureRef = "transition", animationFrame = Nothing }+ , Position (V2 1000000 1000000)+ , Layer 4+ , IsVisible True)++-- Update positions based on velocity and delta time+stepPosition :: Float -> System' ()+stepPosition dT = cmap $ uncurry (stepPositionFormula dT)++spawnParticle :: Position -> Position -> String -> Int -> System' Entity+spawnParticle startPos endPos sref frameOffset = do+ TextureMap tmap <- get global+ let t = tmap Map.! sref+ frameCount' = maybe 1 frameCount (animation t)+ frameSpeed' = maybe 0.1 frameSpeed (animation t)+ (Position start) = startPos+ (Position end) = endPos+ vel = (end - start) ^/ ((fromIntegral frameCount' - fromIntegral frameOffset) * frameSpeed')+ newEntity (Particle endPos, startPos, Velocity vel, Texture RenTexture { textureRef = sref, animationFrame = Just frameOffset }, Layer 3, IsVisible True)
+ examples/noughts-and-crosses.lhs view
@@ -0,0 +1,587 @@+= Introduction++This document breaks down a very small game written using `cadence`. We will be making noughts-and-crosses (or tic-tac-toe depending on where you are from). The main focus of this document will be:++1. To highlight how to use `cadence`+2. (Briefly) introduce how to use Apecs+3. Explain what some of the `cadence` functions do under-the-hood+4. Highlight some useful tips for game development using Apecs and Haskell from my experience++Whilst you can run the game by cloning this repository and running `stack run noughts-and-crosses`, I **strongly** recommend you write code yourself as you follow along, as it will help a lot to solidfy the basic concepts. Additionally, Apecs itself has a [tutorial](https://github.com/jonascarpay/apecs/blob/master/examples/Shmup.md), which whilst it does not use `cadence`, I also highly recommend walking through it as well for a more comprehensive overview of how to use Apecs specifically.++= Types and Top-Level Declarations++With all that said, let's start writing some code! ++== Language Extensions and Imports++To start with, we will need some language extensions since Apecs makes use of a lot of extensions for its inner workings.++> {-# LANGUAGE DataKinds #-}+> {-# LANGUAGE FlexibleContexts #-}+> {-# LANGUAGE FlexibleInstances #-}+> {-# LANGUAGE MultiParamTypeClasses #-}+> {-# LANGUAGE ScopedTypeVariables #-}+> {-# LANGUAGE TemplateHaskell #-}+> {-# LANGUAGE TypeApplications #-}+> {-# LANGUAGE TypeFamilies #-}+> {-# LANGUAGE GeneralizedNewtypeDeriving #-}++Next, we need some imports. To work with Apecs and create some game logic, we simply import Apecs directly++> import Apecs++Following this, we import `cadence` at the top-level, which re-exports everything for us.++> import Cadence++Next we want to import `linear` for working with multi-dimensional vectors.++> import Linear++Finally, we will import some other utilities to help us later:++> import qualified Data.Set as Set+> import qualified SDL+> import Control.Monad (when, void)+> import System.Random+> import Data.Maybe (isJust)+> import Data.Foldable (foldl')++== Creating Types and Components++Now with the imports complete, we can define some Components needed for our game logic! If you are not familiar with the notion of an ECS, I would recommend reading the [Apecs paper](https://github.com/jonascarpay/apecs/blob/master/apecs/prepub.pdf) (as well as the other resources linked in the `README.md`) to get an understanding of how it works. In short, an ECS works by:++- Having you create Entities which inhabit the game world+- Tying to Entities a composition of components, used to represent properties about that Entity+- Writing Systems to manipulate all entities with a specific subset of components+++For example:++- Suppose we have three entities+- One entity holds `Player` and `Position` components, and the other two hold `Enemy` and `Position` components+- We could then write a System which updates **all** Entities which have a `Position` component to move them+- We could then write another which updates only the Entity with the `Player` component to decrement some internal health.++In Apecs, Components come in the form of Haskell types being instances of the Component class, and each have their own store specified. A store is simply the data structure used for that component. There are four different types of Stores:+- `Map` - this is the most common one you will use. It allows for each entity to potentially have an instance of this component. +- `Global` - allows data to be stored irrespective to any entity. Specifically, `Global` components are shared across *all* Entities, meaning *any* Entity can be used to access it. +- `Unique` - allows at most one entity to hold the component+- `Cache` - wraps around another store to allow for O(1) reads and writes++For the purpose of noughts-and-crosses, we will need to store the following:+- The current board state - a 3x3 list of the board. For each entry within that list, we will use a Sum type for pattern matching+- The state of the game - a simple Sum type to represent who's Turn it is within the game+- Mouse inputs from the player - using a `Set` for mouse buttons and a 2D vector for the mouse's position in the window+- A countdown timer - a simple floating-point timer which we will decrement each frame until it reaches 0, and then do something+- The noughts or crosses to draw on the screen - more on this below++For the first three, all of them will be stored as a `Global` component, since all of these we want to be able to access irrespective of any specific Entity.++For the countdown timer, we will store it using `Unique`, since for our example we only ever want one timer to be active at any time.++The code for the first four are shown below++> data Turn = PlayerTurn | AITurn | Win | Reset | CheckWinPlayer | CheckWinAI deriving Show+> instance Semigroup Turn where+> _ <> t2 = t2+> instance Monoid Turn where+> mempty = PlayerTurn+> instance Component Turn where type Storage Turn = Global Turn+> +> data BoardEntry = Nought | Cross | Empty deriving (Show, Eq)+> instance Semigroup BoardEntry where+> Empty <> b = b+> b <> Empty = b+> b <> _ = b+> +> newtype Board = Board [[BoardEntry]] deriving Show+> instance Semigroup Board where+> b1 <> b2 = b1 <> b2+> instance Monoid Board where+> mempty = Board $ [+> [Empty, Empty, Empty],+> [Empty, Empty, Empty],+> [Empty, Empty, Empty]+> ]+> instance Component Board where type Storage Board = Global Board+> +> newtype MousePosition = MousePosition (V2 Float)+> instance Semigroup MousePosition where+> (MousePosition m1) <> (MousePosition m2) = MousePosition (m1 + m2)+> instance Monoid MousePosition where+> mempty = MousePosition (V2 0 0) +> instance Component MousePosition where type Storage MousePosition = Global MousePosition+> +> newtype MouseButtons = MouseButtons (Set.Set SDL.MouseButton)+> instance Semigroup MouseButtons where+> (MouseButtons mbs1) <> (MouseButtons mbs2) = MouseButtons (mbs1 `Set.union` mbs2)+> instance Monoid MouseButtons where+> mempty = MouseButtons Set.empty+> instance Component MouseButtons where type Storage MouseButtons = Global MouseButtons+> +> newtype Countdown = Countdown Float deriving (Show, Eq, Num)+> instance Component Countdown where type Storage Countdown = Unique Countdown ++For the storing of the things to draw, we will make use of the `Renderable`, `Position`, `Colour`, and `Layer` components exposed by `cadence`. ++== Explaining a subset of `cadence`++A subset of `Renderable`, and `Position`, `Layer` and `Colour` are shown below.++< data RenTexture = RenTexture+< { textureRef :: String+< -- ^ Identifier for the texture to render+< , animationFrame :: Maybe Int+< -- ^ Frame index for animations, if applicable+< } deriving (Eq, Show)+< +< -- | Component used to tag a single Entity with data for it to be rendered+< data Renderable = Texture RenTexture+< | Text RenText+< | Point RenPoint+< | Line RenLine+< | Rectangle RenRectangle+< | FilledRectangle RenRectangle+< deriving (Eq, Show)+< instance Component Renderable where type Storage Renderable = Map Renderable+< +< newtype Position = Position (V2 Float) deriving (Show, Eq)+< instance Component Position where type Storage Position = Map Position+< +< -- | Associate a colour with an entity for rendering. If no colour is supplied, it will default to black+< newtype Colour = Colour (V4 Word8) deriving (Show, Eq)+< instance Component Colour where type Storage Colour = Map Colour+< +< -- | Layer Component for draw ordering, higher layers are drawn on top of lower layers. Indexing starts at 0+< newtype Layer = Layer Int deriving (Show, Eq, Ord)+< instance Component Layer where type Storage Layer = Map Layer++`Renderable` is used to tag a single Entity with data for it to be drawn, using a Sum type to pattern match on what is to be drawn. Each constructor of `Renderable` then has a Record to store data about it. The Records have many similarities, but also some naunces:++- Only `RenTexture` stores a `Maybe Int` to represent which frame of an animation the texture is on+- Both `RenTexture` and `RenText` store a reference String, which is used as a key for accessing the `TextureMap` and `FontMap` respectively. This reduces memory usage as we abide by the flyweight pattern++`Position` simply represents the position of the Entity with 2D space. An important thing to note is that in SDL, all things are drawn with the top-left being the point of origin, and the x and y axes increase to the right and down respectively.++`Layer` represents the layer that the Entity will be drawn on. As the comment says, higher layers are drawn on lower layers.++`Colour` simply attaches a colour to Entities.++It is important to note that `Renderable`, `Position`, and `Layer` are required for Entities to be drawn. `IsVisible` and `Colour` are optional++- If `IsVisible` is not attached to the Entity, it will default to assuming the Entity is visible.+ - The purpose of `IsVisible` is to allow control over what is drawn more explicitly, e.g. with different game scenes#+- If `Colour` is not supplied, the colour will default to black+ - Note `Colour` is not needed for Entities whose `Renderable` component is a `Texture`++For loading textures or fonts into their respective maps, `cadence` exposes the following two functions:++< -- | Load a font into the 'FontMap'+< loadFont :: (..) => FilePath -> String -> Int -> SystemT w m ()+< loadFont path ident size = ...+< +< -- | Loads a texture into the 'TextureMap' with an associated identifier and optional animation data+< loadTexture :: (..) => SDL.Renderer -> FilePath -> String -> Maybe Animation -> SystemT w m ()+< loadTexture r path ident anim = ...++The actual drawing of everything can either be done yourself by writing your own code, or using `draw` exposed by `cadence`. `draw` handles the entire rendering pipeline for you by making use of the `Renderable`, `Position`, `Layer`, and `Colour` components and allows you to simply write game logic.++Alongside `Renderable`, `Position`, `Colour`, and `Layer`, `cadence` also exposes some other important components. The first of which is `Config`++< -- | Configuration settings for the game upon initialisation+< data Config = Config+< {+< windowTitle :: String, -- ^ Title of the game window+< windowDimensions :: (Int, Int), -- ^ Width and height of the game window in pixels+< backgroundColor :: V4 Word8, -- ^ Background color of the game window as an RGBA value+< targetFPS :: TargetFPS, -- ^ Desired FPS for the game loop+< showFPS :: Maybe String -- ^ Whether to display the current FPS on the screen, and if so, the font to use+< }+< instance Semigroup Config where+< _ <> c2 = c2+< instance Monoid Config where+< mempty = defaultConfig+< instance Component Config where type Storage Config = Global Config ++`Config` is used to configure the game window, and is passed during initialisation, and then stored globally such that we can access it in the future if needed.++A default config is also exposed to get code running quicker:++< defaultConfig :: Config+< defaultConfig = Config+< { windowTitle = "Cadence Game"+< , windowDimensions = (800, 600)+< , backgroundColor = V4 255 255 255 255+< , targetFPS = VSync+< , showFPS = Just "Roboto-Regular"+< }++Following `Config`, there are these other Components:++< newtype Camera = Camera { camFunc :: V2 Float -> V2 Float }+< instance Semigroup Camera where+< (Camera f1) <> (Camera f2) = Camera $ \pos -> f1 (f2 pos)+< instance Monoid Camera where+< mempty = Camera id+< instance Component Camera where type Storage Camera = Global Camera+< +< newtype Time = Time Float deriving (Show, Eq, Num)+< instance Semigroup Time where+< (Time t1) <> (Time t2) = Time (t1 + t2)+< instance Monoid Time where+< mempty = Time 0+< instance Component Time where type Storage Time = Global Time+< +< newtype Renderer = Renderer (Maybe SDL.Renderer)+< instance Semigroup Renderer where+< (Renderer r1) <> (Renderer r2) = Renderer r1+< instance Monoid Renderer where+< mempty = Renderer Nothing+< instance Component Renderer where type Storage Renderer = Global Renderer+< +< newtype Window = Window (Maybe SDL.Window)+< instance Semigroup Window where+< (Window w1) <> (Window w2) = Window w1+< instance Monoid Window where+< mempty = Window Nothing+< instance Component Window where type Storage Window = Global Window++- `Camera` - stores a function that is applied during the `draw` function to offset all `Renderable` Entities. An example use case for this would be keeping a Player always in the centre of the game window.+- `Time` - stores the total accumulated time of the game+- `Renderer` - stores the SDL rendering context if you want to adjust the renderer+- `Window` - stores the SDL window context if you want to adjust the window++== Creating our Game World++With all of our Components defined, we need to create our Game World type. In Apecs, this is done by writing `makeWorld "World" [..]`, however `cadence` exposes `makeWorld'`, which alongside your own Components, also initialises the game world to include the `cadence` specific components. Thus, we need to write the following:++> makeWorld' [''Turn, ''Board, ''MousePosition, ''MouseButtons, ''Countdown]++What this is doing is utilising [Template Haskell](https://wiki.haskell.org/Template_Haskell) to create a `World` data type at compile-time which includes all the necessary data class instances to define our game world within Apecs. If you want to see what this compiles to, you can do so [here](https://hackage.haskell.org/package/apecs-0.9.6/docs/Apecs.html#v:makeWorld).++Finally, I like to define a type synonym around our World to make our lives ever so slightly easier.++> type System' a = System World a++= Game Logic Implementation++Now with our World created, we can now start implementing our noughts-and-crosses game logic. We will first start by defining our Game's configuration.++> config :: Config+> config = defaultConfig { windowTitle = "Noughts and Crosses"+> , windowDimensions = (600,600)+> , showFPS = Nothing }++The only notable configuration here is the window dimensions. For the sake of this toy example, we will make the entire window the noughts and crosses board, which means our mouse position will always be in one of the 9 sections of the board.++Now we will start writing our first system!++> initialise' :: System' ()+> initialise' = do+> let rly = RenLine { lineX = 0, lineY = 600 }+> rlx = RenLine { lineY = 0, lineX = 600}+> line1 <- newEntity (Line rly, Position (V2 200 0), Colour (V4 0 0 0 255), Layer 0, IsVisible True)+> line2 <- newEntity (Line rly, Position (V2 400 0), Colour (V4 0 0 0 255), Layer 0, IsVisible True)+> line3 <- newEntity (Line rlx, Position (V2 0 200), Colour (V4 0 0 0 255), Layer 0, IsVisible True)+> void $ newEntity (Line rlx, Position (V2 0 400), Colour (V4 0 0 0 255), Layer 0, IsVisible True)++`initialise'`, as the name suggests, initialises what we need for our game world. Due to each `Global` component having a `Monoid` instance, their initial value is taken care of for us. Therefore, all we need to do is set up the visual game board by creating lines to be rendered. This is done by:++- Using the `Renderable` and `Position` components, we create two vertical and horizontal lines.+- We also tag each Entity with a Colour component to set it black, make them visible, and render them on the 0th layer+- Inside `RenLine`, `lineX` and `lineY` represent the x and y offset of the line's endpoint from its starting position respectively.+- We use `newEntity` to create a new Entity within our game world with the components specified.++In Apecs, Entities are simply integers. In many cases you will not need to interact with Entity values directly, but it is important to know.++Now let's define our main entry point into the game logic, our `step` function which will be called every frame to update the game world++> step :: Float -> System' ()+> step dt = do+> t <- get global+> case t of+> PlayerTurn -> stepPlayer dt+> AITurn -> stepAI dt+> CheckWinPlayer -> stepCheckWin dt AITurn+> CheckWinAI -> stepCheckWin dt PlayerTurn+> Win -> stepWin dt+> Reset -> stepReset dt++Whilst `step` does not have much code, the use of `get global` introduces a lot of new Apecs concepts:++- `get` is one of the ways to get Component data from an Apecs Store given an Entity+- `get` infers from the type signature which Component you are wanting to access, and using that determines what Store to access+ - Because of this, if GHC cannot infer the type, you will need to add a type constraint, such as `t <- get global :: System' Turn`+- In our case, we want to access `Turn` which is stored in `Global`+- As mentioned earlier, all `Global` components are accessible using any Entity, therefore we use the alias `global` exposed by Apecs for nice readability+ - Under the hood, `global` is defined as -1++After getting our Turn component, we then pattern match on its value to step accordingly. This allows GHC to infer the type of `t`, resulting in us not needing a type constraint.++Before getitng to our turn-specific step functions, I want to introduce a helper to reduce the amount of code we will need to write.++> updateBoard :: Board -> Int -> Int -> BoardEntry -> System' ()+> updateBoard (Board b) r c t = do+> let (l1,r1) = splitAt c b+> (l2,r2) = splitAt r (head r1)+> r2' = t : tail r2+> r2'' = l2 ++ r2'+> r1' = r2'' : tail r1+> b' = l1 ++ r1'+> x = 200 * fromIntegral r+> y = 200 * fromIntegral c+> case t of+> Nought -> do+> _ <- newEntity (Rectangle RenRectangle { rectSize = V2 100 100 }, Position (V2 (x+50) (y+50)), Colour (V4 0 0 0 255), Layer 1, IsVisible True)+> modify global $ \(_ :: Turn) -> CheckWinPlayer+> Cross -> do+> _ <-newEntity (Line RenLine { lineX = 100, lineY = 100 }, Position (V2 (x+50) (y+50)), Colour (V4 0 0 0 255), Layer 1, IsVisible True)+> _ <- newEntity (Line RenLine { lineX = -100, lineY = 100 }, Position (V2 (x + 150) (y+50)), Colour (V4 0 0 0 255), Layer 1, IsVisible True)+> modify global $ \(_ :: Turn) -> CheckWinAI+> Empty -> return ()+> modify global $ \(Board _) -> Board b'++`updateBoard` takes our current game board, a row and column index, and the tile we want to replace the existing one with, and replaces that tile whilst also creating new Entities with `Renderable` and `Position` components to make them visible. It also progresses our game state so that we check for a win afterwards.++The new concept in `updateBoard` is `modify`. What `modify` does is:++- Takes a single Entity to update a single Component for+- Applies a function to the original Component and stores the result++In our case, we apply `modify` to `global` to simply progress our `Turn` state.++Now let's implement our turn-specific step functions. We will go top-down in our implementations.++> stepPlayer :: Float -> System' ()+> stepPlayer dt = do+> MousePosition (V2 mx my) <- get global+> MouseButtons mbs <- get global+> (Board b) <- get global+> let r = floor (mx / 200)+> c = floor (my / 200)+> t = (b !! c) !! r+> case t of+> Empty -> when (SDL.ButtonLeft `Set.member` mbs) $ updateBoard (Board b) r c Nought+> _ -> return ()++`stepPlayer` does the following:++- Gets our globally stored mouse position and currently pressed mouse buttons+- Accesses the current tile being hovered over by the mouse+- If the tile is empty and the left mouse button is currently pressed, then updates the board and switches the game's state to check the board for a potential win++> stepAI :: Float -> System' ()+> stepAI dt = do+> (Board b) <- get global+> let getTile = do+> n <- randomRIO (0,8) :: IO Int+> let r = n `div` 3+> c = n `mod` 3+> r' = fromIntegral r+> c' = fromIntegral c+> t = (b !! c') !! r'+> case t of+> Empty -> return (r',c')+> _ -> getTile+> (r,c) <- liftIO getTile+> updateBoard (Board b) r c Cross++`stepAI` does the same as `stepPlayer`, except it uses a random integer instead of the mouse position for tile placement.++> stepCheckWin :: Float -> Turn -> System' ()+> stepCheckWin dt t = do+> (Board b) <- get global+> let lines = [(0,1,2), (3,4,5), (6,7,8), (0,3,6), (1,4,7), (2,5,8), (0,4,8), (2,4,6)]+> checkLine (Board b) (n1,n2,n3) +> | t1 == Nought && t2 == Nought && t3 == Nought = Just (n1,n2,n3)+> | t1 == Cross && t2 == Cross && t3 == Cross = Just (n1,n2,n3)+> | otherwise = Nothing+> where+> r1 = n1 `div` 3+> c1 = n1 `mod` 3+> r2 = n2 `div` 3+> c2 = n2 `mod` 3+> r3 = n3 `div` 3+> c3 = n3 `mod` 3+> t1 = (b !! c1) !! r1+> t2 = (b !! c2) !! r2+> t3 = (b !! c3) !! r3+> isFull = Empty `notElem` concat b+> line = foldl' (\acc l -> if isJust acc then acc else checkLine (Board b) l) Nothing lines+> case line of+> Just (n1,_,n3) -> do+> let r1 = n1 `div` 3+> c1 = n1 `mod` 3+> r3 = n3 `div` 3+> c3 = n3 `mod` 3+> c1' = fromIntegral c1+> c3' = fromIntegral c3+> r1' = fromIntegral r1+> r3' = fromIntegral r3+> rl = RenLine { lineX = 0+> , lineY = 0 }+> if c1' == c3' then+> void $ newEntity (Line rl { lineX = 600+> , lineY = 0 }, Position (V2 0 (200 * c1' + 100))+> , Layer 2+> , Colour (V4 255 0 0 255)+> , IsVisible True)+> else if r1' == r3' then+> void $ newEntity (Line rl { lineX = 0+> , lineY = 600 }, Position (V2 (200 * r1' + 100) 0)+> , Layer 2+> , Colour (V4 255 0 0 255)+> , IsVisible True)+> else if (c1' > c3') then+> void $ newEntity (Line rl { lineX = -600+> , lineY = 600 }, Position (V2 600 0)+> , Layer 2+> , Colour (V4 255 0 0 255)+> , IsVisible True)+> else+> void $ newEntity (Line rl { lineX = 600+> , lineY = 600 }, Position(V2 0 0)+> , Layer 2+> , Colour (V4 255 0 0 255)+> , IsVisible True)+> _ <- newEntity (Countdown 3.0)+> modify global $ \(_ :: Turn) -> Win+> Nothing -> if isFull then do+> _ <- newEntity (Countdown 3.0)+> modify global $ \(_ :: Turn) -> Win+> else+> modify global $ \(_ :: Turn) -> t++`stepCheckWin` does the following:++- Checks all possible locations for a complete line+- If a complete line is found, it creates a new line Entity to highlight the line along starting a countdown timer of 3 seconds+ - For wins which are straight lines, we offset them to be in the centre of the square+- If the board is full and no one has a line (i.e. we reach a tie), then we just progress to the `Win` state to simulate the cooldown before wiping the board++> stepWin :: Float -> System' ()+> stepWin dt = cmapM $ \(Countdown t) -> if t < 0+> then do+> modify global $ \(_ :: Turn) -> Reset+> return $ Right $ Not @Countdown+> else return $ Left $ Countdown (t-dt) ++What `stepWin` does is very simple; it counts down our timer and if it reaches 0, it changes our game state to reset the board. However, it introduces a lot of new Apecs concepts, and so we will focus a lot on it.++`cmap`, and its monadic variant `cmapM`, is Apecs' form of `map`. Its functionality is dependent on the type of the function you provide it. For example:++- Suppose we provide `cmap` a function of type `(Componment1,Component2) -> Component1`+- `cmap` iterates over all entities that has the component on the left-hand side, and then writes to the component on the right-hand side+- In the example, we have a tuple on the left-hand side. In Apecs tuples of Components are considered a Component+ - This is an example of how Components can be composed together+- Tuples in Apecs work by mapping over all entities which have the first component, and then checks if those entities also has the subsequent components in the tuple.+- For our case, this means Apecs will get all Entities which have `Component1`, and then also check if they have `Component2` as well.+- Then, by the right-hand side, Apecs will update `Component1` for that Entity++When composing components together, for performance concerns it is important to include the most uniquely identifying component as the first component. For example, suppose we have a `Player`, `Enemy`, and `Position` component. In our game, we have only one player, but multiple enemies, and all of them have a `Position` component. If we wrote a cmap as follows:++< cmap $ \(Position _, Player) -> ...++That would be less efficient than++< cmap $ \(Player, Position _) -> ...++Since Apecs would be checking all Entities with a Position if they were a player, rather than checking just a single entity with Player if it had a Position component.++For the case of `stepWin`, we actually use `cmapM`. Like with `map` and its monadic variant `mapM`, `cmapM` is Apecs' monadic variant of `cmap`, allowing for a monadic function to be passed. For our case, this monadic function allows us to do two operations rather than one.++Now let's actually focus on the type of `stepWin`'s `cmapM`, since it also is something of interest:++- The type of our function is `Countdown -> System' (Either Countdown (Not Countdown))`+- If we remove the `System'` Monad from the type, like how it would be for `cmap`, we would get the following `Countdown -> Either Countdown (Not Countdown)`+- Our type specifies that we get an Entity which has a `Countdown` component, and then return `Either Countdown (Not Countdown)`++So we know what our type is, and know what the left-hand side does, but what about the right, i.e. what does `Either Countdown (Not Countdown)` do for Apecs?++- In Apecs, `Either a b` is used to represent two possible outcomes, captured by our `Left a` and `Right b` respectively+- For our case, we either write to `Countdown` in the case of our `Left`, or we have `Not Countdown` for our `Right`+- `Not :: Not c` is used to delete something, meaning in our `Right` case we delete the `Countdown` component from the Entity.+ - Note - there are other ways to delete components, such as with `Maybe`, or by using `destroy`. We will showcase these later.++It is important to note that, when destroying an Entity, make sure to specify **all** the Entity's components. Failing to do so will mean you have components floating around in memory, which not only causes a memory leak but may affect logic!++> stepReset :: Float -> System' ()+> stepReset dt = do+> cmap $ \(_ :: Renderable, Position _) -> (Nothing :: Maybe (Renderable, Position))+> initialise'+> modify global $ \(_ :: Board) -> mempty :: Board+> modify global $ \(_ :: Turn) -> PlayerTurn++`stepReset` simply deletes all entities with a `Renderable` component along with their `Position` component, and resets the board by using its `mempty`. Since this removes every Renderable entity, we then re-initialise the grid lines, and then give the player the turn to play.++The way we delete components in `stepReset` is using `Maybe`. Like with `Either`, `Maybe c = Just c | Nothing` represents optionality, but is a bit more explicit in what it represents++- `Just c` represents writing the component `c`+- `Nothing` represents deleting the component `c`++For our case, this method is not ideal. To ensure we delete all the components captured by `c`, we have to also read `Position`. This is unnecessary since we just want to delete it. Therefore, a better alternative would have been to use `Either` or `destroy`. We have already seen `Either`, so I will only show `destroy` below++< cmapM_ $ \(_ :: Renderable, e) -> destroy e (Proxy @(Renderable, Position))++As you have probably noticed, all our step functions take in a `Float` named `dt`, but never actually use it. Whilst in practice you would simply adjust their type to never take it as an input (which is the right thing to do!), I wanted to reinforce the idea of passing around `dt`.++When running a game with `cadence`, `dt` is given to your top-level step function, and represents the amount of time elapsed between the previous frame and the current frame in milliseconds. Therefore, in any case where you need to have frame specific timings, you will need to make use of the input `dt`.++Now that we have written all of the systems needed for our game logic, we have two things left to do:++1. Write an event handler+2. Write our `main :: IO ()` function++In `cadence`, events are polled for you, and then passed onto your event handler as `[SDL.EventPayload]`. If you want to see all the possible events that are polled and sent for handling, please refer to the [SDL Documentation](https://hackage.haskell.org/package/sdl2-2.5.5.0/docs/SDL-Event.html#t:EventPayload). SDL's `EventPayload` makes use of Sum types and records for capturing all possible event payload, and so we will use top-level pattern matching for our event handlers++> handlePayload :: [SDL.EventPayload] -> System' ()+> handlePayload = mapM_ handleEvent+> +> handleEvent :: SDL.EventPayload -> System' ()+> handleEvent (SDL.MouseMotionEvent ev) = handleMouseMotionEvent ev+> handleEvent (SDL.MouseButtonEvent ev) = handleMouseButtonEvent ev+> handleEvent _ = return ()+> +> handleMouseMotionEvent :: SDL.MouseMotionEventData -> System' ()+> handleMouseMotionEvent ev = let+> (SDL.P pos) = SDL.mouseMotionEventPos ev+> in+> modify global $ \(MousePosition _ ) -> MousePosition $ fromIntegral <$> pos+> +> handleMouseButtonEvent :: SDL.MouseButtonEventData -> System' ()+> handleMouseButtonEvent ev+> | SDL.mouseButtonEventMotion ev == SDL.Pressed = modify global $ \(MouseButtons mbs) -> MouseButtons (Set.insert (SDL.mouseButtonEventButton ev) mbs)+> | SDL.mouseButtonEventMotion ev == SDL.Released = modify global $ \(MouseButtons mbs) -> MouseButtons (Set.delete (SDL.mouseButtonEventButton ev) mbs)+> | otherwise = return ()++Our `main :: IO ()` function is the entrypoint into our program, and is used to start our game. As mentioned, `cadence` exposes 3 main functions to help with this:++- `initialise` is used to create the SDL window and renderer context, and needs your Apecs `World`+- `run` is the main game loop, which takes the entry point for stepping your game world, your event handler, and a draw function+- `draw` which is the default draw function, and handles the entire rendering pipeline for you by using all entities which have `Renderable`, `Position` and `Layer`, and optionally `Colour` and `IsVisible` components++> main :: IO ()+> main = do+> w <- initWorld+> runWith w initialise'+> (window, renderer) <- initialise w config+> run w renderer window step handlePayload draw++There are two new Apecs concepts here:++- `initWorld` - this function is generated by `makeWorld'`, and is used to get your World state in the form of `w`+- `runWith` - this runs a given System inside your world state++And just like that, our game is complete!++= Tips, Tricks, and Advice for Developing Games in Haskell++With our noughts-and-crosses game complete, I now want to just highlight and collate together some tips for developing games, especially with Apecs, SDL, and `cadence`++- Always try write game logic as separated as possible. Not only is this good software practice in general, but for Haskell specifically, it is one of the best practices you can follow as it will allow for more reusable, idiomatic code through the use of e.g. higher order functions.+- When working with Apecs, since you are always inside a `System' a` Monad, it is very tempting to make use of functions like `cmapM`, `cfoldM`, etc. However, if you are able to write a Component logic which does not need to be inside a Monadic context, then you should not be inside one, as being inside one means you have the possiblity of introducing side effects.+- Interactable user interfaces are inherently stateful things. Therefore, when attempting to build one I recommend decomposing each UI element by exploiting Haskell's type system, and making use of functions being first-class citizens.+- SDL allows for a lot of changes to the renderer or window to be done pragmatically. Therefore, you are able to do pretty much anything you desire. However, the `sdl2` library binds onto the underlying C API for SDL2, and therefore has quite a bit of boilerplate and is very stateful+- When wanting to handle multiple different events, such as keyboard input, mouse movement, mouse buttons, etc. it is often quite useful having Globally stored data structures for storing the currently pressed buttons, like we did for `MouseButtons`, as it allows you to access them from anywhere within your game logic.
+ src/Cadence.hs view
@@ -0,0 +1,22 @@+module Cadence (+ -- * Types+ Config(..), Renderable(..), FPS, Position(..), Time(..), Renderer(..), Window(..), TargetFPS(..), RenPoint(..), RenRectangle(..), RenLine(..), Camera(..), Colour(..), Layer(..), IsVisible(..), defaultConfig,++ -- * Systems+ initialise, run, makeWorld', getMaybe, stepAnimations,++ -- * Texture+ TextureData(..), Animation(..), TextureMap(..), RenTexture(..), loadTexture,++ -- * Font+ FontMap(..), RenText(..), loadFont,++ -- * Draw+ draw, drawTexture, drawText, drawLine, drawPoint, drawRect, drawFilledRect+) where++import Cadence.Types+import Cadence.Systems+import Cadence.Texture+import Cadence.Font+import Cadence.Draw
+ src/Cadence/Draw.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+++module Cadence.Draw (draw,+ drawTexture,+ drawText,+ drawLine,+ drawPoint,+ drawRect,+ drawFilledRect) where++import qualified SDL+import qualified SDL.Font as TTF+import Apecs+import Cadence.Types+import Cadence.Texture+import Cadence.Font (RenText(..), FontMap(..))+import Cadence.Systems (getMaybe)+import Control.Monad.IO.Class (MonadIO)+import qualified Data.Vector.Mutable as MV+import qualified Data.Text as T+import qualified Data.Map as Map+import Linear+import Data.Word (Word8)+import Control.Monad (join, when)+import Data.Foldable (forM_)+import Data.Maybe (isNothing, fromJust)++{-|+Draw all 'Renderable' entities onto their appropriate layer.+This function is the typical draw function to pass to 'run', however you are free to implement your own+Every 'Renderable' Entity must have a 'Position' component. If a 'Renderable' Entity is set to not be visible, it is ignored+It is important to note that elements are drawn with top-left origin, and the x and y axes increase towards the right and down respectively.+-}+draw :: forall w.+ (Has w IO TextureMap+ , Get w IO Renderable+ , Get w IO FontMap+ , Get w IO Camera+ , Get w IO Position+ , Get w IO Config+ , Get w IO Layer+ , Has w IO IsVisible+ , Get w IO Colour)+ => SDL.Renderer+ -> FPS+ -> System w ()+draw renderer fps = do+ c <- get global+ Camera cam <- get global+ let (vw, vh) = windowDimensions c+ isInView :: V2 Float -> (Float,Float) -> Bool+ isInView pos (w,h) =+ let+ (V2 x y) = cam pos+ leftInView = x <= fromIntegral vw+ rightInView = x + w >= 0+ topInView = y <= fromIntegral vh+ bottomInView = y + h >= 0+ in+ leftInView && rightInView && topInView && bottomInView+ maxLayer <- cfold (\acc (_ :: Renderable, Position _, Layer n) -> max acc n) 0+ layerBuffers <- liftIO $ MV.replicateM (maxLayer + 1) (MV.new 1024) -- Preallocate mutable vectors for each layer+ layerCounts <- liftIO $ MV.replicate (maxLayer + 1) 0 -- Track the number of entities in each layer+ TextureMap tm <- get global+ FontMap fm <- get global+ -- Take an action to draw an entity on a given layer, and store it in the appropriate layer buffer+ let updateLayer :: Int -> System w () -> System w ()+ updateLayer i command = do+ buf <- liftIO $ MV.read layerBuffers i+ i' <- liftIO $ MV.read layerCounts i+ buf' <- if i' == MV.length buf then do+ newBuf <- liftIO $ MV.grow buf (MV.length buf) -- Double the buffer size+ liftIO $ MV.write layerBuffers i newBuf+ return newBuf+ else return buf+ liftIO $ MV.write buf' i' command+ liftIO $ MV.write layerCounts i (i' + 1)+ -- Iterate through all Renderable entities, generate their draw commands and store them in the appropriate layer buffer+ cmapM_ $ \(r, Position pos, Layer n, e) -> case r of+ -- For each Renderable type, we do the following:+ -- 1. Check if the entity is visible by using a Proxy on the IsVisible component, if not we skip it+ -- 2. For Textures and Text, we check if their referenced resource exists in the TextureMap/FontMap, if not we skip it+ -- 3. Check if the entity is in view of the camera, if not we skip it+ -- 4. If the entity has a Colour component, we use that colour to draw it, otherwise we default to black+ -- 5. Add the drawing action to the appropriate layer buffer+ Texture t -> getMaybe e (Proxy @IsVisible) >>= \res -> when (isNothing res || (let IsVisible visible = fromJust res in visible)) $ case Map.lookup (textureRef t) tm of+ Just td -> do+ info <- liftIO $ SDL.queryTexture (texture td)+ IsVisible b <- get e+ let w = fromIntegral $ SDL.textureWidth info+ h = fromIntegral $ SDL.textureHeight info+ when (isInView pos (w,h) && b) $ updateLayer n (drawTexture renderer td (cam pos) (animationFrame t))+ Nothing -> return () -- Texture not found, skip drawing+ Text t -> getMaybe e (Proxy @IsVisible) >>= \res -> when (isNothing res || (let IsVisible visible = fromJust res in visible)) $ case Map.lookup (fontRef t) fm of+ Just font -> do+ IsVisible b <- get e+ (w,h) <- liftIO $ TTF.size font (T.pack $ displayText t)+ when (isInView pos (fromIntegral w, fromIntegral h) && b) $ exists e (Proxy @Colour) >>= \c' -> if c' then+ get e >>= \(Colour col) -> updateLayer n (drawText renderer t font (cam pos) col)+ else+ updateLayer n (drawText renderer t font (cam pos) (V4 0 0 0 255))+ Nothing -> return () -- Font not found, skip drawing+ Point p -> getMaybe e (Proxy @IsVisible) >>= \res -> when (isNothing res || (let IsVisible visible = fromJust res in visible)) $ do+ IsVisible b <- get e+ when (isInView pos (0,0) && b) $ exists e (Proxy @Colour) >>= \c' -> if c' then+ get e >>= \(Colour col) -> updateLayer n (drawPoint renderer (cam pos) col)+ else+ updateLayer n (drawPoint renderer (cam pos) (V4 0 0 0 255))+ Line l -> getMaybe e (Proxy @IsVisible) >>= \res -> when (isNothing res || (let IsVisible visible = fromJust res in visible)) $ do+ IsVisible b <- get e+ when (isInView pos (lineX l, lineY l) && b) $ exists e (Proxy @Colour) >>= \c' -> if c' then+ get e >>= \(Colour col) -> updateLayer n (drawLine renderer l (cam pos) col)+ else+ updateLayer n (drawLine renderer l (cam pos) (V4 0 0 0 255))+ Rectangle r' -> getMaybe e (Proxy @IsVisible) >>= \res -> when (isNothing res || (let IsVisible visible = fromJust res in visible)) $ do+ IsVisible b <- get e+ let (V2 w h) = rectSize r'+ when (isInView pos (w,h) && b) $ exists e (Proxy @Colour) >>= \c' -> if c' then+ get e >>= \(Colour col) -> updateLayer n (drawRect renderer r' (cam pos) col)+ else+ updateLayer n (drawRect renderer r' (cam pos) (V4 0 0 0 255))+ FilledRectangle r' -> getMaybe e (Proxy @IsVisible) >>= \res -> when (isNothing res || (let IsVisible visible = fromJust res in visible)) $ do+ IsVisible b <- get e+ let (V2 w h) = rectSize r'+ when (isInView pos (w,h) && b) $ exists e (Proxy @Colour) >>= \c' -> if c' then+ get e >>= \(Colour col) -> updateLayer n (drawFilledRect renderer r' (cam pos) col)+ else+ updateLayer n (drawFilledRect renderer r' (cam pos) (V4 0 0 0 255))+ case showFPS c of+ Just ref -> case Map.lookup ref fm of+ Just font -> updateLayer maxLayer (drawText renderer (RenText ref (show fps ++ " FPS")) font (V2 10 10) (V4 0 255 0 255))+ Nothing -> return () -- Font not found, skip drawing FPS+ Nothing -> return () -- Not showing FPS, skip drawing it+ -- Iterate through each layer buffer and execute the drawing commands in order+ forM_ [0..maxLayer] $ \i -> do+ buf <- liftIO $ MV.read layerBuffers i+ count <- liftIO $ MV.read layerCounts i+ forM_ [0..(count - 1)] $ \j -> do+ join $ liftIO $ MV.read buf j -- Execute the drawing command++-- | Draw a line given its 'RenLine', 'Position' and colour+drawLine :: SDL.Renderer -> RenLine -> V2 Float -> V4 Word8 -> System w ()+drawLine r l pos col = do+ SDL.rendererDrawColor r SDL.$= col+ SDL.drawLine r (SDL.P $ floor <$> pos) (SDL.P $ floor <$> (pos + V2 (lineX l) (lineY l)))++-- | Draw a point given its 'Position' and colour+drawPoint :: SDL.Renderer -> V2 Float -> V4 Word8 -> System w ()+drawPoint r pos col = do+ SDL.rendererDrawColor r SDL.$= col+ SDL.drawPoint r (SDL.P $ floor <$> pos)++-- | Draw a rectangle outline given its 'RenRectangle', 'Position' and colour+drawRect :: SDL.Renderer -> RenRectangle -> V2 Float -> V4 Word8 -> System w ()+drawRect r rect pos col = do+ SDL.rendererDrawColor r SDL.$= col+ SDL.drawRect r $ Just (SDL.Rectangle (SDL.P (floor <$> pos)) (floor <$> rectSize rect))++-- | Draw a filled rectangle given its 'RenRectangle', 'Position' and colour+drawFilledRect :: SDL.Renderer -> RenRectangle -> V2 Float -> V4 Word8 -> System w ()+drawFilledRect r rect pos col = do+ SDL.rendererDrawColor r SDL.$= col+ SDL.fillRect r $ Just (SDL.Rectangle (SDL.P (floor <$> pos)) (floor <$> rectSize rect))++{-|+Draw a 'Texture' given its 'TextureData' and 'Position'+If either the 'TextureData' does not have an 'Animation' or no frame index is provided, the texture will be drawn as if it was static.+-}+drawTexture :: SDL.Renderer -> TextureData -> V2 Float -> Maybe Int -> System w ()+drawTexture r (TextureData t (Just a)) pos (Just n) = do+ info <- liftIO $ SDL.queryTexture t+ let w = SDL.textureWidth info+ h = SDL.textureHeight info+ fw = w `div` fromIntegral (frameCount a)+ srcRect = SDL.Rectangle (SDL.P (V2 (fromIntegral n * fw) 0)) (V2 fw h)+ dstRect = SDL.Rectangle (SDL.P (floor <$> pos)) (V2 fw h)+ liftIO $ SDL.copy r t (Just srcRect) (Just dstRect)+drawTexture r (TextureData t _) pos _ = do+ info <- liftIO $ SDL.queryTexture t+ let w = SDL.textureWidth info+ h = SDL.textureHeight info+ pos' = SDL.Rectangle (SDL.P (floor <$> pos)) (V2 w h)+ liftIO $ SDL.copy r t Nothing (Just pos')++-- | Draw text given its 'RenText', 'Font' and 'Position'+drawText :: SDL.Renderer -> RenText -> TTF.Font -> V2 Float -> V4 Word8 -> System w ()+drawText r t font pos col = do+ (tex, size) <- generateSolidText r font col (displayText t)+ SDL.copy r tex Nothing (Just $ SDL.Rectangle (SDL.P (floor <$> pos)) (fromIntegral <$> size))+ SDL.destroyTexture tex++generateSolidText :: MonadIO m => SDL.Renderer -> TTF.Font -> TTF.Color -> String -> m (SDL.Texture, SDL.V2 Int)+generateSolidText r font = generateText r font (TTF.solid font)++generateText :: MonadIO m => SDL.Renderer -> TTF.Font -> (TTF.Color -> T.Text -> m SDL.Surface) -> TTF.Color -> String -> m (SDL.Texture, SDL.V2 Int)+generateText r font f col str = do+ let t = T.pack str+ surface <- f col t+ tex <- liftIO $ SDL.createTextureFromSurface r surface+ SDL.freeSurface surface+ (w,h) <- liftIO $ TTF.size font t+ return (tex, V2 w h)
+ src/Cadence/Font.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}++module Cadence.Font (FontMap(..), RenText(..), loadFont) where++import qualified SDL.Font as TTF+import Apecs+import qualified Data.Map as Map+import Control.Monad.IO.Class (MonadIO)++-- | Stores the SDL fonts loaded in the game, mapped by their identifiers+newtype FontMap = FontMap (Map.Map String TTF.Font)+instance Semigroup FontMap where+ (FontMap m1) <> (FontMap m2) = FontMap (Map.union m1 m2)+instance Monoid FontMap where+ mempty = FontMap Map.empty+instance Component FontMap where type Storage FontMap = Global FontMap++-- | Represents a text element for rendering+data RenText = RenText+ { fontRef :: String+ , displayText :: String+ } deriving (Show, Eq)++-- | Load a font into the 'FontMap'+loadFont :: forall w m. (Has w m FontMap, MonadIO m) + => FilePath+ -> String -- ^ Font identifier+ -> Int -- ^ Font size in points+ -> SystemT w m ()+loadFont path ident size = do+ font <- liftIO $ TTF.load path size+ modify global $ \(FontMap m) -> FontMap (Map.insert ident font m)
+ src/Cadence/Systems.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Cadence.Systems (initialise, run, makeWorld', stepAnimations, getMaybe) where++import Apecs+import Cadence.Types+import Cadence.Texture+import Cadence.Font (FontMap(..), loadFont)+import qualified SDL+import qualified SDL.Font as TTF+import qualified SDL.Image as IMG+import qualified Data.Text as T+import Language.Haskell.TH.Syntax+import Control.Monad (unless)+import qualified SDL.Raw+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, isNothing, fromJust)+import System.Exit (exitSuccess)+import Linear++-- | Initialise the SDL window and renderer+initialise :: forall w.+ (Set w IO Renderer+ , Set w IO Window+ , Set w IO Config+ , Set w IO FontMap)+ => w+ -> Config -- ^ Game config+ -> IO (SDL.Window, SDL.Renderer) -- ^ Returns the created window and renderer contexts+initialise world config = do+ SDL.initialize [SDL.InitVideo]+ TTF.initialize+ IMG.initialize []+ let (w,h) = windowDimensions config+ title = windowTitle config+ windowConfig = SDL.defaultWindow { SDL.windowInitialSize = V2 (fromIntegral w) (fromIntegral h),+ SDL.windowMode = SDL.Windowed,+ SDL.windowResizable = False }+ window <- SDL.createWindow (T.pack title) windowConfig+ runWith world (set global $ Window $ Just window)+ runWith world (set global config)++ let rendererType = case targetFPS config of+ VSync -> SDL.AcceleratedVSyncRenderer+ _ -> SDL.AcceleratedRenderer+ rendererConfig = SDL.defaultRenderer { SDL.rendererType = rendererType,+ SDL.rendererTargetTexture = True }+ renderer <- SDL.createRenderer window (-1) rendererConfig+ runWith world (set global $ Renderer $ Just renderer)+ runWith world (loadFont "resources/Roboto-Regular.ttf" "Roboto-Regular" 24)++ return (window, renderer)++-- | Main game loop+run :: forall w.+ (Has w IO Time+ , Has w IO TextureMap+ , Get w IO Renderable+ , Has w IO IsVisible+ , Get w IO Config)+ => w -- ^ World state+ -> SDL.Renderer -- ^ SDL renderer context+ -> SDL.Window -- ^ SDL window context+ -> (Float -> System w ()) -- ^ World step function+ -> ([SDL.EventPayload] -> System w ()) -- ^ Event handler+ -> (SDL.Renderer -> FPS -> System w ()) -- ^ Draw function, receives the renderer and current FPS+ -> IO ()+run w r window step eventHandler draw = do+ SDL.showWindow window+ let loop prevTicks prevPerf tickAcc fpsAcc = do+ ticks <- SDL.ticks+ perf <- SDL.Raw.getPerformanceCounter+ freq <- SDL.Raw.getPerformanceFrequency+ payload <- map SDL.eventPayload <$> SDL.pollEvents+ let quit = SDL.QuitEvent `elem` payload+ dt = ticks - prevTicks+ tickAcc' = tickAcc + dt+ avgFps = 1000.0 / (fromIntegral tickAcc' / fromIntegral fpsAcc)+ elapsed = fromIntegral (perf - prevPerf) / fromIntegral freq * 1000+ runSystem (eventHandler payload) w+ runSystem (do+ let dt' = fromIntegral dt / 1000+ modify global $ \(Time t) -> Time (t + dt')+ stepAnimations dt'+ step dt') w+ runSystem (do+ c <- get global+ liftIO $ SDL.rendererDrawColor r SDL.$= backgroundColor c) w+ SDL.clear r+ runSystem (draw r (round avgFps)) w+ SDL.present r+ runSystem (do+ c <- get global+ case targetFPS c of+ Limited fps -> let+ frameTime = 1000 / fromIntegral fps+ delayTime = max 0 (frameTime - elapsed)+ in SDL.delay $ floor delayTime+ _ -> return ()) w+ unless quit $ loop ticks perf tickAcc' (fpsAcc + 1)+ loop 0 0 0 0+ SDL.destroyRenderer r+ SDL.destroyWindow window+ TTF.quit+ IMG.quit+ SDL.quit+ exitSuccess++-- | Template Haskell function to generate the world type and instances for the given component types. See the [Apecs documentation](https://hackage.haskell.org/package/apecs-0.9.6/docs/Apecs.html#v:makeWorld) for more details.+makeWorld' :: [Name] -> Q [Dec]+makeWorld' cTypes = makeWorld "World" (cTypes ++ [''TextureMap+ , ''FontMap+ , ''Position+ , ''Time+ , ''Renderable+ , ''Renderer+ , ''Window+ , ''Camera+ , ''Config+ , ''Layer+ , ''IsVisible+ , ''Colour])++stepAnimations :: forall w.+ (Has w IO Time+ , Has w IO TextureMap+ , Get w IO Renderable+ , Set w IO Renderable+ , Has w IO IsVisible+ , Members w IO Renderable)+ => Float+ -> System w ()+stepAnimations dt = cmapM $ \(r, e) -> do+ case r of+ Texture t -> getMaybe e (Proxy @IsVisible) >>= \res -> if isNothing res || (let IsVisible visible = fromJust res in visible) then do+ Time t' <- get global+ TextureMap m <- get global+ let tex = textureRef t `Map.lookup` m+ case tex of+ Nothing -> return r+ Just tex' -> case animation tex' of+ Just a -> do+ let trigger = floor (t' / frameSpeed a) /= floor ((t' + dt) / frameSpeed a)+ nextTex = next a `Map.lookup` m+ if trigger then do+ let frame = fromMaybe 0 (animationFrame t)+ newFrame = (frame + 1) `mod` frameCount a+ if newFrame == 0 then+ case nextTex of+ Just nextTex' -> case animation nextTex' of+ Just _ -> return $ Texture t { textureRef = next a, animationFrame = Just 0 }+ Nothing -> return $ Texture t { textureRef = next a, animationFrame = Nothing }+ Nothing -> return $ Texture t { animationFrame = Just frame }+ else+ return $ Texture t { animationFrame = Just newFrame }+ else return r+ Nothing -> return r+ else return r+ _ -> return r++-- | Checks if an entity hsa a component. If so, it returns that component in a Just. Otherwise, it returns Nothing+getMaybe :: forall w m c. Get w m c => Entity -> Proxy c -> SystemT w m (Maybe c)+getMaybe e p = exists e p >>= \y -> if y then Just <$> get e else return Nothing
+ src/Cadence/Texture.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}++module Cadence.Texture (TextureData(..), Animation(..), TextureMap(..), RenTexture(..), loadTexture) where++import qualified SDL.Image as IMG+import qualified SDL+import Apecs+import qualified Data.Map as Map+import Control.Monad.IO.Class (MonadIO)++{-|+Represents a texture in the game, which may be static or animated.+Note that animations must be stored as a horizontal [sprite sheet](https://www.aseprite.org/docs/sprite-sheet/).+-}+data TextureData = TextureData+ { texture :: SDL.Texture+ , animation :: Maybe Animation+ } deriving (Eq)++-- | Animation data for animated textures+data Animation = Animation+ { frameCount :: Int+ -- ^ Total number of frames in the animation+ , frameSpeed :: Float+ -- ^ Duration of each frame in seconds+ , next :: String+ -- ^ Identifier of the next texture to transition to after this one finishes. If this is the empty ("") string, the final frame will be held instead of looping or transitioning+ } deriving (Show, Eq)++-- | Represents a Texture for rendering+data RenTexture = RenTexture+ { textureRef :: String+ -- ^ Identifier for the texture to render+ , animationFrame :: Maybe Int+ -- ^ Frame index for animations, if applicable+ } deriving (Eq, Show)++-- | Stores the SDL textures loaded in the game, mapped by their identifiers+newtype TextureMap = TextureMap (Map.Map String TextureData)+instance Semigroup TextureMap where+ (TextureMap m1) <> (TextureMap m2) = TextureMap (Map.union m1 m2)+instance Monoid TextureMap where+ mempty = TextureMap Map.empty+instance Component TextureMap where type Storage TextureMap = Global TextureMap++-- | Loads a texture into the 'TextureMap' with an associated identifier and optional animation data+loadTexture :: forall w m. (Has w m TextureMap, MonadIO m) + => SDL.Renderer -- ^ SDL renderer context + -> FilePath+ -> String -- ^ Texture identifier+ -> Maybe Animation+ -> SystemT w m ()+loadTexture r path ident anim = do+ tex <- liftIO $ IMG.loadTexture r path+ modify global $ \(TextureMap m) -> TextureMap (Map.insert ident (TextureData tex anim) m)
+ src/Cadence/Types.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# LANGUAGE InstanceSigs #-}++module Cadence.Types (Config(..)+ , Renderable(..)+ , FPS+ , Position(..)+ , Time(..)+ , Renderer(..)+ , Window(..)+ , TargetFPS(..)+ , RenPoint(..)+ , RenRectangle(..)+ , RenLine(..)+ , Camera(..)+ , Colour(..)+ , Layer(..)+ , IsVisible(..)+ , defaultConfig) where++import qualified SDL+import Apecs+import Data.Word (Word8)+import Cadence.Texture (RenTexture)+import Cadence.Font (RenText)+import GHC.TypeLits (Nat)+import Linear+import qualified Data.Vector.Mutable as MV++type FPS = Int++data TargetFPS = VSync+ | Unlimited+ | Limited Nat++-- | Configuration settings for the game upon initialisation+data Config = Config+ {+ windowTitle :: String, -- ^ Title of the game window+ windowDimensions :: (Int, Int), -- ^ Width and height of the game window in pixels+ backgroundColor :: V4 Word8, -- ^ Background color of the game window as an RGBA value+ targetFPS :: TargetFPS, -- ^ Desired FPS for the game loop+ showFPS :: Maybe String -- ^ Whether to display the current FPS on the screen, and if so, the font to use+ }+instance Semigroup Config where+ _ <> c2 = c2+instance Monoid Config where+ mempty = defaultConfig+instance Component Config where type Storage Config = Global Config ++defaultConfig :: Config+defaultConfig = Config+ { windowTitle = "Cadence Game"+ , windowDimensions = (800, 600)+ , backgroundColor = V4 255 255 255 255+ , targetFPS = VSync+ , showFPS = Just "Roboto-Regular"+ }++-- | Represents a point to be rendered+data RenPoint = RenPoint deriving (Show, Eq)++-- | Represents a line to be rendered+data RenLine = RenLine+ { lineX :: Float -- ^ X coordinate of the line's ending point+ , lineY :: Float -- ^ Y coordinate of the line's ending point+ } deriving (Show, Eq)++-- | Represents a rectangle to be rendered+newtype RenRectangle = RenRectangle+ { rectSize :: V2 Float -- ^ Width and height of the rectangle+ } deriving (Show, Eq)++-- | Component used to tag a single Entity with data for it to be rendered+data Renderable = Texture RenTexture+ | Text RenText+ | Point RenPoint+ | Line RenLine+ | Rectangle RenRectangle+ | FilledRectangle RenRectangle+ deriving (Eq, Show)+instance Component Renderable where type Storage Renderable = Map Renderable++-- | Associate a colour with an entity for rendering. If no colour is supplied, it will default to black+newtype Colour = Colour (V4 Word8) deriving (Show, Eq)+instance Component Colour where type Storage Colour = Map Colour++-- | Layer Component for draw ordering, higher layers are drawn on top of lower layers. Indexing starts at 0+newtype Layer = Layer Int deriving (Show, Eq, Ord)+instance Component Layer where type Storage Layer = Map Layer++-- | Component to track whether an entity should be rendered or not, used for culling and animation stepping. If an entity is not supplied this, it will default to True (visible)+newtype IsVisible = IsVisible Bool deriving (Show, Eq)+instance Component IsVisible where type Storage IsVisible = Map IsVisible++-- | Position component of an entity within the game world. Required for rendering+newtype Position = Position (V2 Float) deriving (Show, Eq)+instance Component Position where type Storage Position = Map Position++-- | Global camera component. Stores a function which transforms a position in the game world to a position on the screen.+newtype Camera = Camera { camFunc :: V2 Float -> V2 Float }+instance Semigroup Camera where+ (Camera f1) <> (Camera f2) = Camera $ \pos -> f1 (f2 pos)+instance Monoid Camera where+ mempty = Camera id+instance Component Camera where type Storage Camera = Global Camera++-- | Total time elapsed since the start of the game+newtype Time = Time Float deriving (Show, Eq, Num)+instance Semigroup Time where+ (Time t1) <> (Time t2) = Time (t1 + t2)+instance Monoid Time where+ mempty = Time 0+instance Component Time where type Storage Time = Global Time++-- | Renderer context stored in a Component+newtype Renderer = Renderer (Maybe SDL.Renderer)+instance Semigroup Renderer where+ (Renderer r1) <> (Renderer _) = Renderer r1+instance Monoid Renderer where+ mempty = Renderer Nothing+instance Component Renderer where type Storage Renderer = Global Renderer++-- | Window context stored in a Component+newtype Window = Window (Maybe SDL.Window)+instance Semigroup Window where+ (<>) :: Window -> Window -> Window+ (Window w1) <> (Window _) = Window w1+instance Monoid Window where+ mempty = Window Nothing+instance Component Window where type Storage Window = Global Window
+ test/Spec.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++import Test.Hspec+import Test.QuickCheck+import Apecs+import qualified SDL+import qualified Data.Text as T+import qualified Data.Map as Map+import Control.Monad.Catch (try)+import Cadence++makeWorld' []++testConfig :: Config+testConfig = defaultConfig { windowTitle = "Test Window" }++main :: IO ()+main = hspec $ do+ describe "GDK.Systems.initialise" $ do+ it "Initialises SDL and creates a window and renderer" $ do+ w <- initWorld+ (window, renderer) <- initialise w testConfig+ size <- SDL.get (SDL.windowSize window)+ size `shouldBe` SDL.V2 800 600+ title <- SDL.get (SDL.windowTitle window)+ title `shouldBe` T.pack "Test Window"+ SDL.destroyRenderer renderer+ SDL.destroyWindow window+ it "Programmer can adjust window size and renderer after initialisation" $ do+ w <- initWorld+ (window, renderer) <- initialise w testConfig+ size <- SDL.get (SDL.windowSize window)+ size `shouldBe` SDL.V2 800 600+ title <- SDL.get (SDL.windowTitle window)+ title `shouldBe` T.pack "Test Window"+ SDL.windowSize window SDL.$= SDL.V2 1000 1000+ size' <- SDL.get (SDL.windowSize window)+ size' `shouldBe` SDL.V2 1000 1000+ SDL.destroyRenderer renderer+ SDL.destroyWindow window+ describe "GDK.Systems.stepAnimations" $ do+ it "Correctly steps a single animation frame" $ do+ w <- initWorld+ (_, renderer) <- initialise w testConfig+ tex <- SDL.createTexture renderer SDL.RGBA8888 SDL.TextureAccessStatic (SDL.V2 1 1)+ let test1 = TextureData { texture = tex, animation = Just Animation { frameCount = 2, frameSpeed = 0.1, next = "test2" }}+ test2 = TextureData { texture = tex, animation = Just Animation { frameCount = 2, frameSpeed = 0.1, next = "test1" }}+ runSystem (do+ modify global $ \(TextureMap ts) -> TextureMap (Map.insert "test2" test2 (Map.insert "test1" test1 ts))+ _ <- newEntity (Texture (RenTexture { textureRef = "test1", animationFrame = Just 0 }), IsVisible True)+ stepAnimations 0.1+ en <- cfold (\acc r -> case r of+ Texture t -> Just t+ _ -> acc) Nothing+ liftIO $ en `shouldBe` (Just $ RenTexture { textureRef = "test1", animationFrame = Just 1 })) w+ it "Correctly loops to the next animation" $ do+ w <- initWorld+ (_, renderer) <- initialise w testConfig+ tex <- SDL.createTexture renderer SDL.RGBA8888 SDL.TextureAccessStatic (SDL.V2 1 1)+ let test1 = TextureData { texture = tex, animation = Just Animation { frameCount = 2, frameSpeed = 0.1, next = "test2" }}+ test2 = TextureData { texture = tex, animation = Just Animation { frameCount = 2, frameSpeed = 0.1, next = "test1" }}+ runSystem (do+ modify global $ \(TextureMap ts) -> TextureMap (Map.insert "test2" test2 (Map.insert "test1" test1 ts))+ _ <- newEntity (Texture (RenTexture { textureRef = "test1", animationFrame = Just 0 }), IsVisible True)+ stepAnimations 0.1+ stepAnimations 0.1+ en <- cfold (\acc r -> case r of+ Texture t -> Just t+ _ -> acc) Nothing+ liftIO $ en `shouldBe` (Just $ RenTexture { textureRef = "test2", animationFrame = Just 0 })) w+ it "Holds the last frame when next = \"\"" $ do+ w <- initWorld+ (_, renderer) <- initialise w testConfig+ tex <- SDL.createTexture renderer SDL.RGBA8888 SDL.TextureAccessStatic (SDL.V2 1 1)+ let test = TextureData { texture = tex, animation = Just Animation { frameCount = 2, frameSpeed = 0.1, next = "test2" }}+ runSystem (do+ modify global $ \(TextureMap ts) -> TextureMap (Map.insert "test" test ts)+ _ <- newEntity (Texture (RenTexture { textureRef = "test", animationFrame = Just 0 }), IsVisible True)+ stepAnimations 0.1+ stepAnimations 0.1+ en <- cfold (\acc r -> case r of+ Texture t -> Just t+ _ -> acc) Nothing+ liftIO $ en `shouldBe` (Just $ RenTexture { textureRef = "test", animationFrame = Just 1 })) w+ describe "GDK.Texture.loadTexture" $ do+ it "Loads a valid texture into the TextureMap" $ do+ w <- initWorld+ (_, renderer) <- initialise w testConfig+ runSystem (do+ loadTexture renderer "test/resources/test.png" "testTex" Nothing+ TextureMap tm <- get global+ liftIO $ Map.member "testTex" tm `shouldBe` True) w+ it "Associates animation data with the loaded texture" $ do+ w <- initWorld+ (_, renderer) <- initialise w testConfig+ let anim = Animation { frameCount = 4, frameSpeed = 0.2, next = "nextTex" }+ runSystem (do+ loadTexture renderer "test/resources/test.png" "testTex" (Just anim)+ TextureMap tm <- get global+ case Map.lookup "testTex" tm of+ Just td -> liftIO $ animation td `shouldBe` Just anim+ Nothing -> liftIO $ expectationFailure "Texture not found in TextureMap") w+ it "Throws SDLException when loading a non-existent texture" $ do+ w <- initWorld+ (_, renderer) <- initialise w testConfig+ runSystem (do+ result <- try (loadTexture renderer "test/resources/nonexistent.png" "badTex" Nothing)+ case result of+ Left (e :: SDL.SDLException) -> liftIO $ return () -- Expected exception, test passes+ Right _ -> liftIO $ expectationFailure "Expected SDLException was not thrown") w+ describe "GDK.Font.loadFont" $ do+ it "Loads a valid font into the FontMap" $ do+ w <- initWorld+ _ <- initialise w testConfig+ runSystem (do+ loadFont "test/resources/Roboto-Black.ttf" "testFont" 24+ FontMap fm <- get global+ liftIO $ Map.member "testFont" fm `shouldBe` True) w+ it "Throws SDLException when loading a non-existent font" $ do+ w <- initWorld+ _ <- initialise w testConfig+ runSystem (do+ result <- try (loadFont "test/resources/nonexistent.ttf" "badFont" 24)+ case result of+ Left (e :: SDL.SDLException) -> liftIO $ return () -- Expected exception, test passes+ Right _ -> liftIO $ expectationFailure "Expected SDLException was not thrown") w