path: root/src/Game/Entities.hs

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]
  }

-- | Returns the number of frames available on the entity's sprite for current direction.
frameLimit :: Entity -> Int
frameLimit e = S.frameCount e.sprite (toSpriteSet e.dir)

type Collision = Entity -> IO Bool

-- | Collision detection of player vs entity.
--
-- The player's head won't register, this is necessary to avoid hitting things on a platform above when jumping.
collision :: IORef Entity -> Collision
collision playerRef other = do
  player <- readIORef playerRef
  pure $
    player.x + 4 < other.x + 12
      && other.x + 4 < player.x + 12
      && player.y + 12 < other.y + 16
      && other.y + 4 < player.y + 24

mkEntities :: S.SpriteSheet -> M.Map -> IORef C.Controls -> IO Entities
mkEntities sprites m controls = do
  player <- case find isPlayer (M.objects m) of
    Just (M.PlayerEntity x y) -> mkPlayer sprites x y controls (M.isBlocked m)
    _ -> error "No player entity in map"
  playerRef <- newIORef player
  entities <- traverse (toEntity playerRef) $ filter (not . isPlayer) (M.objects m)
  -- the entities list has always player first
  pure $ Entities sprites playerRef (player : entities)
  where
    toEntity :: IORef Entity -> M.Object -> IO Entity
    toEntity playerRef (M.BatteryEntity x y) = mkBattery sprites x y playerRef
    toEntity _ (M.PlayerEntity _ _) = error "Player already processed"

    isPlayer :: M.Object -> Bool
    isPlayer (M.PlayerEntity _ _) = True
    isPlayer _ = False

processSpawn :: S.SpriteSheet -> Spawn -> IO Entity
processSpawn sprites (DustEffectSpawn x y) = mkEffect sprites x y "dust"

updateAll :: Entities -> IO Entities
updateAll es = do
  -- update the player first (including the reference)
  updatedPlayer <- player.update player
  _ <- writeIORef es.player updatedPlayer
  -- then the other entities
  updated <- (updatedPlayer :) <$> traverse (\e -> e.update e) others
  -- collect new entities
  new <- traverse (processSpawn es.sprites) (concatMap (\e -> e.spawns) updated)
  -- clear spawns (new entities), filter out destroyed entities, and add the new ones
  pure es {entities = map (\e -> e {spawns = []}) (filter (\e -> not e.destroy) updated) ++ new}
  where
    player = head es.entities
    others = tail es.entities

render :: SDL.Renderer -> Entities -> IO ()
render renderer es = do
  -- always render player last
  traverse_ renderOne others
  renderOne player
  where
    player = head es.entities
    others = tail es.entities

    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 -> IORef Entity -> IO Entity
mkBattery sprites x y playerRef = 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 = updateBattery (collision playerRef),
        destroy = False,
        spawns = []
      }

updateBattery :: Collision -> Entity -> IO Entity
updateBattery touchedPlayer e = do
  -- XXX: how do we update game state? :thinkingface:
  (\t -> if t then e {destroy = True} else updateBatteryFrame) <$> touchedPlayer e
  where
    updateBatteryFrame :: Entity
    updateBatteryFrame
      | 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 (keyboard)
  | 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