module Game (main) where import Control.Monad.Reader 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 Game.Entities.Const (gameOverDelay) 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.Utils as U import SDL (($=), ($~)) import qualified SDL import qualified SDL.Image import SDL.Vect (V2 (..), V4 (..)) name :: String name = "Haskell gamedev [Space Platformer]" gameWidth, gameHeight :: CInt (gameWidth, gameHeight) = (320, 192) gameScale :: CInt gameScale = 3 maxLives :: Int maxLives = 4 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 :: IORef Bool, renderRect :: IORef (SDL.Rectangle CInt), controls :: IORef C.Controls, map :: M.Map, sprites :: S.SpriteSheet, font :: BF.BitmapFont, entities :: IORef E.Entities, hud :: H.Hud, state :: IORef GS.State } 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) fullscreen <- newIORef False renderRect <- newIORef defaultRenderRect tsTexture <- SDL.Image.loadTexture renderer "data/tiles.png" ssTexture <- SDL.Image.loadTexture renderer "data/sprites.png" bfTexture <- SDL.Image.loadTexture renderer "data/font.png" controls <- newIORef =<< C.init map' <- M.load "data/map.json" tsTexture sprites <- S.load "data/sprites.json" ssTexture font <- BF.load "data/font.json" bfTexture state <- newIORef GS.State { batteries = 0, totalBatteries = M.totalBatteries map', lives = maxLives, totalLives = maxLives, hitDelay = 0, gameOverDelay = 0 } hud <- H.mkHud sprites state entities <- newIORef =<< E.mkEntities sprites map' controls state runReaderT gameLoop Env { window = window, renderer = renderer, canvas = canvas, fullscreen = fullscreen, renderRect = renderRect, controls = controls, map = map', sprites = sprites, font = font, entities = entities, hud = hud, state = state } SDL.destroyWindow window SDL.quit toggleFullscreen :: ReaderT Env IO () toggleFullscreen = do env <- ask let fullscreen = env.fullscreen renderRect = env.renderRect renderer = env.renderer window = env.window fullscreen $~ not fs <- SDL.get fullscreen let mode = if fs then SDL.FullscreenDesktop else SDL.Windowed in SDL.setWindowMode window mode vp <- if fs then SDL.get $ SDL.rendererViewport renderer else pure Nothing let newRenderRect = 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 in renderRect $= newRenderRect gameLoop :: ReaderT Env IO () gameLoop = do env <- ask let renderer = env.renderer canvas = env.canvas renderRect = env.renderRect controls = env.controls stateRef = env.state events <- map SDL.eventPayload <$> SDL.pollEvents -- F11 for fullscreen / windowed when (fromMaybe False $ U.isPressed SDL.KeycodeF11 events) toggleFullscreen -- ESC or close the window to quit let quit = fromMaybe False (U.isPressed SDL.KeycodeEscape events) || SDL.QuitEvent `elem` events unless quit $ do -- update controls controls $~ flip C.update events SDL.rendererRenderTarget renderer $= Just canvas SDL.clear renderer void $ liftIO $ do state <- readIORef stateRef if state.lives > 0 then playLoop env else if state.gameOverDelay > 0 then fadeOutLoop env state.gameOverDelay >> stateRef $= state {GS.gameOverDelay = state.gameOverDelay - 1} else gameOverLoop env SDL.rendererRenderTarget renderer $= Nothing SDL.clear renderer rect <- SDL.get renderRect SDL.copy renderer canvas Nothing (Just rect) SDL.present renderer gameLoop where playLoop :: Env -> IO () playLoop env = do let renderer = env.renderer map' = env.map entities = env.entities hud = env.hud updated <- E.updateAll =<< readIORef entities entities $= updated -- render map and entities void $ do M.render renderer map' H.render renderer hud E.render renderer updated fadeOutLoop :: Env -> Int -> IO () fadeOutLoop env i = do let renderer = env.renderer map' = env.map entities = env.entities hud = env.hud -- render map and entities -- doing a fade to black void $ do M.render renderer map' H.render renderer hud E.render renderer =<< readIORef entities SDL.rendererDrawBlendMode renderer $= SDL.BlendAlphaBlend SDL.rendererDrawColor renderer $= V4 0 0 0 (fromIntegral (255 - i * (255 `div` gameOverDelay))) SDL.fillRect renderer (Just $ U.rect 0 0 320 176) gameOverLoop :: Env -> IO () gameOverLoop env = do let renderer = env.renderer sprites = env.sprites hud = env.hud H.render renderer hud title <- S.get sprites "game-over" S.render renderer title 112 80 0 0