path: root/src/Game.hs

module Game (main) where

import Control.Monad
import Data.IORef
import Data.Maybe (fromMaybe)
import Data.Text (pack)
import Foreign.C.Types (CInt)
import qualified Game.BitmapFont as BF
import qualified Game.Controller as C
import qualified Game.Entities as E
import qualified Game.Hud as H
import qualified Game.Map as M
import qualified Game.Sprites as S
import qualified Game.State as GS
import qualified Game.Toaster as T
import qualified Game.Utils as U
import SDL (($=))
import qualified SDL
import qualified SDL.Image
import SDL.Vect (V2 (..))

name :: String
name = "Haskell gamedev [Space Platformer]"

gameWidth, gameHeight :: CInt
(gameWidth, gameHeight) = (320, 192)

gameScale :: CInt
gameScale = 3

windowWidth, windowHeight :: CInt
(windowWidth, windowHeight) = (gameWidth * gameScale, gameHeight * gameScale)

version :: String
version = "0.1.0"

data Env = Env
  { window :: SDL.Window,
    renderer :: SDL.Renderer,
    canvas :: SDL.Texture,
    fullscreen :: Bool,
    renderRect :: SDL.Rectangle CInt,
    tsTexture :: SDL.Texture,
    mapList :: [String],
    map :: M.Map,
    sprites :: S.SpriteSheet,
    font :: BF.BitmapFont,
    entities :: E.Entities,
    hud :: H.Hud,
    toaster :: T.Toaster,
    state :: GS.State,
    controlsRef :: IORef C.Controls
  }

defaultRenderRect :: SDL.Rectangle CInt
defaultRenderRect = SDL.Rectangle (SDL.P $ V2 0 0) (V2 windowWidth windowHeight)

main :: IO ()
main = do
  SDL.initialize [SDL.InitVideo, SDL.InitGameController]
  window <-
    SDL.createWindow
      (pack $ name ++ " " ++ version)
      SDL.defaultWindow {SDL.windowInitialSize = SDL.V2 windowWidth windowHeight}
  renderer <-
    SDL.createRenderer
      window
      (-1)
      SDL.RendererConfig
        { SDL.rendererType = SDL.AcceleratedVSyncRenderer,
          SDL.rendererTargetTexture = True
        }
  SDL.HintRenderScaleQuality $= SDL.ScaleNearest
  canvas <- SDL.createTexture renderer SDL.RGBA8888 SDL.TextureAccessTarget (V2 gameWidth gameHeight)
  tsTexture <- SDL.Image.loadTexture renderer "data/tiles.png"
  ssTexture <- SDL.Image.loadTexture renderer "data/sprites.png"
  bfTexture <- SDL.Image.loadTexture renderer "data/font.png"
  mapList <- M.loadMapList "data/maps.json"
  map' <- M.load (head mapList) tsTexture
  sprites <- S.load "data/sprites.json" ssTexture
  font <- BF.load "data/font.json" bfTexture
  controlsRef <- newIORef C.init
  entities <- E.mkEntities sprites map' controlsRef
  hud <- H.mkHud sprites font
  toaster <- T.mkToaster font (fromIntegral gameHeight)
  gameLoop
    Env
      { window = window,
        renderer = renderer,
        canvas = canvas,
        fullscreen = False,
        renderRect = defaultRenderRect,
        tsTexture = tsTexture,
        mapList = mapList,
        map = map',
        sprites = sprites,
        font = font,
        entities = entities,
        hud = hud,
        toaster = toaster,
        state = GS.initialState map',
        controlsRef = controlsRef
      }
  SDL.destroyWindow window
  SDL.quit

toggleFullscreen :: Env -> IO Env
toggleFullscreen env =
  do
    let fullscreen = not env.fullscreen
        renderer = env.renderer
        window = env.window
    let mode = if fullscreen then SDL.FullscreenDesktop else SDL.Windowed
     in SDL.setWindowMode window mode

    vp <- if fullscreen then SDL.get $ SDL.rendererViewport renderer else pure Nothing
    let renderRect = case vp of
          Nothing -> defaultRenderRect
          Just (SDL.Rectangle _ (V2 w h)) -> SDL.Rectangle (SDL.P $ V2 rx ry) (V2 rw rh)
            where
              scale = min (w `div` gameWidth) (h `div` gameHeight)
              rx = (w - (gameWidth * scale)) `div` 2
              ry = (h - (gameHeight * scale)) `div` 2
              rw = gameWidth * scale
              rh = gameHeight * scale
    pure env {fullscreen = fullscreen, renderRect = renderRect}

