Initial import

1 files changed, 139 insertions, 0 deletions

diff --git a/src/Game/Entities.hs b/src/Game/Entities.hs
new file mode 100644
index 0000000..0d37632
--- /dev/null
+++ b/src/Game/Entities.hs
@@ -0,0 +1,139 @@
+module Game.Entities (Entity (..), toSpriteSet, mkPlayer, render) where
+
+import Data.IORef
+import qualified Game.Controller as C
+import qualified Game.Sprites as S
+import qualified SDL
+
+data Dir = DirRight | DirLeft deriving (Eq)
+
+data Type = TypePlayer -- \| TypeEnemy | TypeItem
+
+toSpriteSet :: Dir -> Int
+toSpriteSet DirRight = 0
+toSpriteSet DirLeft = 1
+
+frameDelay :: Int
+frameDelay = 6
+
+jumpFrame :: Int
+jumpFrame = 3
+
+gravityOff :: Int
+gravityOff = -1
+
+gravityUp :: Int
+gravityUp = 0
+
+gravityDown :: Int
+gravityDown = 16
+
+gravityTable :: [Int]
+gravityTable = [0, 6, 4, 4, 2, 2, 2, 2, 1, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 2, 3]
+
+data Entity = Entity
+  { eType :: Type,
+    eX :: Int,
+    eY :: Int,
+    eDelay :: Int,
+    eFrame :: Int,
+    eFrameLimit :: Int,
+    eGravity :: Int,
+    eDir :: Dir,
+    eSprite :: S.Sprite,
+    eUpdate :: Entity -> IO Entity,
+    eBlocked :: Int -> Int -> Bool,
+    eDestroy :: Bool
+  }
+
+mkPlayer :: S.SpriteSheet -> Int -> Int -> IORef C.Controls -> (Int -> Int -> Bool) -> IO Entity
+mkPlayer sprites x y controls isBlocked = do
+  s <- S.get sprites "player"
+  pure $ Entity TypePlayer x y 0 0 3 gravityOff DirRight s (updatePlayer controls) isBlocked False
+
+updateFrame :: Bool -> Entity -> Entity
+updateFrame updated e
+  | isGravityOn = e
+  | delay > 0 = e {eDelay = delay - 1}
+  | frame < eFrameLimit e = e {eDelay = frameDelay, eFrame = if updated then frame + 1 else 0}
+  | otherwise = e {eDelay = frameDelay, eFrame = 0}
+  where
+    isGravityOn = eGravity e > gravityOff
+    frame = eFrame e
+    delay = eDelay e
+
+updateHorizontal :: Bool -> Bool -> Entity -> Entity
+updateHorizontal left right e
+  -- prevent pressing both directions (keyboard)
+  | 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}
+  | otherwise = e
+  where
+    x = eX e
+    y = eY e
+    isBlocked = eBlocked e
+    gravity = eGravity e
+    isGoingDown = gravity == gravityOff || gravity >= gravityDown
+
+updateVertical :: Bool -> Entity -> Entity
+updateVertical jump e
+  | jump && gravity == gravityOff = e {eGravity = gravityUp, eFrame = jumpFrame}
+  | otherwise = e
+  where
+    gravity = eGravity 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 {eGravity = gravityOff, eDelay = 0, eFrame = 0}
+  | otherwise = applyGravity (v - 1) e {eY = y + change}
+  where
+    gravity = eGravity e
+    isGoingDown = 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}
+  | otherwise = e
+  where
+    current = eGravity e
+    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) $
+        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
+
+render :: SDL.Renderer -> Entity -> IO ()
+render renderer ent =
+  S.render renderer sp x y set frame
+  where
+    sp = eSprite ent
+    x = eX ent
+    y = eY ent
+    set = toSpriteSet $ eDir ent
+    frame = eFrame ent