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
|
module Main where
import Pong
import Spear.App
import Spear.Game
import Spear.Math.AABB
import Spear.Math.Matrix4 as Matrix4 hiding (position)
import Spear.Math.Spatial
import Spear.Math.Spatial2
import Spear.Math.Vector
import Spear.Render.Core.Pipeline
import Spear.Render.Core.State
import Spear.Render.Immediate
import Spear.Window
import Data.Maybe (mapMaybe)
data GameState = GameState
{ window :: Window
, renderCoreState :: RenderCoreState
, immRenderState :: ImmRenderState
, viewProjection :: Matrix4
, world :: [GameObject]
}
app = App step render resize
main =
withWindow (900, 600) (Just "Pong") initGame endGame $
loop app
initGame :: Window -> Game () GameState
initGame window = do
(immRenderState, renderCoreState) <- runSiblingGame newImmRenderer newRenderCoreState
return $ GameState window renderCoreState immRenderState Matrix4.id newWorld
endGame :: Game GameState ()
endGame = do
game <- getGameState
runSubGame' (deleteImmRenderer $ immRenderState game) (renderCoreState game)
step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
step elapsed dt inputEvents = do
gs <- getGameState
let events = translateEvents inputEvents
modifyGameState $ \gs ->
gs
{ world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gs)
}
return (not $ exitRequested inputEvents)
render :: Game GameState ()
render = do
gameState <- getGameState
immRenderState' <- flip execSubGame (immRenderState gameState) $ do
immStart
immSetViewProjectionMatrix (viewProjection gameState)
-- Clear the background to a different colour than the playable area to make
-- the latter distinguishable.
gameIO $ do
setClearColour (0.2, 0.2, 0.2, 0.0)
clearBuffers [ColourBuffer]
render' $ world gameState
immEnd
saveGameState $ gameState { immRenderState = immRenderState' }
render' :: [GameObject] -> Game ImmRenderState ()
render' world = do
immLoadIdentity
renderBackground
-- Draw objects.
immSetColour (vec4 1.0 1.0 1.0 1.0)
mapM_ renderGO world
renderBackground :: Game ImmRenderState ()
renderBackground =
let pmin = 0 :: Float
pmax = 1 :: Float
in do
immSetColour (vec4 0.6 0.35 0.6 1.0)
immDrawQuads2d [
(vec2 pmin pmin
,vec2 pmax pmin
,vec2 pmax pmax
,vec2 pmin pmax)]
renderGO :: GameObject -> Game ImmRenderState ()
renderGO go = do
let (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax)) = aabb go
(Vector2 xcenter ycenter) = position go
immPreservingMatrix $ do
immTranslate (vec3 xcenter ycenter 0)
immDrawQuads2d [
(vec2 xmin ymin
,vec2 xmax ymin
,vec2 xmax ymax
,vec2 xmin ymax)]
resize :: WindowEvent -> Game GameState ()
resize (ResizeEvent w h) =
let r = fromIntegral w / fromIntegral h
pad = if r > 1 then (r-1) / 2 else (1/r - 1) / 2
left = if r > 1 then -pad else 0
right = if r > 1 then 1 + pad else 1
bottom = if r > 1 then 0 else -pad
top = if r > 1 then 1 else 1 + pad
in do
gameIO $ setViewport 0 0 w h
modifyGameState $ \state -> state {
viewProjection = Matrix4.ortho left right bottom top (-1) 1
}
translateEvents = mapMaybe translateEvents'
where translateEvents' (KeyDown KEY_A) = Just MoveLeft
translateEvents' (KeyDown KEY_D) = Just MoveRight
translateEvents' (KeyUp KEY_A) = Just StopLeft
translateEvents' (KeyUp KEY_D) = Just StopRight
translateEvents' _ = Nothing
exitRequested = elem (KeyDown KEY_ESC)
|
