blob: a49efecf5ceb51e104238e5e96ca59c61cdf7133 (
plain)
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
|
module Main where
import Data.Maybe (mapMaybe)
import Graphics.Rendering.OpenGL.GL (($=))
import qualified Graphics.Rendering.OpenGL.GL as GL
import Graphics.Rendering.OpenGL.GL.VertexSpec (currentColor)
import Pong
import Spear.App
import Spear.Game
import Spear.Math.AABB
import Spear.Math.Spatial
import Spear.Math.Spatial2
import Spear.Math.Vector
import Spear.Window
data GameState = GameState
{ window :: Window,
world :: [GameObject]
}
main =
withWindow (900, 600) (2, 0) (Just "Pong") initGame $
loop step
initGame :: Window -> Game () GameState
initGame window = return $ GameState window newWorld
step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
step elapsed dt inputEvents = do
gs <- getGameState
gameIO . process $ inputEvents
let events = translateEvents inputEvents
modifyGameState $ \gs ->
gs
{ world = stepWorld (realToFrac elapsed) dt events (world gs)
}
getGameState >>= \gs -> gameIO . render $ world gs
return (not $ exitRequested inputEvents)
render world = do
-- Clear the background to a different colour than the playable area to make
-- the latter distinguishable.
GL.clearColor $= GL.Color4 0.2 0.2 0.2 0.0
GL.clear [GL.ColorBuffer]
GL.matrixMode $= GL.Modelview 0
GL.loadIdentity
renderBackground
-- Draw objects.
GL.currentColor $= GL.Color4 1.0 1.0 1.0 1.0
mapM_ renderGO world
renderBackground :: IO ()
renderBackground =
let pmin = 0 :: Float
pmax = 1 :: Float
in do
GL.currentColor $= GL.Color4 0.7 0.5 0.7 1.0
GL.renderPrimitive GL.TriangleStrip $ do
GL.vertex (GL.Vertex2 pmin pmax)
GL.vertex (GL.Vertex2 pmin pmin)
GL.vertex (GL.Vertex2 pmax pmax)
GL.vertex (GL.Vertex2 pmax pmin)
renderGO :: GameObject -> IO ()
renderGO go = do
let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go
(Vector2 xcenter ycenter) = position go
(xmin, ymin, xmax, ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax')
GL.preservingMatrix $ do
GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0)
GL.renderPrimitive GL.TriangleStrip $ do
GL.vertex (GL.Vertex2 xmin ymax)
GL.vertex (GL.Vertex2 xmin ymin)
GL.vertex (GL.Vertex2 xmax ymax)
GL.vertex (GL.Vertex2 xmax ymin)
process = mapM_ procEvent
procEvent (Resize 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
GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
GL.matrixMode $= GL.Projection
GL.loadIdentity
GL.ortho left right bottom top (-1) 1
GL.matrixMode $= GL.Modelview 0
procEvent _ = return ()
translateEvents = mapMaybe translateEvents'
where translateEvents' (KeyDown KEY_LEFT) = Just MoveLeft
translateEvents' (KeyDown KEY_RIGHT) = Just MoveRight
translateEvents' (KeyUp KEY_LEFT) = Just StopLeft
translateEvents' (KeyUp KEY_RIGHT) = Just StopRight
translateEvents' _ = Nothing
exitRequested = elem (KeyDown KEY_ESC)
f2d :: Float -> GL.GLdouble
f2d = realToFrac
|
