diff options
Diffstat (limited to 'demos/pong/Main.hs')
-rw-r--r-- | demos/pong/Main.hs | 86 |
1 files changed, 86 insertions, 0 deletions
diff --git a/demos/pong/Main.hs b/demos/pong/Main.hs new file mode 100644 index 0000000..8c379ec --- /dev/null +++ b/demos/pong/Main.hs | |||
@@ -0,0 +1,86 @@ | |||
1 | module Main where | ||
2 | |||
3 | import Pong | ||
4 | |||
5 | import Spear.Math.AABB | ||
6 | import Spear.Math.Spatial2 | ||
7 | import Spear.Math.Vector | ||
8 | import Spear.Game | ||
9 | import Spear.Window | ||
10 | |||
11 | import Data.Maybe (mapMaybe) | ||
12 | import qualified Graphics.Rendering.OpenGL.GL as GL | ||
13 | import Graphics.Rendering.OpenGL.GL (($=)) | ||
14 | |||
15 | data GameState = GameState | ||
16 | { wnd :: Window | ||
17 | , elapsed :: Double | ||
18 | , world :: [GameObject] | ||
19 | } | ||
20 | |||
21 | main = do | ||
22 | result <- run | ||
23 | case result of | ||
24 | Left err -> putStrLn err | ||
25 | Right _ -> return () | ||
26 | |||
27 | run = withWindow (640,480) [] Window (2,0) (Just "Pong") initGame | ||
28 | $ loop (Just 30) step | ||
29 | |||
30 | initGame wnd = do | ||
31 | gameIO $ do | ||
32 | GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0 | ||
33 | GL.matrixMode $= GL.Modelview 0 | ||
34 | GL.loadIdentity | ||
35 | return $ GameState wnd 0 newWorld | ||
36 | |||
37 | step :: Dt -> Game GameState Bool | ||
38 | step dt = do | ||
39 | gs <- getGameState | ||
40 | evts <- events (wnd gs) | ||
41 | gameIO . process $ evts | ||
42 | let evts' = translate evts | ||
43 | modifyGameState $ \ gs -> gs | ||
44 | { world = stepWorld (elapsed gs) dt evts' (world gs) | ||
45 | , elapsed = elapsed gs + realToFrac dt } | ||
46 | getGameState >>= \gs -> gameIO . render $ world gs | ||
47 | return (not $ exitRequested evts) | ||
48 | |||
49 | render world = do | ||
50 | GL.clear [GL.ColorBuffer] | ||
51 | mapM_ renderGO world | ||
52 | swapBuffers | ||
53 | |||
54 | renderGO :: GameObject -> IO () | ||
55 | renderGO go = do | ||
56 | let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go | ||
57 | (Vector2 xcenter ycenter) = pos go | ||
58 | (xmin,ymin,xmax,ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax') | ||
59 | GL.preservingMatrix $ do | ||
60 | GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0) | ||
61 | GL.renderPrimitive (GL.TriangleStrip) $ do | ||
62 | GL.vertex (GL.Vertex2 xmin ymax) | ||
63 | GL.vertex (GL.Vertex2 xmin ymin) | ||
64 | GL.vertex (GL.Vertex2 xmax ymax) | ||
65 | GL.vertex (GL.Vertex2 xmax ymin) | ||
66 | |||
67 | process = mapM_ procEvent | ||
68 | procEvent (Resize w h) = do | ||
69 | GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) | ||
70 | GL.matrixMode $= GL.Projection | ||
71 | GL.loadIdentity | ||
72 | GL.ortho 0 1 0 1 (-1) 1 | ||
73 | GL.matrixMode $= GL.Modelview 0 | ||
74 | procEvent _ = return () | ||
75 | |||
76 | translate = mapMaybe translate' | ||
77 | translate' (KeyDown KEY_LEFT) = Just MoveLeft | ||
78 | translate' (KeyDown KEY_RIGHT) = Just MoveRight | ||
79 | translate' (KeyUp KEY_LEFT) = Just StopLeft | ||
80 | translate' (KeyUp KEY_RIGHT) = Just StopRight | ||
81 | translate' _ = Nothing | ||
82 | |||
83 | exitRequested = any (==(KeyDown KEY_ESC)) | ||
84 | |||
85 | f2d :: Float -> GL.GLdouble | ||
86 | f2d = realToFrac \ No newline at end of file | ||