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
|
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.Controller as C
import qualified Game.Entities as E
import qualified Game.Map as M
import qualified Game.Sprites as S
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, 180)
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 :: IORef Bool,
_renderRect :: IORef (SDL.Rectangle CInt),
_controls :: IORef C.Controls,
_map :: M.Map,
_sprites :: S.SpriteSheet,
_entities :: IORef E.Entities
}
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"
controls <- newIORef =<< C.init
map' <- M.load "data/map.json" tsTexture
sprites <- S.load "data/sprites.json" ssTexture
entities <- newIORef $ E.mkEntities sprites
player <- E.mkPlayer sprites 32 104 controls (M.isBlocked map')
entities $~ E.append player
runReaderT gameLoop (Env window renderer canvas fullscreen renderRect controls map' sprites entities)
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
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 $~ 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'
E.render renderer updated
SDL.rendererRenderTarget renderer $= Nothing
rect <- SDL.get renderRect
SDL.copy renderer canvas Nothing (Just rect)
SDL.present renderer
gameLoop
|
