diff options
Diffstat (limited to 'Demos/Pong')
-rw-r--r-- | Demos/Pong/Main.hs | 83 | ||||
-rw-r--r-- | Demos/Pong/Pong.hs | 142 | ||||
-rw-r--r-- | Demos/Pong/Setup.hs | 3 |
3 files changed, 228 insertions, 0 deletions
diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs new file mode 100644 index 0000000..4dbe0a3 --- /dev/null +++ b/Demos/Pong/Main.hs | |||
@@ -0,0 +1,83 @@ | |||
1 | {-# LANGUAGE ImportQualifiedPost #-} | ||
2 | |||
3 | module Main where | ||
4 | |||
5 | import Data.Maybe (mapMaybe) | ||
6 | import Graphics.Rendering.OpenGL.GL (($=)) | ||
7 | import Graphics.Rendering.OpenGL.GL qualified as GL | ||
8 | import Pong | ||
9 | import Spear.App | ||
10 | import Spear.Game | ||
11 | import Spear.Math.AABB | ||
12 | import Spear.Math.Spatial2 | ||
13 | import Spear.Math.Vector | ||
14 | import Spear.Window | ||
15 | |||
16 | data GameState = GameState | ||
17 | { window :: Window, | ||
18 | world :: [GameObject] | ||
19 | } | ||
20 | |||
21 | main = | ||
22 | withWindow (900, 600) (2, 0) (Just "Pong") initGame $ | ||
23 | loop step | ||
24 | |||
25 | initGame :: Window -> Game () GameState | ||
26 | initGame window = do | ||
27 | gameIO $ do | ||
28 | GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0 | ||
29 | GL.matrixMode $= GL.Modelview 0 | ||
30 | GL.loadIdentity | ||
31 | return $ GameState window newWorld | ||
32 | |||
33 | step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool | ||
34 | step elapsed dt inputEvents = do | ||
35 | gs <- getGameState | ||
36 | gameIO . process $ inputEvents | ||
37 | let events = translate inputEvents | ||
38 | modifyGameState $ \gs -> | ||
39 | gs | ||
40 | { world = stepWorld elapsed dt events (world gs) | ||
41 | } | ||
42 | getGameState >>= \gs -> gameIO . render $ world gs | ||
43 | return (not $ exitRequested inputEvents) | ||
44 | |||
45 | render world = do | ||
46 | GL.clear [GL.ColorBuffer] | ||
47 | mapM_ renderGO world | ||
48 | |||
49 | renderGO :: GameObject -> IO () | ||
50 | renderGO go = do | ||
51 | let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go | ||
52 | (Vector2 xcenter ycenter) = pos go | ||
53 | (xmin, ymin, xmax, ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax') | ||
54 | GL.preservingMatrix $ do | ||
55 | GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0) | ||
56 | GL.renderPrimitive (GL.TriangleStrip) $ do | ||
57 | GL.vertex (GL.Vertex2 xmin ymax) | ||
58 | GL.vertex (GL.Vertex2 xmin ymin) | ||
59 | GL.vertex (GL.Vertex2 xmax ymax) | ||
60 | GL.vertex (GL.Vertex2 xmax ymin) | ||
61 | |||
62 | process = mapM_ procEvent | ||
63 | |||
64 | procEvent (Resize w h) = do | ||
65 | GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) | ||
66 | GL.matrixMode $= GL.Projection | ||
67 | GL.loadIdentity | ||
68 | GL.ortho 0 1 0 1 (-1) 1 | ||
69 | GL.matrixMode $= GL.Modelview 0 | ||
70 | procEvent _ = return () | ||
71 | |||
72 | translate = mapMaybe translate' | ||
73 | |||
74 | translate' (KeyDown KEY_LEFT) = Just MoveLeft | ||
75 | translate' (KeyDown KEY_RIGHT) = Just MoveRight | ||
76 | translate' (KeyUp KEY_LEFT) = Just StopLeft | ||
77 | translate' (KeyUp KEY_RIGHT) = Just StopRight | ||
78 | translate' _ = Nothing | ||
79 | |||
80 | exitRequested = any (== (KeyDown KEY_ESC)) | ||
81 | |||
82 | f2d :: Float -> GL.GLdouble | ||
83 | f2d = realToFrac | ||
diff --git a/Demos/Pong/Pong.hs b/Demos/Pong/Pong.hs new file mode 100644 index 0000000..b048bbc --- /dev/null +++ b/Demos/Pong/Pong.hs | |||
@@ -0,0 +1,142 @@ | |||
1 | module Pong | ||
2 | ( GameEvent (..), | ||
3 | GameObject, | ||
4 | newWorld, | ||
5 | stepWorld, | ||
6 | aabb, | ||
7 | ) | ||
8 | where | ||
9 | |||
10 | import Data.Monoid (mconcat) | ||
11 | import GHC.Float (double2Float) | ||
12 | import Spear.Math.AABB | ||
13 | import Spear.Math.Spatial2 | ||
14 | import Spear.Math.Vector | ||
15 | import Spear.Step | ||
16 | |||
17 | -- Configuration | ||
18 | |||
19 | padSize = vec2 0.05 0.02 | ||
20 | |||
21 | ballSize = 0.01 | ||
22 | |||
23 | ballVelocity = vec2 0.3 0.3 | ||
24 | |||
25 | playerSpeed = 0.7 | ||
26 | |||
27 | initialEnemyPos = vec2 0.5 0.9 | ||
28 | |||
29 | initialPlayerPos = vec2 0.5 0.1 | ||
30 | |||
31 | initialBallPos = vec2 0.5 0.5 | ||
32 | |||
33 | -- Game events | ||
34 | |||
35 | data GameEvent | ||
36 | = MoveLeft | ||
37 | | MoveRight | ||
38 | | StopLeft | ||
39 | | StopRight | ||
40 | deriving (Eq, Ord) | ||
41 | |||
42 | -- Game objects | ||
43 | |||
44 | data GameObject = GameObject | ||
45 | { aabb :: AABB2, | ||
46 | obj :: Obj2, | ||
47 | gostep :: Step [GameObject] [GameEvent] GameObject GameObject | ||
48 | } | ||
49 | |||
50 | instance Spatial2 GameObject where | ||
51 | getObj2 = obj | ||
52 | setObj2 s o = s {obj = o} | ||
53 | |||
54 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] | ||
55 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos | ||
56 | |||
57 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject | ||
58 | update elapsed dt evts gos go = | ||
59 | let (go', s') = runStep (gostep go) elapsed dt gos evts go | ||
60 | in go' {gostep = s'} | ||
61 | |||
62 | ballBox, padBox :: AABB2 | ||
63 | ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize | ||
64 | padBox = AABB2 (-padSize) padSize | ||
65 | |||
66 | obj2 = obj2FromVectors unitx2 unity2 | ||
67 | |||
68 | newWorld = | ||
69 | [ GameObject ballBox (obj2 initialBallPos) $ stepBall ballVelocity, | ||
70 | GameObject padBox (obj2 initialEnemyPos) stepEnemy, | ||
71 | GameObject padBox (obj2 initialPlayerPos) stepPlayer | ||
72 | ] | ||
73 | |||
74 | -- Ball steppers | ||
75 | |||
76 | stepBall vel = collideBall vel .> moveBall | ||
77 | |||
78 | collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) | ||
79 | collideBall vel = step $ \_ dt gos _ ball -> | ||
80 | let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball | ||
81 | collideCol = x pmin < 0 || x pmax > 1 | ||
82 | collideRow = y pmin < 0 || y pmax > 1 || any (collide ball) (tail gos) | ||
83 | negx v@(Vector2 x y) = if collideCol then vec2 (-x) y else v | ||
84 | negy v@(Vector2 x y) = if collideRow then vec2 x (-y) else v | ||
85 | vel' = negx . negy $ vel | ||
86 | delta = dt -- A small delta to apply when collision occurs. | ||
87 | adjustX = if collideCol then scale delta (vec2 (x vel) 0) else vec2 0 0 | ||
88 | adjustY = if collideRow then scale delta (vec2 0 (y vel)) else vec2 0 0 | ||
89 | in ((vel' + adjustX + adjustY, ball), collideBall vel') | ||
90 | |||
91 | collide go1 go2 = | ||
92 | let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) = | ||
93 | aabb go1 `aabbAdd` pos go1 | ||
94 | (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) = | ||
95 | aabb go2 `aabbAdd` pos go2 | ||
96 | in not $ | ||
97 | xmax1 < xmin2 | ||
98 | || xmin1 > xmax2 | ||
99 | || ymax1 < ymin2 | ||
100 | || ymin1 > ymax2 | ||
101 | |||
102 | aabbAdd (AABB2 pmin pmax) p = AABB2 (p + pmin) (p + pmax) | ||
103 | |||
104 | moveBall :: Step s e (Vector2, GameObject) GameObject | ||
105 | moveBall = step $ \_ dt _ _ (vel, ball) -> (move (scale dt vel) ball, moveBall) | ||
106 | |||
107 | -- Enemy stepper | ||
108 | |||
109 | stepEnemy = movePad | ||
110 | |||
111 | movePad :: Step s e GameObject GameObject | ||
112 | movePad = step $ \elapsed _ _ _ pad -> | ||
113 | let p = vec2 px 0.9 | ||
114 | px = | ||
115 | double2Float (sin elapsed * 0.5 + 0.5) | ||
116 | * (1 - 2 * x padSize) | ||
117 | + x padSize | ||
118 | in (setPos p pad, movePad) | ||
119 | |||
120 | -- Player stepper | ||
121 | |||
122 | stepPlayer = sfold moveGO .> clamp | ||
123 | |||
124 | moveGO = | ||
125 | mconcat | ||
126 | [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-playerSpeed) 0), | ||
127 | switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0) | ||
128 | ] | ||
129 | |||
130 | moveGO' :: Vector2 -> Step s e GameObject GameObject | ||
131 | moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir) | ||
132 | |||
133 | clamp :: Step s e GameObject GameObject | ||
134 | clamp = spure $ \go -> | ||
135 | let p' = vec2 (clamp' x s (1 - s)) y | ||
136 | (Vector2 x y) = pos go | ||
137 | clamp' x a b | ||
138 | | x < a = a | ||
139 | | x > b = b | ||
140 | | otherwise = x | ||
141 | (Vector2 s _) = padSize | ||
142 | in setPos p' go | ||
diff --git a/Demos/Pong/Setup.hs b/Demos/Pong/Setup.hs new file mode 100644 index 0000000..e8ef27d --- /dev/null +++ b/Demos/Pong/Setup.hs | |||
@@ -0,0 +1,3 @@ | |||
1 | import Distribution.Simple | ||
2 | |||
3 | main = defaultMain | ||