aboutsummaryrefslogtreecommitdiff
path: root/Demos
diff options
context:
space:
mode:
Diffstat (limited to 'Demos')
-rw-r--r--Demos/Pong/Main.hs22
-rw-r--r--Demos/Pong/Pong.hs109
2 files changed, 80 insertions, 51 deletions
diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs
index 0644f9d..a49efec 100644
--- a/Demos/Pong/Main.hs
+++ b/Demos/Pong/Main.hs
@@ -8,6 +8,7 @@ import Pong
8import Spear.App 8import Spear.App
9import Spear.Game 9import Spear.Game
10import Spear.Math.AABB 10import Spear.Math.AABB
11import Spear.Math.Spatial
11import Spear.Math.Spatial2 12import Spear.Math.Spatial2
12import Spear.Math.Vector 13import Spear.Math.Vector
13import Spear.Window 14import Spear.Window
@@ -28,10 +29,10 @@ step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
28step elapsed dt inputEvents = do 29step elapsed dt inputEvents = do
29 gs <- getGameState 30 gs <- getGameState
30 gameIO . process $ inputEvents 31 gameIO . process $ inputEvents
31 let events = translate inputEvents 32 let events = translateEvents inputEvents
32 modifyGameState $ \gs -> 33 modifyGameState $ \gs ->
33 gs 34 gs
34 { world = stepWorld elapsed dt events (world gs) 35 { world = stepWorld (realToFrac elapsed) dt events (world gs)
35 } 36 }
36 getGameState >>= \gs -> gameIO . render $ world gs 37 getGameState >>= \gs -> gameIO . render $ world gs
37 return (not $ exitRequested inputEvents) 38 return (not $ exitRequested inputEvents)
@@ -63,7 +64,7 @@ renderBackground =
63renderGO :: GameObject -> IO () 64renderGO :: GameObject -> IO ()
64renderGO go = do 65renderGO go = do
65 let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go 66 let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go
66 (Vector2 xcenter ycenter) = pos go 67 (Vector2 xcenter ycenter) = position go
67 (xmin, ymin, xmax, ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax') 68 (xmin, ymin, xmax, ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax')
68 GL.preservingMatrix $ do 69 GL.preservingMatrix $ do
69 GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0) 70 GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0)
@@ -76,7 +77,7 @@ renderGO go = do
76process = mapM_ procEvent 77process = mapM_ procEvent
77 78
78procEvent (Resize w h) = 79procEvent (Resize w h) =
79 let r = (fromIntegral w) / (fromIntegral h) 80 let r = fromIntegral w / fromIntegral h
80 pad = if r > 1 then (r-1) / 2 else (1/r - 1) / 2 81 pad = if r > 1 then (r-1) / 2 else (1/r - 1) / 2
81 left = if r > 1 then -pad else 0 82 left = if r > 1 then -pad else 0
82 right = if r > 1 then 1 + pad else 1 83 right = if r > 1 then 1 + pad else 1
@@ -90,13 +91,12 @@ procEvent (Resize w h) =
90 GL.matrixMode $= GL.Modelview 0 91 GL.matrixMode $= GL.Modelview 0
91procEvent _ = return () 92procEvent _ = return ()
92 93
93translate = mapMaybe translate' 94translateEvents = mapMaybe translateEvents'
94 95 where translateEvents' (KeyDown KEY_LEFT) = Just MoveLeft
95translate' (KeyDown KEY_LEFT) = Just MoveLeft 96 translateEvents' (KeyDown KEY_RIGHT) = Just MoveRight
96translate' (KeyDown KEY_RIGHT) = Just MoveRight 97 translateEvents' (KeyUp KEY_LEFT) = Just StopLeft
97translate' (KeyUp KEY_LEFT) = Just StopLeft 98 translateEvents' (KeyUp KEY_RIGHT) = Just StopRight
98translate' (KeyUp KEY_RIGHT) = Just StopRight 99 translateEvents' _ = Nothing
99translate' _ = Nothing
100 100
101exitRequested = elem (KeyDown KEY_ESC) 101exitRequested = elem (KeyDown KEY_ESC)
102 102
diff --git a/Demos/Pong/Pong.hs b/Demos/Pong/Pong.hs
index 0e24a42..104a92e 100644
--- a/Demos/Pong/Pong.hs
+++ b/Demos/Pong/Pong.hs
@@ -1,3 +1,7 @@
1{-# LANGUAGE MultiParamTypeClasses #-}
2{-# LANGUAGE NoImplicitPrelude #-}
3{-# LANGUAGE TypeSynonymInstances #-}
4
1module Pong 5module Pong
2 ( GameEvent (..), 6 ( GameEvent (..),
3 GameObject, 7 GameObject,
@@ -7,25 +11,29 @@ module Pong
7 ) 11 )
8where 12where
9 13
10import Data.Monoid (mconcat)
11import GHC.Float (double2Float)
12import Spear.Math.AABB 14import Spear.Math.AABB
15import Spear.Math.Algebra
16import Spear.Math.Spatial
13import Spear.Math.Spatial2 17import Spear.Math.Spatial2
14import Spear.Math.Vector 18import Spear.Math.Vector
19import Spear.Prelude
15import Spear.Step 20import Spear.Step
16 21
22import Data.Monoid (mconcat)
23
24
17-- Configuration 25-- Configuration
18 26
19padSize = vec2 0.07 0.02 27padSize = vec2 0.07 0.02
20ballSize = 0.012 28ballSize = 0.012 :: Float
21ballSpeed = 0.6 29ballSpeed = 0.6 :: Float
22initialBallVelocity = vec2 1 1 30initialBallVelocity = vec2 1 1
23maxBounceAngle = 65 * pi/180 31maxBounceAngle = (65::Float) * (pi::Float)/(180::Float)
24playerSpeed = 1.0 32playerSpeed = 1.0 :: Float
25enemySpeed = 1.5 33enemySpeed = 3.0 :: Float
26initialEnemyPos = vec2 0.5 0.9 34initialEnemyPos = vec2 0.5 0.9
27initialPlayerPos = vec2 0.5 0.1 35initialPlayerPos = vec2 0.5 0.1
28initialBallPos = vec2 0.5 0.5 36initialBallPos = vec2 0.5 0.5
29 37
30-- Game events 38-- Game events
31 39
@@ -40,13 +48,36 @@ data GameEvent
40 48
41data GameObject = GameObject 49data GameObject = GameObject
42 { aabb :: AABB2, 50 { aabb :: AABB2,
43 obj :: Obj2, 51 basis :: Transform2,
44 gostep :: Step [GameObject] [GameEvent] GameObject GameObject 52 gostep :: Step [GameObject] [GameEvent] GameObject GameObject
45 } 53 }
46 54
47instance Spatial2 GameObject where 55
48 getObj2 = obj 56instance Has2dTransform GameObject where
49 setObj2 s o = s {obj = o} 57 set2dTransform transform object = object { basis = transform }
58 transform2 = basis
59
60
61instance Positional GameObject Vector2 where
62 setPosition p = with2dTransform (setPosition p)
63 position = position . basis
64 translate v = with2dTransform (translate v)
65
66
67instance Rotational GameObject Vector2 Angle where
68 setRotation r = with2dTransform (setRotation r)
69 rotation = rotation . basis
70 rotate angle = with2dTransform (rotate angle)
71 right = right . basis
72 up = up . basis
73 forward = forward . basis
74 setForward v = with2dTransform (setForward v)
75
76
77instance Spatial GameObject Vector2 Angle Transform2 where
78 setTransform t obj = obj { basis = t }
79 transform = basis
80
50 81
51stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] 82stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
52stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos 83stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos
@@ -60,13 +91,12 @@ ballBox, padBox :: AABB2
60ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize 91ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize
61padBox = AABB2 (-padSize) padSize 92padBox = AABB2 (-padSize) padSize
62 93
63obj2 = obj2FromVectors unitx2 unity2
64
65newWorld = 94newWorld =
66 [ GameObject ballBox (obj2 initialBallPos) $ stepBall initialBallVelocity, 95 [ GameObject ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity,
67 GameObject padBox (obj2 initialEnemyPos) stepEnemy, 96 GameObject padBox (makeAt initialEnemyPos) stepEnemy,
68 GameObject padBox (obj2 initialPlayerPos) stepPlayer 97 GameObject padBox (makeAt initialPlayerPos) stepPlayer
69 ] 98 ]
99 where makeAt = newTransform2 unitx2 unity2
70 100
71-- Ball steppers 101-- Ball steppers
72 102
@@ -76,7 +106,7 @@ stepBall vel = collideBall vel .> moveBall
76-- ball when collision is detected. 106-- ball when collision is detected.
77collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) 107collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject)
78collideBall vel = step $ \_ dt gos _ ball -> 108collideBall vel = step $ \_ dt gos _ ball ->
79 let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball 109 let (AABB2 pmin pmax) = translate (position ball) (aabb ball)
80 collideSide = x pmin < 0 || x pmax > 1 110 collideSide = x pmin < 0 || x pmax > 1
81 collideBack = y pmin < 0 || y pmax > 1 111 collideBack = y pmin < 0 || y pmax > 1
82 collidePaddle = any (collide ball) (tail gos) 112 collidePaddle = any (collide ball) (tail gos)
@@ -84,18 +114,18 @@ collideBall vel = step $ \_ dt gos _ ball ->
84 flipY v@(Vector2 x y) = if collideBack then vec2 x (-y) else v 114 flipY v@(Vector2 x y) = if collideBack then vec2 x (-y) else v
85 vel' = normalise . (\v -> foldl (paddleBounce ball) v (tail gos)) . flipX . flipY $ vel 115 vel' = normalise . (\v -> foldl (paddleBounce ball) v (tail gos)) . flipX . flipY $ vel
86 -- A small delta to apply when collision occurs. 116 -- A small delta to apply when collision occurs.
87 delta = 1 + if collideSide || collideBack || collidePaddle then 2*dt else 0 117 delta = (1::Float) + if collideSide || collideBack || collidePaddle then (2::Float)*dt else (0::Float)
88 in ((scale ballSpeed (scale delta vel'), ball), collideBall vel') 118 in ((ballSpeed * delta * vel', ball), collideBall vel')
89 119
90paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2 120paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2
91paddleBounce ball v paddle = 121paddleBounce ball v paddle =
92 if collide ball paddle 122 if collide ball paddle
93 then 123 then
94 let (AABB2 pmin pmax) = aabb paddle `aabbAdd` pos paddle 124 let (AABB2 pmin pmax) = translate (position paddle) (aabb paddle)
95 center = (x pmin + x pmax) / 2 125 center = (x pmin + x pmax) / (2::Float)
96 -- Normalized offset of the ball from the paddle's center, [-1, +1]. 126 -- Normalized offset of the ball from the paddle's center, [-1, +1].
97 -- It's outside the [-1, +1] range if there is no collision. 127 -- It's outside the [-1, +1] range if there is no collision.
98 offset = (x (pos ball) - center) / ((x pmax - x pmin) / 2) 128 offset = (x (position ball) - center) / ((x pmax - x pmin) / (2::Float))
99 angle = offset * maxBounceAngle 129 angle = offset * maxBounceAngle
100 -- When it bounces off of a paddle, y vel is flipped. 130 -- When it bounces off of a paddle, y vel is flipped.
101 ysign = -(signum (y v)) 131 ysign = -(signum (y v))
@@ -105,19 +135,17 @@ paddleBounce ball v paddle =
105collide :: GameObject -> GameObject -> Bool 135collide :: GameObject -> GameObject -> Bool
106collide go1 go2 = 136collide go1 go2 =
107 let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) = 137 let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) =
108 aabb go1 `aabbAdd` pos go1 138 translate (position go1) (aabb go1)
109 (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) = 139 (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) =
110 aabb go2 `aabbAdd` pos go2 140 translate (position go2) (aabb go2)
111 in not $ 141 in not $
112 xmax1 < xmin2 142 xmax1 < xmin2
113 || xmin1 > xmax2 143 || xmin1 > xmax2
114 || ymax1 < ymin2 144 || ymax1 < ymin2
115 || ymin1 > ymax2 145 || ymin1 > ymax2
116 146
117aabbAdd (AABB2 pmin pmax) p = AABB2 (p + pmin) (p + pmax)
118
119moveBall :: Step s e (Vector2, GameObject) GameObject 147moveBall :: Step s e (Vector2, GameObject) GameObject
120moveBall = step $ \_ dt _ _ (vel, ball) -> (move (scale dt vel) ball, moveBall) 148moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall)
121 149
122-- Enemy stepper 150-- Enemy stepper
123 151
@@ -125,12 +153,13 @@ stepEnemy = movePad
125 153
126movePad :: Step s e GameObject GameObject 154movePad :: Step s e GameObject GameObject
127movePad = step $ \elapsed _ _ _ pad -> 155movePad = step $ \elapsed _ _ _ pad ->
128 let p = vec2 px 0.9 156 let enemyY = 0.9
157 p = vec2 px enemyY
129 px = 158 px =
130 double2Float (sin (elapsed * enemySpeed) * 0.5 + 0.5) 159 (sin (enemySpeed * elapsed) * (0.5::Float) + (0.5::Float))
131 * (1 - 2 * x padSize) 160 * ((1::Float) - (2::Float) * x padSize)
132 + x padSize 161 + x padSize
133 in (setPos p pad, movePad) 162 in (setPosition p pad, movePad)
134 163
135-- Player stepper 164-- Player stepper
136 165
@@ -138,20 +167,20 @@ stepPlayer = sfold moveGO .> clamp
138 167
139moveGO = 168moveGO =
140 mconcat 169 mconcat
141 [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-playerSpeed) 0), 170 [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-playerSpeed) 0),
142 switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0) 171 switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0)
143 ] 172 ]
144 173
145moveGO' :: Vector2 -> Step s e GameObject GameObject 174moveGO' :: Vector2 -> Step s e GameObject GameObject
146moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir) 175moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir)
147 176
148clamp :: Step s e GameObject GameObject 177clamp :: Step s e GameObject GameObject
149clamp = spure $ \go -> 178clamp = spure $ \go ->
150 let p' = vec2 (clamp' x s (1 - s)) y 179 let p' = vec2 (clamp' x s (1 - s)) y
151 (Vector2 x y) = pos go 180 (Vector2 x y) = position go
152 clamp' x a b 181 clamp' x a b
153 | x < a = a 182 | x < a = a
154 | x > b = b 183 | x > b = b
155 | otherwise = x 184 | otherwise = x
156 (Vector2 s _) = padSize 185 (Vector2 s _) = padSize
157 in setPos p' go 186 in setPosition p' go