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

module Game.Entities (Entities, mkEntities, mkPlayer, mkEffect, append, update, render) where

import Data.Foldable (traverse_)
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 | 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 = 16

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]

data Spawn = DustEffectSpawn Int Int

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,
    eSpawns :: [Spawn]
  }

mkEntities :: S.SpriteSheet -> Entities
mkEntities sprites = Entities sprites []

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"

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

render :: SDL.Renderer -> Entities -> IO ()
render renderer (Entities _ entities) = do
  traverse_ renderOne entities
  where
    renderOne :: Entity -> IO ()
    renderOne e =
      S.render renderer sp x y set frame
      where
        sp = eSprite e
        x = eX e
        y = eY e
        set = toSpriteSet $ eDir e
        frame = eFrame e

mkEffect :: S.SpriteSheet -> Int -> Int -> String -> IO Entity
mkEffect sprites x y name = do
  s <- S.get sprites name
  pure $ Entity TypeEffect x y frameDelay 0 3 gravityOff DirRight s (pure . updateEffect) (\_ _ -> False) False []

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

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 < frameLimit = 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
    frameLimit = eFrameLimit 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 -> Bool -> Entity -> Entity
updateVertical jump down e
  | not jump || gravity /= gravityOff = e
  | not down = e {eGravity = gravityUp, eFrame = jumpFrame, eSpawns = events ++ [DustEffectSpawn x (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}
  | otherwise = e
  where
    x = eX e
    y = eY 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 {eGravity = gravityOff, eDelay = 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) (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