aboutsummaryrefslogtreecommitdiff
path: root/src/Game.hs
blob: c2f6083ce7dd2b375b09460f75588b5d0968a451 (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
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
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 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,
    state :: GS.State,
    controls :: 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
  controls <- newIORef C.init
  entities <- E.mkEntities sprites map' controls
  hud <- H.mkHud sprites font
  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,
        state = GS.initialState map',
        controls = controls
      }
  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
      controls = env.controls
      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
    writeIORef controls =<< (`C.update` events) =<< readIORef controls

    SDL.rendererRenderTarget renderer $= Just canvas
    SDL.clear renderer

    updatedEnv <-
      if state.gameOverDelay /= 1
        then playLoop =<< updateState env
        else gameOverLoop env

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

    SDL.present renderer

    gameLoop updatedEnv
  where
    -- update state counters, etc
    updateState :: Env -> IO Env
    updateState env
      | state.gameOverDelay > 1 = pure env {state = state {GS.gameOverDelay = state.gameOverDelay - 1}}
      | 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}}
      | state.levelCompleted == GS.ExitDone = do
          map' <- M.load (env.mapList !! (env.state.currentLevel + 1)) env.tsTexture
          entities <- E.mkEntities env.sprites map' env.controls
          pure $
            env
              { map = map',
                state = (GS.levelState env.state map') {GS.currentLevel = env.state.currentLevel + 1},
                entities = entities
              }
      | otherwise = pure env
      where
        state = env.state
        (x, y) = state.lastBattery

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

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

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

  -- 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 e {state = state, entities = updated}

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
      controls = e.controls

  ctl <- readIORef controls

  if ctl.a
    then do
      -- retry last level
      entities <- E.mkEntities sprites map' controls
      pure
        e {state = (GS.levelState e.state map') {GS.lives = GS.maxLives}, entities = entities}
    else do
      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