aboutsummaryrefslogtreecommitdiff
path: root/src/Game.hs
blob: 41c8178d4d35a4d98f82476dc915276b76ebc820 (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
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.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

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 :: Bool,
    renderRect :: SDL.Rectangle CInt,
    map :: M.Map,
    sprites :: S.SpriteSheet,
    font :: BF.BitmapFont,
    entities :: E.Entities,
    hud :: H.Hud,
    controls :: IORef C.Controls,
    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)
  tsTexture <- SDL.Image.loadTexture renderer "data/tiles.png"
  ssTexture <- SDL.Image.loadTexture renderer "data/sprites.png"
  bfTexture <- SDL.Image.loadTexture renderer "data/font.png"
  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
        }
  controls <- newIORef =<< C.init
  hud <- H.mkHud sprites state
  entities <- E.mkEntities sprites map' controls state
  gameLoop
    Env
      { window = window,
        renderer = renderer,
        canvas = canvas,
        fullscreen = False,
        renderRect = defaultRenderRect,
        map = map',
        sprites = sprites,
        font = font,
        entities = entities,
        hud = hud,
        controls = controls,
        state = state
      }
  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

  -- F11 for fullscreen / windowed
  env <- if fromMaybe False $ U.isPressed SDL.KeycodeF11 events then toggleFullscreen e else pure e

  let renderer = env.renderer
      canvas = env.canvas
      renderRect = env.renderRect
      controls = env.controls
      stateRef = env.state
      entities = env.entities

  -- 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

    state <- readIORef stateRef
    when (state.gameOverDelay > 1) $ stateRef $= state {GS.gameOverDelay = state.gameOverDelay - 1}
    when (state.gameOverDelay == 1) $ gameOverLoop env

    updatedEntities <- if state.gameOverDelay /= 1 then playLoop env else pure entities

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

    SDL.present renderer

    gameLoop env {entities = updatedEntities}

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

  updated <- E.updateAll entities

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

  -- render map and entities

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

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

  pure updated

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

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