aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJuan J. Martinez <jjm@usebox.net>2023-02-07 16:08:13 +0000
committerJuan J. Martinez <jjm@usebox.net>2023-02-07 16:08:13 +0000
commit9534c490c5c318e6c29ebf881ac5350545f479e5 (patch)
treea1d3e04db1fbeae883502668e1444763c2a28a69
parent54d3f5a32758eb92606338d28a13652bcf51375c (diff)
downloadspace-plat-hs-9534c490c5c318e6c29ebf881ac5350545f479e5.tar.gz
space-plat-hs-9534c490c5c318e6c29ebf881ac5350545f479e5.zip
Using OverloadedRecordDot
-rw-r--r--game.cabal2
-rw-r--r--src/Game.hs22
-rw-r--r--src/Game/Controller.hs46
-rw-r--r--src/Game/Entities.hs203
-rw-r--r--src/Game/Map.hs50
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)