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
|
