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
|
