aboutsummaryrefslogtreecommitdiff
path: root/Demos/Pong
diff options
context:
space:
mode:
author3gg <3gg@shellblade.net>2023-03-10 09:03:32 -0800
committer3gg <3gg@shellblade.net>2023-03-10 09:03:32 -0800
commit6e26564f4235eeea5dda386282e18081db6f8f07 (patch)
tree2c9c61f20d8f75385dbc8cdda1a3962de1a4c613 /Demos/Pong
parentf688e3b624226ca843a7256987d9a76560a3ab9b (diff)
Compile demos with main project.
Diffstat (limited to 'Demos/Pong')
-rw-r--r--Demos/Pong/Main.hs83
-rw-r--r--Demos/Pong/Pong.hs142
-rw-r--r--Demos/Pong/Setup.hs3
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
3module Main where
4
5import Data.Maybe (mapMaybe)
6import Graphics.Rendering.OpenGL.GL (($=))
7import Graphics.Rendering.OpenGL.GL qualified as GL
8import Pong
9import Spear.App
10import Spear.Game
11import Spear.Math.AABB
12import Spear.Math.Spatial2
13import Spear.Math.Vector
14import Spear.Window
15
16data GameState = GameState
17 { window :: Window,
18 world :: [GameObject]
19 }
20
21main =
22 withWindow (900, 600) (2, 0) (Just "Pong") initGame $
23 loop step
24
25initGame :: Window -> Game () GameState
26initGame 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
33step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
34step 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
45render world = do
46 GL.clear [GL.ColorBuffer]
47 mapM_ renderGO world
48
49renderGO :: GameObject -> IO ()
50renderGO 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
62process = mapM_ procEvent
63
64procEvent (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
70procEvent _ = return ()
71
72translate = mapMaybe translate'
73
74translate' (KeyDown KEY_LEFT) = Just MoveLeft
75translate' (KeyDown KEY_RIGHT) = Just MoveRight
76translate' (KeyUp KEY_LEFT) = Just StopLeft
77translate' (KeyUp KEY_RIGHT) = Just StopRight
78translate' _ = Nothing
79
80exitRequested = any (== (KeyDown KEY_ESC))
81
82f2d :: Float -> GL.GLdouble
83f2d = 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 @@
1module Pong
2 ( GameEvent (..),
3 GameObject,
4 newWorld,
5 stepWorld,
6 aabb,
7 )
8where
9
10import Data.Monoid (mconcat)
11import GHC.Float (double2Float)
12import Spear.Math.AABB
13import Spear.Math.Spatial2
14import Spear.Math.Vector
15import Spear.Step
16
17-- Configuration
18
19padSize = vec2 0.05 0.02
20
21ballSize = 0.01
22
23ballVelocity = vec2 0.3 0.3
24
25playerSpeed = 0.7
26
27initialEnemyPos = vec2 0.5 0.9
28
29initialPlayerPos = vec2 0.5 0.1
30
31initialBallPos = vec2 0.5 0.5
32
33-- Game events
34
35data GameEvent
36 = MoveLeft
37 | MoveRight
38 | StopLeft
39 | StopRight
40 deriving (Eq, Ord)
41
42-- Game objects
43
44data GameObject = GameObject
45 { aabb :: AABB2,
46 obj :: Obj2,
47 gostep :: Step [GameObject] [GameEvent] GameObject GameObject
48 }
49
50instance Spatial2 GameObject where
51 getObj2 = obj
52 setObj2 s o = s {obj = o}
53
54stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
55stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos
56
57update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
58update elapsed dt evts gos go =
59 let (go', s') = runStep (gostep go) elapsed dt gos evts go
60 in go' {gostep = s'}
61
62ballBox, padBox :: AABB2
63ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize
64padBox = AABB2 (-padSize) padSize
65
66obj2 = obj2FromVectors unitx2 unity2
67
68newWorld =
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
76stepBall vel = collideBall vel .> moveBall
77
78collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject)
79collideBall 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
91collide 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
102aabbAdd (AABB2 pmin pmax) p = AABB2 (p + pmin) (p + pmax)
103
104moveBall :: Step s e (Vector2, GameObject) GameObject
105moveBall = step $ \_ dt _ _ (vel, ball) -> (move (scale dt vel) ball, moveBall)
106
107-- Enemy stepper
108
109stepEnemy = movePad
110
111movePad :: Step s e GameObject GameObject
112movePad = 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
122stepPlayer = sfold moveGO .> clamp
123
124moveGO =
125 mconcat
126 [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-playerSpeed) 0),
127 switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0)
128 ]
129
130moveGO' :: Vector2 -> Step s e GameObject GameObject
131moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir)
132
133clamp :: Step s e GameObject GameObject
134clamp = 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 @@
1import Distribution.Simple
2
3main = defaultMain