Pickups WIP

TODO: collision

3 files changed, 98 insertions, 49 deletions

diff --git a/src/Game/Entities.hs b/src/Game/Entities.hs
index 36d25c1..ebb73d0 100644
--- a/src/Game/Entities.hs
+++ b/src/Game/Entities.hs
@@ -1,6 +1,8 @@
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
 module Game.Entities (Entities, Entity, mkEntities, updateAll, render) where
 
-import Data.Foldable (traverse_)
+import Data.Foldable (find, traverse_)
 import Data.IORef
 import qualified Game.Controller as C
 import qualified Game.Map as M
@@ -9,7 +11,7 @@ import qualified SDL
 
 data Dir = DirRight | DirLeft deriving (Eq)
 
-data Type = TypePlayer | TypeEffect
+data Type = TypePlayer | TypePickup | TypeEffect
 
 toSpriteSet :: Dir -> Int
 toSpriteSet DirRight = 0
@@ -36,7 +38,14 @@ jumpLimit = gravityDown + 7
 gravityTable :: [Int]
 gravityTable = [0, 6, 4, 4, 2, 2, 2, 2, 1, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 2, 2, 2, 2, 4]
 
-data Entities = Entities S.SpriteSheet [Entity]
+type MapCollision = Int -> Int -> Bool
+
+data Entities = Entities
+  { sprites :: S.SpriteSheet,
+    player :: IORef Entity,
+    entities :: [Entity],
+    mapCollision :: MapCollision
+  }
 
 data Spawn = DustEffectSpawn Int Int
 
@@ -46,37 +55,47 @@ data Entity = Entity
     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,
+    update :: Entity -> MapCollision -> IO Entity,
     destroy :: Bool,
     spawns :: [Spawn]
   }
 
+frameLimit :: Entity -> Int
+frameLimit e = S.frameCount e.sprite (toSpriteSet e.dir)
+
 mkEntities :: S.SpriteSheet -> M.Map -> IORef C.Controls -> IO Entities
 mkEntities sprites m controls = do
   entities <- traverse toEntity $ M.objects m
-  pure $ Entities sprites entities
+  player <- case find isPlayer entities of
+    Just player -> newIORef player
+    Nothing -> error "No player entity in map"
+  pure $ Entities sprites player entities (M.isBlocked m)
   where
     toEntity :: M.Object -> IO Entity
-    toEntity (M.PlayerEntity x y) = mkPlayer sprites x y controls (M.isBlocked m)
+    toEntity (M.PlayerEntity x y) = mkPlayer sprites x y controls
+    toEntity (M.BatteryEntity x y) = mkBattery sprites x y
+
+    isPlayer :: Entity -> Bool
+    isPlayer e = case e.typ of
+      TypePlayer -> True
+      _ -> False
 
 processSpawn :: S.SpriteSheet -> Spawn -> IO Entity
 processSpawn sprites (DustEffectSpawn x y) = mkEffect sprites x y "dust"
 
 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 (\e -> not e.destroy) updated) ++ new
+updateAll es = do
+  updated <- traverse (\e -> e.update e es.mapCollision) es.entities
+  new <- traverse (processSpawn es.sprites) (concatMap (\e -> e.spawns) updated)
+  pure es {entities = map (\e -> e {spawns = []}) (filter (\e -> not e.destroy) updated) ++ new}
 
 render :: SDL.Renderer -> Entities -> IO ()
-render renderer (Entities _ entities) = do
-  traverse_ renderOne entities
+render renderer es = do
+  traverse_ renderOne es.entities
   where
     renderOne :: Entity -> IO ()
     renderOne e =
@@ -94,13 +113,11 @@ mkEffect sprites x y name = do
         y = y,
         delay = frameDelay,
         frame = 0,
-        frameLimit = 3,
         jumping = False,
         gravity = gravityOff,
         dir = DirRight,
         sprite = s,
-        update = pure . updateEffect,
-        isBlocked = \_ _ -> False,
+        update = \e _ -> pure $ updateEffect e,
         destroy = False,
         spawns = []
       }
@@ -108,11 +125,36 @@ mkEffect sprites x y name = do
 updateEffect :: Entity -> Entity
 updateEffect e
   | e.delay > 0 = e {delay = e.delay - 1}