gameLoop :: Env -> IO ()
gameLoop e = do
  events <- map SDL.eventPayload <$> SDL.pollEvents

  -- ALT + Enter for fullscreen / windowed
  env <-
    if fromMaybe False (C.isPressed SDL.KeycodeReturn events) && C.isModKey C.altMod events
      then toggleFullscreen e
      else pure e

  let renderer = env.renderer
      canvas = env.canvas
      renderRect = env.renderRect
      controlsRef = env.controlsRef
      state = env.state

  -- ESC or close the window to quit
  let quit = fromMaybe False (C.isPressed SDL.KeycodeEscape events) || SDL.QuitEvent `elem` events
  unless quit $ do
    -- update controls
    updatedToasterEnv <- do
      ctl <- readIORef controlsRef
      C.update ctl env.toaster events
        >>= ( \(ctl', toaster) -> do
                writeIORef controlsRef ctl'
                pure env {toaster = T.update toaster}
            )

    SDL.rendererRenderTarget renderer $= Just canvas

    updatedEnv <- case state.playState of
      GS.GameOver -> gameOverLoop updatedToasterEnv
      GS.ExitDone frames -> nextStageLoop updatedToasterEnv frames
      _ -> playLoop updatedToasterEnv
    T.render renderer updatedEnv.toaster

    SDL.rendererRenderTarget renderer $= Nothing
    SDL.clear renderer
    SDL.copy renderer canvas Nothing (Just renderRect)

    SDL.present renderer

    gameLoop updatedEnv

playLoop :: Env -> IO Env
playLoop e = do
  let renderer = e.renderer
      map' = M.update e.map
      entities = e.entities
      hud = e.hud

  (updated, state) <- E.updateAll entities e.state

  env <- updateState e {state = state, entities = updated, map = map'}

  -- to update the map viewport
  let (px, py) = E.playerPosition updated

  SDL.clear renderer

  -- set the SDL viewport
  viewport <- M.viewport renderer map' px py (fromIntegral gameWidth) (fromIntegral gameHeight - H.height) (Just (0, H.height))
  -- render map and entities
  M.render renderer map' viewport
  E.renderVisible renderer updated viewport state

  -- reset viewport to draw the HUD
  SDL.rendererViewport renderer $= Nothing
  H.render renderer hud state

  pure env
  where
    -- update state counters, etc
    updateState :: Env -> IO Env
    updateState env
      | state.gameOverDelay > 0 = do
          let delay = state.gameOverDelay - 1
          pure $
            if delay > 0
              then env {state = state {GS.gameOverDelay = delay}}
              else env {state = state {GS.playState = GS.GameOver}}
      | state.batteries == state.totalBatteries && not state.exit = do
          es <- E.addExit env.entities x (y - 8) -- adjusted to player's height
          pure env {entities = es, state = state {GS.exit = True}}
      | otherwise = pure env
      where
        state = env.state
        (x, y) = state.lastBattery

nextStageLoop :: Env -> Int -> IO Env
nextStageLoop e frames
  -- erase the screen
  | frames < fromIntegral gameWidth = do
      SDL.fillRect e.renderer $ Just (U.rect 0 H.height (frames + 8) (fromIntegral gameHeight - H.height))
      pure e {state = e.state {GS.playState = GS.ExitDone $ frames + 8}}
  -- some delay after the transition is done
  | frames < fromIntegral gameWidth + 32 =
      pure e {state = e.state {GS.playState = GS.ExitDone $ frames + 1}}
  | otherwise = do
      map' <- M.load (e.mapList !! (e.state.currentLevel + 1)) e.tsTexture
      entities <- E.mkEntities e.sprites map' e.controlsRef
      pure $
        e
          { map = map',
            state = (GS.levelState e.state map') {GS.currentLevel = e.state.currentLevel + 1},
            entities = entities
          }

gameOverLoop :: Env -> IO Env
gameOverLoop e = do
  let renderer = e.renderer
      sprites = e.sprites
      state = e.state
      hud = e.hud
      font = e.font
      map' = e.map
      controlsRef = e.controlsRef

  ctl <- readIORef controlsRef

  if ctl.a
    then do
      -- retry last level
      entities <- E.mkEntities sprites map' controlsRef
      pure
        e {state = (GS.levelState e.state map') {GS.lives = GS.maxLives}, entities = entities}
    else do
      SDL.clear renderer
      H.render renderer hud state
      title <- S.get sprites "game-over"
      S.render renderer title 112 80 0 0

      BF.renderText renderer font 109 116 "Press    to retry"
      button <- S.get sprites "ui"
      let buttonOrKey = case ctl.joyId of
            Just _ -> 1
            Nothing -> 2
      S.render renderer button 143 113 0 buttonOrKey

      BF.renderText renderer font 112 132 "(or ESC to quit)"
      pure e