path: root/src/Game/Entities.hs

{-# OPTIONS_GHC -Wno-unused-top-binds #-}

module Game.Entities (Entities, Entity, mkEntities, updateAll, render) where

import Data.Foldable (find, traverse_)
import Data.IORef
import qualified Game.Controller as C
import qualified Game.Map as M
import qualified Game.Sprites as S
import qualified SDL

data Dir = DirRight | DirLeft deriving (Eq)

data Type = TypePlayer | TypePickup | TypeEffect

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 = 14

jumpLimit :: Int
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]

type IsBlocked = Int -> Int -> Bool

data Entities = Entities
  { sprites :: S.SpriteSheet,
    player :: IORef Entity,
    entities :: [Entity]
  }

data Spawn = DustEffectSpawn Int Int

data Entity = Entity
  { typ :: Type,
    x :: Int,
    y :: Int,
    delay :: Int,
    frame :: Int,
    jumping :: Bool,
    gravity :: Int,
    dir :: Dir,
    sprite :: S.Sprite,
    update :: Entity -> 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
  player <- case find isPlayer entities of
    Just player -> newIORef player
    Nothing -> error "No player entity in map"
  pure $ Entities sprites player entities
  where
    toEntity :: M.Object -> IO Entity
    toEntity (M.PlayerEntity x y) = mkPlayer sprites x y controls (M.isBlocked m)
    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 es = do
  updated <- traverse (\e -> e.update e) 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 es = do
  traverse_ renderOne es.entities
  where
    renderOne :: Entity -> IO ()
    renderOne e =
      S.render renderer e.sprite e.x e.y set e.frame
      where
        set = toSpriteSet e.dir

mkEffect :: S.SpriteSheet -> Int -> Int -> String -> IO Entity
mkEffect sprites x y name = do
  s <- S.get sprites name
  pure $
    Entity
      { typ = TypeEffect,
        x = x,
        y = y,
        delay = frameDelay,
        frame = 0,
        jumping = False,
        gravity = gravityOff,
        dir = DirRight,
        sprite = s,
        update = pure . updateEffect,
        destroy = False,
        spawns = []
      }

updateEffect :: Entity -> Entity
updateEffect e
  | e.delay > 0 = e {delay = e.delay - 1}
  | e.frame + 1 < frameLimit e = e {delay = frameDelay, frame = e.frame + 1}
  | otherwise = e {destroy = True}

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 = pure . updateBattery,
        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 -> IsBlocked -> IO Entity
mkPlayer sprites x y controls isBlocked = do
  s <- S.get sprites "player"
  pure $
    Entity
      { typ = TypePlayer,
        x = x,
        y = y,
        delay = 0,
        frame = 0,
        jumping = False,
        gravity = gravityOff,
        dir = DirRight,
        sprite = s,
        update = updatePlayer controls isBlocked,
        destroy = False,
        spawns = []
      }

updateFrame :: Bool -> Entity -> Entity
updateFrame updated e
  | isGravityOn = e
  | e.delay > 0 = e {delay = e.delay - 1}
  | 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 :: IsBlocked -> 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 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 :: IsBlocked -> Bool -> Bool -> Entity -> Entity
updateVertical isBlocked jump down e
  | not jump
      || e.jumping
      -- make jumping easier with "Coyote time"
      || (e.gravity /= gravityOff && (e.gravity < gravityDown || e.gravity > jumpLimit)) =
      e
  | 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 (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 :: IsBlocked -> Int -> Entity -> Entity
applyGravity isBlocked v e
  | v == 0 = e
  -- hit the floor
  | isGoingDown
      && (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 isBlocked (v - 1) e {y = e.y + change}
  where
    isGoingDown = e.gravity >= gravityDown
    change = if isGoingDown then 1 else -1

updateGravity :: IsBlocked -> 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 -> IsBlocked -> Entity -> IO Entity
updatePlayer controls isBlocked e = do
  ctl <- readIORef controls
  pure $
    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