-  | e.frame + 1 < e.frameLimit = e {delay = e.frameLimit, frame = e.frame + 1}
+  | e.frame + 1 < frameLimit e = e {delay = frameDelay, 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
+mkBattery :: S.SpriteSheet -> Int -> Int -> IO Entity
+mkBattery sprites x y = do
+  s <- S.get sprites "battery"
+  pure $
+    Entity
+      { typ = TypePickup,
+        x = x,
+        y = y,
+        delay = frameDelay,
+        frame = 0,
+        jumping = False,
+        gravity = gravityOff,
+        dir = DirRight,
+        sprite = s,
+        update = \e _ -> pure $ updateBattery e,
+        destroy = False,
+        spawns = []
+      }
+
+updateBattery :: Entity -> Entity
+updateBattery e
+  | e.delay > 0 = e {delay = e.delay - 1}
+  | e.frame + 1 < frameLimit e = e {delay = frameDelay, frame = e.frame + 1}
+  | otherwise = e {delay = frameDelay, frame = 0}
+
+mkPlayer :: S.SpriteSheet -> Int -> Int -> IORef C.Controls -> IO Entity
+mkPlayer sprites x y controls = do
   s <- S.get sprites "player"
   pure $
     Entity
@@ -121,13 +163,11 @@ mkPlayer sprites x y controls isBlocked' = do
         y = y,
         delay = 0,
         frame = 0,
-        frameLimit = 3,
         jumping = False,
         gravity = gravityOff,
         dir = DirRight,
         sprite = s,
         update = updatePlayer controls,
-        isBlocked = isBlocked',
         destroy = False,
         spawns = []
       }
@@ -136,28 +176,28 @@ updateFrame :: Bool -> Entity -> Entity
 updateFrame updated e
   | isGravityOn = e
   | e.delay > 0 = e {delay = e.delay - 1}
-  | e.frame < e.frameLimit = e {delay = frameDelay, frame = if updated then e.frame + 1 else 0}
+  | e.frame + 1 < frameLimit e = e {delay = frameDelay, frame = if updated then e.frame + 1 else 0}
   | otherwise = e {delay = frameDelay, frame = 0}
   where
     isGravityOn = e.gravity > gravityOff
 
-updateHorizontal :: Bool -> Bool -> Entity -> Entity
-updateHorizontal left right e
+updateHorizontal :: MapCollision -> Bool -> Bool -> Entity -> Entity
+updateHorizontal isBlocked left right e
   -- prevent pressing both directions (kyboard)
   | left && right = e
   -- change direction first
   | 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}
+  | left && isGoingDown = if isBlocked (e.x - 1) (e.y + 23) then e else e {x = e.x - 1}
+  | left && not isGoingDown = if isBlocked (e.x - 1) (e.y + 23) && isBlocked (e.x - 1) (e.y + 17) then e else e {x = e.x - 1}
+  | right && isGoingDown = if isBlocked (e.x + 17) (e.y + 23) then e else e {x = e.x + 1}
+  | right && not isGoingDown = if isBlocked (e.x + 17) (e.y + 23) && isBlocked (e.x + 17) (e.y + 17) then e else e {x = e.x + 1}
   | otherwise = e
   where
     isGoingDown = e.gravity == gravityOff || e.gravity >= gravityDown
 
-updateVertical :: Bool -> Bool -> Entity -> Entity
-updateVertical jump down e
+updateVertical :: MapCollision -> Bool -> Bool -> Entity -> Entity
+updateVertical isBlocked jump down e
   | not jump
       || e.jumping
       -- make jumping easier with "Coyote time"
@@ -167,40 +207,40 @@ updateVertical jump down e
   -- 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 (e.isBlocked (e.x + 2) (e.y + 24 + 8))
-      && not (e.isBlocked (e.x + 12) (e.y + 24 + 8)) =
+      && not (isBlocked (e.x + 2) (e.y + 24 + 8))
+      && not (isBlocked (e.x + 12) (e.y + 24 + 8)) =
       e {gravity = gravityDown, frame = jumpFrame, y = e.y + 1}
   | otherwise = e
 
