From 9534c490c5c318e6c29ebf881ac5350545f479e5 Mon Sep 17 00:00:00 2001 From: "Juan J. Martinez" Date: Tue, 7 Feb 2023 16:08:13 +0000 Subject: Using OverloadedRecordDot --- game.cabal | 2 + src/Game.hs | 22 +++--- src/Game/Controller.hs | 46 +++++------ src/Game/Entities.hs | 203 +++++++++++++++++++++---------------------------- src/Game/Map.hs | 50 ++++++------ 5 files changed, 145 insertions(+), 178 deletions(-) diff --git a/game.cabal b/game.cabal index 70155bb..7263429 100644 --- a/game.cabal +++ b/game.cabal @@ -33,6 +33,8 @@ library ghc-options: -Wall -Werror -O2 -j default-extensions: OverloadedStrings + OverloadedRecordDot + DuplicateRecordFields hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Game.hs b/src/Game.hs index 667053d..5a974c6 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -79,10 +79,10 @@ main = do toggleFullscreen :: ReaderT Env IO () toggleFullscreen = do env <- ask - let fullscreen = _fullscreen env - renderRect = _renderRect env - renderer = _renderer env - window = _window env + let fullscreen = env._fullscreen + renderRect = env._renderRect + renderer = env._renderer + window = env._window fullscreen $~ not fs <- SDL.get fullscreen let mode = if fs then SDL.FullscreenDesktop else SDL.Windowed @@ -104,12 +104,12 @@ toggleFullscreen = do gameLoop :: ReaderT Env IO () gameLoop = do env <- ask - let renderer = _renderer env - canvas = _canvas env - renderRect = _renderRect env - controls = _controls env - map' = _map env - entities = _entities env + let renderer = env._renderer + canvas = env._canvas + renderRect = env._renderRect + controls = env._controls + map' = env._map + entities = env._entities events <- map SDL.eventPayload <$> SDL.pollEvents @@ -125,7 +125,7 @@ gameLoop = do SDL.rendererRenderTarget renderer $= Just canvas SDL.clear renderer - updated <- liftIO $ E.update =<< readIORef entities + updated <- liftIO $ E.updateAll =<< readIORef entities entities $= updated -- render map and entities diff --git a/src/Game/Controller.hs b/src/Game/Controller.hs index ec1cdf3..b5cd685 100644 --- a/src/Game/Controller.hs +++ b/src/Game/Controller.hs @@ -9,14 +9,14 @@ import qualified SDL.Raw import Prelude hiding (init) data Controls = Controls - { cUp :: Bool, - cDown :: Bool, - cLeft :: Bool, - cRight :: Bool, - cA :: Bool, - cB :: Bool, - cMenu :: Bool, - cJoy :: Maybe SDL.Raw.Joystick + { up :: Bool, + down :: Bool, + left :: Bool, + right :: Bool, + a :: Bool, + b :: Bool, + menu :: Bool, + joy :: Maybe SDL.Raw.Joystick } deriving (Show) @@ -39,29 +39,29 @@ init = do updateGamepad :: [SDL.EventPayload] -> Controls -> Controls updateGamepad events controls - | isNothing $ cJoy controls = controls + | isNothing $ controls.joy = controls -- XXX: deal with disconnection/reconnection | otherwise = controls - { cUp = fromMaybe (cUp controls) $ isPressedGamepad SDL.ControllerButtonDpadUp events, - cDown = fromMaybe (cDown controls) $ isPressedGamepad SDL.ControllerButtonDpadDown events, - cLeft = fromMaybe (cLeft controls) $ isPressedGamepad SDL.ControllerButtonDpadLeft events, - cRight = fromMaybe (cRight controls) $ isPressedGamepad SDL.ControllerButtonDpadRight events, - cA = fromMaybe (cA controls) $ isPressedGamepad SDL.ControllerButtonA events, - cB = fromMaybe (cB controls) $ isPressedGamepad SDL.ControllerButtonB events, - cMenu = fromMaybe (cMenu controls) $ isPressedGamepad SDL.ControllerButtonStart events + { up = fromMaybe controls.up $ isPressedGamepad SDL.ControllerButtonDpadUp events, + down = fromMaybe controls.down $ isPressedGamepad SDL.ControllerButtonDpadDown events, + left = fromMaybe controls.left $ isPressedGamepad SDL.ControllerButtonDpadLeft events, + right = fromMaybe controls.right $ isPressedGamepad SDL.ControllerButtonDpadRight events, + a = fromMaybe controls.a $ isPressedGamepad SDL.ControllerButtonA events, + b = fromMaybe controls.b $ isPressedGamepad SDL.ControllerButtonB events, + menu = fromMaybe controls.menu $ isPressedGamepad SDL.ControllerButtonStart events } updateKeyboard :: [SDL.EventPayload] -> Controls -> Controls updateKeyboard events controls = controls - { cUp = fromMaybe (cUp controls) $ isPressed SDL.KeycodeUp events, - cDown = fromMaybe (cDown controls) $ isPressed SDL.KeycodeDown events, - cLeft = fromMaybe (cLeft controls) $ isPressed SDL.KeycodeLeft events, - cRight = fromMaybe (cRight controls) $ isPressed SDL.KeycodeRight events, - cA = fromMaybe (cA controls) $ isPressed SDL.KeycodeZ events, - cB = fromMaybe (cB controls) $ isPressed SDL.KeycodeX events, - cMenu = fromMaybe (cMenu controls) $ isPressed SDL.KeycodeReturn events + { up = fromMaybe controls.up $ isPressed SDL.KeycodeUp events, + down = fromMaybe controls.down $ isPressed SDL.KeycodeDown events, + left = fromMaybe controls.left $ isPressed SDL.KeycodeLeft events, + right = fromMaybe controls.right $ isPressed SDL.KeycodeRight events, + a = fromMaybe controls.a $ isPressed SDL.KeycodeZ events, + b = fromMaybe controls.b $ isPressed SDL.KeycodeX events, + menu = fromMaybe controls.menu $ isPressed SDL.KeycodeReturn events } update :: [SDL.EventPayload] -> Controls -> Controls diff --git a/src/Game/Entities.hs b/src/Game/Entities.hs index b42f232..05149d0 100644 --- a/src/Game/Entities.hs +++ b/src/Game/Entities.hs @@ -1,4 +1,4 @@ -module Game.Entities (Entities, mkEntities, mkPlayer, mkEffect, append, update, render) where +module Game.Entities (Entities, mkEntities, mkPlayer, mkEffect, append, updateAll, render) where import Data.Foldable (traverse_) import Data.IORef @@ -40,20 +40,20 @@ data Entities = Entities S.SpriteSheet [Entity] data Spawn = DustEffectSpawn Int Int data Entity = Entity - { eType :: Type, - eX :: Int, - eY :: Int, - eDelay :: Int, - eFrame :: Int, - eFrameLimit :: Int, - eJumping :: Bool, - eGravity :: Int, - eDir :: Dir, - eSprite :: S.Sprite, - eUpdate :: Entity -> IO Entity, - eBlocked :: Int -> Int -> Bool, - eDestroy :: Bool, - eSpawns :: [Spawn] + { typ :: Type, + x :: Int, + y :: Int, + delay :: Int, + frame :: Int, + frameLimit :: Int, + jumping :: Bool, + gravity :: Int, + dir :: Dir, + sprite :: S.Sprite, + update :: Entity -> IO Entity, + isBlocked :: Int -> Int -> Bool, + destroy :: Bool, + spawns :: [Spawn] } mkEntities :: S.SpriteSheet -> Entities @@ -63,13 +63,13 @@ append :: Entity -> Entities -> Entities append e (Entities sprites entities) = Entities sprites (entities ++ [e]) processSpawn :: S.SpriteSheet -> Spawn -> IO Entity -processSpawn sprites (DustEffectSpawn x y) = mkEffect sprites x y "dust" +processSpawn sprites (DustEffectSpawn x' y') = mkEffect sprites x' y' "dust" -update :: Entities -> IO Entities -update (Entities sprites entities) = do - updated <- traverse (\e -> eUpdate e e) entities - new <- traverse (processSpawn sprites) (concatMap eSpawns updated) - pure $ Entities sprites $ map (\e -> e {eSpawns = []}) (filter (not . eDestroy) updated) ++ new +updateAll :: Entities -> IO Entities +updateAll (Entities sprites entities) = do + updated <- traverse (\e -> e.update e) entities + new <- traverse (processSpawn sprites) (concatMap (\e -> e.spawns) updated) + pure $ Entities sprites $ map (\e -> e {spawns = []}) (filter (not . destroy) updated) ++ new render :: SDL.Renderer -> Entities -> IO () render renderer (Entities _ entities) = do @@ -77,156 +77,127 @@ render renderer (Entities _ entities) = do where renderOne :: Entity -> IO () renderOne e = - S.render renderer sp x y set frame + S.render renderer e.sprite e.x e.y set e.frame where - sp = eSprite e - x = eX e - y = eY e - set = toSpriteSet $ eDir e - frame = eFrame e + set = toSpriteSet e.dir mkEffect :: S.SpriteSheet -> Int -> Int -> String -> IO Entity -mkEffect sprites x y name = do +mkEffect sprites x' y' name = do s <- S.get sprites name pure $ Entity - { eType = TypeEffect, - eX = x, - eY = y, - eDelay = frameDelay, - eFrame = 0, - eFrameLimit = 3, - eJumping = False, - eGravity = gravityOff, - eDir = DirRight, - eSprite = s, - eUpdate = pure . updateEffect, - eBlocked = \_ _ -> False, - eDestroy = False, - eSpawns = [] + { typ = TypeEffect, + x = x', + y = y', + delay = frameDelay, + frame = 0, + frameLimit = 3, + jumping = False, + gravity = gravityOff, + dir = DirRight, + sprite = s, + update = pure . updateEffect, + isBlocked = \_ _ -> False, + destroy = False, + spawns = [] } updateEffect :: Entity -> Entity updateEffect e - | delay > 0 = e {eDelay = delay - 1} - | frame + 1 < frameLimit = e {eDelay = frameDelay, eFrame = frame + 1} - | otherwise = e {eDestroy = True} - where - frame = eFrame e - frameLimit = eFrameLimit e - delay = eDelay e + | e.delay > 0 = e {delay = e.delay - 1} + | e.frame + 1 < e.frameLimit = e {delay = e.frameLimit, frame = e.frame + 1} + | otherwise = e {destroy = True} mkPlayer :: S.SpriteSheet -> Int -> Int -> IORef C.Controls -> (Int -> Int -> Bool) -> IO Entity -mkPlayer sprites x y controls isBlocked = do +mkPlayer sprites x' y' controls isBlocked' = do s <- S.get sprites "player" pure $ Entity - { eType = TypePlayer, - eX = x, - eY = y, - eDelay = 0, - eFrame = 0, - eFrameLimit = 3, - eJumping = False, - eGravity = gravityOff, - eDir = DirRight, - eSprite = s, - eUpdate = updatePlayer controls, - eBlocked = isBlocked, - eDestroy = False, - eSpawns = [] + { typ = TypePlayer, + x = x', + y = y', + delay = 0, + frame = 0, + frameLimit = 3, + jumping = False, + gravity = gravityOff, + dir = DirRight, + sprite = s, + update = updatePlayer controls, + isBlocked = isBlocked', + destroy = False, + spawns = [] } updateFrame :: Bool -> Entity -> Entity updateFrame updated e | isGravityOn = e - | delay > 0 = e {eDelay = delay - 1} - | frame < frameLimit = e {eDelay = frameDelay, eFrame = if updated then frame + 1 else 0} - | otherwise = e {eDelay = frameDelay, eFrame = 0} + | e.delay > 0 = e {delay = e.delay - 1} + | e.frame < e.frameLimit = e {delay = frameDelay, frame = if updated then e.frame + 1 else 0} + | otherwise = e {delay = frameDelay, frame = 0} where - isGravityOn = eGravity e > gravityOff - frame = eFrame e - frameLimit = eFrameLimit e - delay = eDelay e + isGravityOn = e.gravity > gravityOff updateHorizontal :: Bool -> Bool -> Entity -> Entity updateHorizontal left right e - -- prevent pressing both directions (keyboard) + -- prevent pressing both directions (ky'board) | left && right = e -- change direction first - | left && eDir e /= DirLeft = e {eDir = DirLeft, eDelay = 0} - | right && eDir e /= DirRight = e {eDir = DirRight, eDelay = 0} - | left && isGoingDown = if isBlocked (x - 1) (y + 23) then e else e {eX = x - 1} - | left && not isGoingDown = if isBlocked (x - 1) (y + 23) && isBlocked (x - 1) (y + 17) then e else e {eX = x - 1} - | right && isGoingDown = if isBlocked (x + 17) (y + 23) then e else e {eX = x + 1} - | right && not isGoingDown = if isBlocked (x + 17) (y + 23) && isBlocked (x + 17) (y + 17) then e else e {eX = x + 1} + | left && e.dir /= DirLeft = e {dir = DirLeft, delay = 0} + | right && e.dir /= DirRight = e {dir = DirRight, delay = 0} + | left && isGoingDown = if e.isBlocked (e.x - 1) (e.y + 23) then e else e {x = e.x - 1} + | left && not isGoingDown = if e.isBlocked (e.x - 1) (e.y + 23) && e.isBlocked (e.x - 1) (e.y + 17) then e else e {x = e.x - 1} + | right && isGoingDown = if e.isBlocked (e.x + 17) (e.y + 23) then e else e {x = e.x + 1} + | right && not isGoingDown = if e.isBlocked (e.x + 17) (e.y + 23) && e.isBlocked (e.x + 17) (e.y + 17) then e else e {x = e.x + 1} | otherwise = e where - x = eX e - y = eY e - isBlocked = eBlocked e - gravity = eGravity e - isGoingDown = gravity == gravityOff || gravity >= gravityDown + isGoingDown = e.gravity == gravityOff || e.gravity >= gravityDown updateVertical :: Bool -> Bool -> Entity -> Entity updateVertical jump down e | not jump - || jumping + || e.jumping -- make jumping easier with "Coyote time" - || (gravity /= gravityOff && (gravity < gravityDown || gravity > jumpLimit)) = + || (e.gravity /= gravityOff && (e.gravity < gravityDown || e.gravity > jumpLimit)) = e - | not down = e {eJumping = True, eGravity = gravityUp, eFrame = jumpFrame, eSpawns = events ++ [DustEffectSpawn x (y + 8)]} + | not down = e {jumping = True, gravity = gravityUp, frame = jumpFrame, spawns = e.spawns ++ [DustEffectSpawn e.x (e.y + 8)]} -- go down a 8 pixel tall platform; not ideal to have these values hardcoded here -- but to be fair, the player height/width is hardcoded as well | down - && not (isBlocked (x + 2) (y + 24 + 8)) - && not (isBlocked (x + 12) (y + 24 + 8)) = - applyGravity 8 e {eGravity = gravityDown, eFrame = jumpFrame, eY = eY e + 1} + && not (e.isBlocked (e.x + 2) (e.y + 24 + 8)) + && not (e.isBlocked (e.x + 12) (e.y + 24 + 8)) = + applyGravity 8 e {gravity = gravityDown, frame = jumpFrame, y = e.y + 1} | otherwise = e - where - x = eX e - y = eY e - jumping = eJumping e - gravity = eGravity e - isBlocked = eBlocked e - events = eSpawns e applyGravity :: Int -> Entity -> Entity applyGravity v e | v == 0 = e -- hit the floor | isGoingDown - && (isBlocked (x + 2) (y + 24) || isBlocked (x + 12) (y + 24)) - && not (isBlocked (x + 2) (y + 23)) - && not (isBlocked (x + 12) (y + 23)) = - e {eJumping = False, eGravity = gravityOff, eDelay = 0} - | otherwise = applyGravity (v - 1) e {eY = y + change} + && (e.isBlocked (e.x + 2) (e.y + 24) || e.isBlocked (e.x + 12) (e.y + 24)) + && not (e.isBlocked (e.x + 2) (e.y + 23)) + && not (e.isBlocked (e.x + 12) (e.y + 23)) = + e {jumping = False, gravity = gravityOff, delay = 0} + | otherwise = applyGravity (v - 1) e {y = e.y + change} where - gravity = eGravity e - isGoingDown = gravity >= gravityDown + isGoingDown = e.gravity >= gravityDown change = if isGoingDown then 1 else -1 - x = eX e - y = eY e - isBlocked = eBlocked e updateGravity :: Entity -> Entity updateGravity e - | current > gravityOff = applyGravity (gravityTable !! current) e {eGravity = new} - | not (isBlocked (x + 2) (y + 24) || isBlocked (x + 12) (y + 24)) = e {eGravity = gravityDown, eFrame = jumpFrame} + | current > gravityOff = applyGravity (gravityTable !! current) e {gravity = new} + | not (e.isBlocked (e.x + 2) (e.y + 24) || e.isBlocked (e.x + 12) (e.y + 24)) = e {gravity = gravityDown, frame = jumpFrame} | otherwise = e where - current = eGravity e + current = e.gravity new = if current > gravityOff && current < length gravityTable - 1 then current + 1 else current - x = eX e - y = eY e - isBlocked = eBlocked e updatePlayer :: IORef C.Controls -> Entity -> IO Entity updatePlayer controls e = do ctl <- readIORef controls pure $ updateGravity $ - updateVertical (C.cA ctl) (C.cDown ctl) $ - updateHorizontal (C.cLeft ctl) (C.cRight ctl) $ - -- left or right, but not both (keyboard) - updateFrame ((C.cLeft ctl || C.cRight ctl) && (C.cLeft ctl /= C.cRight ctl)) e + updateVertical ctl.a ctl.down $ + updateHorizontal ctl.left ctl.right $ + -- left or right, but not both (ky'board) + updateFrame ((ctl.left || ctl.right) && (ctl.left /= ctl.right)) e diff --git a/src/Game/Map.hs b/src/Game/Map.hs index 7866f97..94478bd 100644 --- a/src/Game/Map.hs +++ b/src/Game/Map.hs @@ -13,24 +13,24 @@ import Text.JSON import Text.JSON.Types data Tileset = Tileset - { tsCols :: Int, - tsWidth :: Int, - tsHeight :: Int, - tsFirstGid :: Int + { cols :: Int, + width :: Int, + height :: Int, + firstGid :: Int } deriving (Show) data TileLayer = TileLayer - { tlName :: String, - tlTiles :: [Int] + { name :: String, + tiles :: [Int] } deriving (Show) data MapData = MapData - { mWidth :: Int, - mHeight :: Int, - mTileset :: Tileset, - mLayers :: [TileLayer] + { width :: Int, + height :: Int, + tileset :: Tileset, + layers :: [TileLayer] } deriving (Show) @@ -78,13 +78,10 @@ load filename tex = do -- | Check for collision detection vs "Blocked" TileLayer that MUST be last layer. -- x and y in pixels. isBlocked :: Map -> Int -> Int -> Bool -isBlocked (Map (MapData width _ ts layers) _) x y = - tiles !! ((x `div` tw) + (y `div` th) * width) >= firstgid +isBlocked (Map (MapData mapWidth _ ts ls) _) x y = + blocked !! ((x `div` ts.width) + (y `div` ts.height) * mapWidth) >= ts.firstGid where - tiles = tlTiles (last layers) - tw = tsWidth ts - th = tsHeight ts - firstgid = tsFirstGid ts + blocked = (last ls).tiles -- | Renders a map. render :: SDL.Renderer -> Map -> IO () @@ -93,28 +90,25 @@ render renderer (Map mapData tex) = do ( \layer -> mapM_ ( \(x, y) -> - renderTile x y $ tlTiles layer !! (x + (y * mWidth mapData)) + renderTile x y $ layer.tiles !! (x + (y * mapData.width)) ) index ) - (init $ mLayers mapData) + (init $ mapData.layers) where - mw = mWidth mapData - mh = mHeight mapData - index = [(x, y) | x <- [0 .. mw - 1], y <- [0 .. mh - 1]] + index = [(x, y) | x <- [0 .. mapData.width - 1], y <- [0 .. mapData.height - 1]] - ts = mTileset mapData - firstgid = tsFirstGid ts - cols = tsCols ts - tileWidth = tsWidth ts - tileHeight = tsHeight ts + columns = mapData.tileset.cols + firstgid = mapData.tileset.firstGid + tileWidth = mapData.tileset.width + tileHeight = mapData.tileset.height renderTile :: Int -> Int -> Int -> IO () renderTile x y tile | tile < firstgid = pure () | otherwise = do - let tx = (tile - firstgid) `rem` cols - ty = (tile - firstgid) `div` cols + let tx = (tile - firstgid) `rem` columns + ty = (tile - firstgid) `div` columns src = U.rect (tx * tileWidth) (ty * tileHeight) tileWidth tileHeight dst = U.rect (x * tileWidth) (y * tileHeight) tileWidth tileHeight SDL.copy renderer tex (Just src) (Just dst) -- cgit v1.2.3