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
|
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 qualified Game.Hud as H
import qualified Game.Map as M
import qualified Game.Sprites as S
import qualified Game.State as GS
import Game.Utils (isPressed)
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 :: 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
}
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
map' = env.map
entities = env.entities
hud = env.hud
font = env.font
events <- map SDL.eventPayload <$> SDL.pollEvents
-- F11 for fullscreen / windowed
when (fromMaybe False $ isPressed SDL.KeycodeF11 events) toggleFullscreen
-- ESC or close the window to quit
let quit = fromMaybe False (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
updated <- liftIO $ E.updateAll =<< readIORef entities
entities $= updated
-- render map and entities
void $ liftIO $ do
M.render renderer map'
H.render renderer hud
E.render renderer updated
BF.renderText renderer font 120 178 "This is a test!"
SDL.rendererRenderTarget renderer $= Nothing
SDL.clear renderer
rect <- SDL.get renderRect
SDL.copy renderer canvas Nothing (Just rect)
SDL.present renderer
gameLoop
|
