aboutsummaryrefslogtreecommitdiff
path: root/Demos/Pong/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Demos/Pong/Main.hs')
-rw-r--r--Demos/Pong/Main.hs22
1 files changed, 12 insertions, 10 deletions
diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs
index a49efec..ac0feab 100644
--- a/Demos/Pong/Main.hs
+++ b/Demos/Pong/Main.hs
@@ -18,9 +18,11 @@ data GameState = GameState
18 world :: [GameObject] 18 world :: [GameObject]
19 } 19 }
20 20
21app = App step render resize
22
21main = 23main =
22 withWindow (900, 600) (2, 0) (Just "Pong") initGame $ 24 withWindow (900, 600) (2, 0) (Just "Pong") initGame $
23 loop step 25 loop app
24 26
25initGame :: Window -> Game () GameState 27initGame :: Window -> Game () GameState
26initGame window = return $ GameState window newWorld 28initGame window = return $ GameState window newWorld
@@ -28,16 +30,18 @@ initGame window = return $ GameState window newWorld
28step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool 30step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
29step elapsed dt inputEvents = do 31step elapsed dt inputEvents = do
30 gs <- getGameState 32 gs <- getGameState
31 gameIO . process $ inputEvents
32 let events = translateEvents inputEvents 33 let events = translateEvents inputEvents
33 modifyGameState $ \gs -> 34 modifyGameState $ \gs ->
34 gs 35 gs
35 { world = stepWorld (realToFrac elapsed) dt events (world gs) 36 { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gs)
36 } 37 }
37 getGameState >>= \gs -> gameIO . render $ world gs
38 return (not $ exitRequested inputEvents) 38 return (not $ exitRequested inputEvents)
39 39
40render world = do 40render :: Game GameState ()
41render = getGameState >>= \gs -> gameIO . render' $ world gs
42
43render' :: [GameObject] -> IO ()
44render' world = do
41 -- Clear the background to a different colour than the playable area to make 45 -- Clear the background to a different colour than the playable area to make
42 -- the latter distinguishable. 46 -- the latter distinguishable.
43 GL.clearColor $= GL.Color4 0.2 0.2 0.2 0.0 47 GL.clearColor $= GL.Color4 0.2 0.2 0.2 0.0
@@ -74,22 +78,20 @@ renderGO go = do
74 GL.vertex (GL.Vertex2 xmax ymax) 78 GL.vertex (GL.Vertex2 xmax ymax)
75 GL.vertex (GL.Vertex2 xmax ymin) 79 GL.vertex (GL.Vertex2 xmax ymin)
76 80
77process = mapM_ procEvent 81resize :: WindowEvent -> Game s ()
78 82resize (ResizeEvent w h) =
79procEvent (Resize w h) =
80 let r = fromIntegral w / fromIntegral h 83 let r = fromIntegral w / fromIntegral h
81 pad = if r > 1 then (r-1) / 2 else (1/r - 1) / 2 84 pad = if r > 1 then (r-1) / 2 else (1/r - 1) / 2
82 left = if r > 1 then -pad else 0 85 left = if r > 1 then -pad else 0
83 right = if r > 1 then 1 + pad else 1 86 right = if r > 1 then 1 + pad else 1
84 bottom = if r > 1 then 0 else -pad 87 bottom = if r > 1 then 0 else -pad
85 top = if r > 1 then 1 else 1 + pad 88 top = if r > 1 then 1 else 1 + pad
86 in do 89 in gameIO $ do
87 GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) 90 GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
88 GL.matrixMode $= GL.Projection 91 GL.matrixMode $= GL.Projection
89 GL.loadIdentity 92 GL.loadIdentity
90 GL.ortho left right bottom top (-1) 1 93 GL.ortho left right bottom top (-1) 1
91 GL.matrixMode $= GL.Modelview 0 94 GL.matrixMode $= GL.Modelview 0
92procEvent _ = return ()
93 95
94translateEvents = mapMaybe translateEvents' 96translateEvents = mapMaybe translateEvents'
95 where translateEvents' (KeyDown KEY_LEFT) = Just MoveLeft 97 where translateEvents' (KeyDown KEY_LEFT) = Just MoveLeft