-applyGravity :: Int -> Entity -> Entity
-applyGravity v e
+applyGravity :: MapCollision -> Int -> Entity -> Entity
+applyGravity isBlocked v e
   | v == 0 = e
   -- hit the floor
   | isGoingDown
-      && (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)) =
+      && (isBlocked (e.x + 2) (e.y + 24) || isBlocked (e.x + 12) (e.y + 24))
+      && not (isBlocked (e.x + 2) (e.y + 23))
+      && not (isBlocked (e.x + 12) (e.y + 23)) =
       e {jumping = False, gravity = gravityOff, delay = 0}
-  | otherwise = applyGravity (v - 1) e {y = e.y + change}
+  | otherwise = applyGravity isBlocked (v - 1) e {y = e.y + change}
   where
     isGoingDown = e.gravity >= gravityDown
     change = if isGoingDown then 1 else -1
 
-updateGravity :: Entity -> Entity
-updateGravity e
-  | 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}
+updateGravity :: MapCollision -> Entity -> Entity
+updateGravity isBlocked e
+  | current > gravityOff = applyGravity isBlocked (gravityTable !! current) e {gravity = new}
+  | not (isBlocked (e.x + 2) (e.y + 24) || isBlocked (e.x + 12) (e.y + 24)) = e {gravity = gravityDown, frame = jumpFrame}
   | otherwise = e
   where
     current = e.gravity
     new = if current > gravityOff && current < length gravityTable - 1 then current + 1 else current
 
-updatePlayer :: IORef C.Controls -> Entity -> IO Entity
-updatePlayer controls e = do
+updatePlayer :: IORef C.Controls -> Entity -> MapCollision -> IO Entity
+updatePlayer controls e isBlocked = do
   ctl <- readIORef controls
   pure $
-    updateGravity $
-      updateVertical ctl.a ctl.down $
-        updateHorizontal ctl.left ctl.right $
+    updateGravity isBlocked $
+      updateVertical isBlocked ctl.a ctl.down $
+        updateHorizontal isBlocked ctl.left ctl.right $
           -- left or right, but not both (keyboard)
           updateFrame ((ctl.left || ctl.right) && (ctl.left /= ctl.right)) e
diff --git a/src/Game/Map.hs b/src/Game/Map.hs
index b79ba14..3855d16 100644
--- a/src/Game/Map.hs
+++ b/src/Game/Map.hs
@@ -31,7 +31,10 @@ data Layer
   deriving (Show)
 
 -- | The object types in the map.
-data Object = PlayerEntity Int Int deriving (Show)
+data Object
+  = PlayerEntity Int Int
+  | BatteryEntity Int Int
+  deriving (Show)
 
 data JsonMapData = JsonMapData
   { width :: Int,
@@ -68,6 +71,8 @@ instance JSON Object where
     case get_field obj "name" of
       Just "Player" ->
         PlayerEntity <$> valFromObj "x" obj <*> valFromObj "y" obj
+      Just "Battery" ->
+        BatteryEntity <$> valFromObj "x" obj <*> valFromObj "y" obj
       Just (JSString (JSONString s)) -> Error $ "unsupported entity " ++ show s
       e -> Error $ "unsupported entity in " ++ show e
   readJSON _ = mzero
diff --git a/src/Game/Sprites.hs b/src/Game/Sprites.hs
index de949b5..3e8c195 100644
--- a/src/Game/Sprites.hs
+++ b/src/Game/Sprites.hs
@@ -1,6 +1,7 @@
 module Game.Sprites
   ( SpriteSheet,
     Sprite,
+    frameCount,
     load,
     get,
     render,
@@ -26,6 +27,9 @@ data SpriteSheet = SpriteSheet Sprites SDL.Texture
 -- Can be rendered with `render`.
 data Sprite = Sprite [[SDL.Rectangle CInt]] SDL.Texture
 
+frameCount :: Sprite -> Int -> Int
+frameCount (Sprite frames _) set = length $ frames !! set
+
 newtype SpriteData = SpriteData [[SDL.Rectangle CInt]] deriving (Show)
 
 newtype Sprites = Sprites [(String, SpriteData)] deriving (Show)