aboutsummaryrefslogtreecommitdiff
path: root/src/Game.hs
blob: 4f84ad1ca4ba3bcae1252eacb1baad265b5a9f41 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
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 Nothing

    gameOverLoop :: Env -> IO ()
    gameOverLoop env = do
      let renderer = env.renderer
          sprites = env.sprites

      title <- S.get sprites "game-over"
      S.render renderer title 112 80 0 0