module Game (main) where import Control.Monad import Data.IORef import Data.Maybe (fromMaybe) import Data.Text (pack) import Foreign.C.Types (CInt) import Game.BitmapFont qualified as BF import Game.Controller qualified as C import Game.Entities qualified as E import Game.Hud qualified as H import Game.Map qualified as M import Game.Sprites qualified as S import Game.State qualified as GS import Game.Toaster qualified as T import Game.Utils qualified as U import SDL (($=)) import SDL qualified import SDL.Image qualified 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