aboutsummaryrefslogtreecommitdiff
path: root/Demos/Pong
diff options
context:
space:
mode:
Diffstat (limited to 'Demos/Pong')
-rw-r--r--Demos/Pong/Main.hs104
-rw-r--r--Demos/Pong/Pong.hs186
2 files changed, 156 insertions, 134 deletions
diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs
index 0237a26..22b1021 100644
--- a/Demos/Pong/Main.hs
+++ b/Demos/Pong/Main.hs
@@ -1,3 +1,5 @@
1{-# LANGUAGE MultiParamTypeClasses #-}
2
1module Main where 3module Main where
2 4
3import Pong 5import Pong
@@ -5,66 +7,85 @@ import Pong
5import Spear.App 7import Spear.App
6import Spear.Game 8import Spear.Game
7import Spear.Math.AABB 9import Spear.Math.AABB
8import Spear.Math.Matrix4 as Matrix4 hiding (position) 10import Spear.Math.Matrix4 as Matrix4
9import Spear.Math.Spatial 11import Spear.Math.Spatial
10import Spear.Math.Spatial2 12import Spear.Math.Spatial2
11import Spear.Math.Vector 13import Spear.Math.Vector
14import Spear.Physics.Collision
12import Spear.Render.Core.Pipeline 15import Spear.Render.Core.Pipeline
13import Spear.Render.Core.State 16import Spear.Render.Core.State
14import Spear.Render.Immediate 17import Spear.Render.Immediate
18import Spear.Sound.Sound
19import Spear.Sound.State
15import Spear.Window 20import Spear.Window
16 21
17import Data.Maybe (mapMaybe) 22import Control.Monad (when)
18 23
19 24
20data GameState = GameState 25data Pong = Pong
21 { window :: Window 26 { viewProjection :: Matrix4
22 , renderCoreState :: RenderCoreState 27 , backgroundMusic :: SoundSource
23 , immRenderState :: ImmRenderState
24 , viewProjection :: Matrix4
25 , world :: [GameObject] 28 , world :: [GameObject]
26 } 29 }
27 30
28app = App step render resize 31type GameState = AppState Pong
32
33
34options = defaultAppOptions { title = "Pong" }
35
36app = App options initGame endGame step render resize
29 37
30main =
31 withWindow (900, 600) (Just "Pong") initGame endGame $
32 loop app
33 38
34initGame :: Window -> Game () GameState 39main :: IO ()
35initGame window = do 40main = runApp app
36 (immRenderState, renderCoreState) <- runSiblingGame newImmRenderer newRenderCoreState 41
37 return $ GameState window renderCoreState immRenderState Matrix4.id newWorld 42initGame :: Game AppContext Pong
43initGame = do
44 music <- siblingGame $ do
45 musicBuffer <- loadAudioFile "/home/jeanne/Casual Tiki Party Main.wav"
46 music <- makeSoundSource
47 setSoundSourceBuffer music musicBuffer
48 setSoundLoopMode music Loop
49 playSounds [music]
50 return music
51 return $ Pong Matrix4.id music newWorld
38 52
39endGame :: Game GameState () 53endGame :: Game GameState ()
40endGame = do 54endGame = return ()
41 game <- getGameState 55
42 runSubGame' (deleteImmRenderer $ immRenderState game) (renderCoreState game)
43 56
44step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool 57step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
45step elapsed dt inputEvents = do 58step elapsed dt inputEvents = do
46 gs <- getGameState 59 appState <- get
47 let events = translateEvents inputEvents 60 gameState <- getGameState
48 modifyGameState $ \gs -> 61 events <- processInput (appWindow appState)
49 gs 62 --when (events /= []) $ liftIO . putStrLn $ show events
50 { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gs) 63 modifyGameState $ \pong -> pong
51 } 64 { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gameState)
65 }
52 return (not $ exitRequested inputEvents) 66 return (not $ exitRequested inputEvents)
53 67
68processInput :: Window -> Game GameState [GameEvent]
69processInput window = processKeys window
70 [ (KEY_A, MoveLeft)
71 , (KEY_D, MoveRight)
72 ]
73
74exitRequested = elem (KeyDown KEY_ESC)
75
76
54render :: Game GameState () 77render :: Game GameState ()
55render = do 78render = do
56 gameState <- getGameState 79 gameState <- getGameState
57 immRenderState' <- flip execSubGame (immRenderState gameState) $ do 80 siblingGame $ do
58 immStart 81 immStart
59 immSetViewProjectionMatrix (viewProjection gameState) 82 immSetViewProjectionMatrix (viewProjection gameState)
60 -- Clear the background to a different colour than the playable area to make 83 -- Clear the background to a different colour than the playable area to make
61 -- the latter distinguishable. 84 -- the latter distinguishable.
62 gameIO $ do 85 setClearColour (0.2, 0.2, 0.2, 0.0)
63 setClearColour (0.2, 0.2, 0.2, 0.0) 86 clearBuffers [ColourBuffer]
64 clearBuffers [ColourBuffer]
65 render' $ world gameState 87 render' $ world gameState
66 immEnd 88 immEnd
67 saveGameState $ gameState { immRenderState = immRenderState' }
68 89
69render' :: [GameObject] -> Game ImmRenderState () 90render' :: [GameObject] -> Game ImmRenderState ()
70render' world = do 91render' world = do
@@ -79,7 +100,7 @@ renderBackground =
79 let pmin = 0 :: Float 100 let pmin = 0 :: Float
80 pmax = 1 :: Float 101 pmax = 1 :: Float
81 in do 102 in do
82 immSetColour (vec4 0.6 0.35 0.6 1.0) 103 immSetColour (vec4 0.0 0.25 0.41 1.0)
83 immDrawQuads2d [ 104 immDrawQuads2d [
84 (vec2 pmin pmin 105 (vec2 pmin pmin
85 ,vec2 pmax pmin 106 ,vec2 pmax pmin
@@ -87,18 +108,16 @@ renderBackground =
87 ,vec2 pmin pmax)] 108 ,vec2 pmin pmax)]
88 109
89renderGO :: GameObject -> Game ImmRenderState () 110renderGO :: GameObject -> Game ImmRenderState ()
90renderGO go = do 111renderGO go =
91 let (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax)) = aabb go 112 let (AABB2Volume (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax))) = boundingVolume go
92 (Vector2 xcenter ycenter) = position go 113 in
93 immPreservingMatrix $ do
94 immTranslate (vec3 xcenter ycenter 0)
95 immDrawQuads2d [ 114 immDrawQuads2d [
96 (vec2 xmin ymin 115 (vec2 xmin ymin
97 ,vec2 xmax ymin 116 ,vec2 xmax ymin
98 ,vec2 xmax ymax 117 ,vec2 xmax ymax
99 ,vec2 xmin ymax)] 118 ,vec2 xmin ymax)]
100 119
101-- TODO: Fix the resize hang. 120
102resize :: WindowEvent -> Game GameState () 121resize :: WindowEvent -> Game GameState ()
103resize (ResizeEvent w h) = 122resize (ResizeEvent w h) =
104 let r = fromIntegral w / fromIntegral h 123 let r = fromIntegral w / fromIntegral h
@@ -108,16 +127,7 @@ resize (ResizeEvent w h) =
108 bottom = if r > 1 then 0 else -pad 127 bottom = if r > 1 then 0 else -pad
109 top = if r > 1 then 1 else 1 + pad 128 top = if r > 1 then 1 else 1 + pad
110 in do 129 in do
111 gameIO $ setViewport 0 0 w h 130 setViewport 0 0 w h
112 modifyGameState $ \state -> state { 131 modifyGameState $ \pong -> pong {
113 viewProjection = Matrix4.ortho left right bottom top (-1) 1 132 viewProjection = Matrix4.ortho left right bottom top (-1) 1
114 } 133 }
115
116translateEvents = mapMaybe translateEvents'
117 where translateEvents' (KeyDown KEY_LEFT) = Just MoveLeft
118 translateEvents' (KeyDown KEY_RIGHT) = Just MoveRight
119 translateEvents' (KeyUp KEY_LEFT) = Just StopLeft
120 translateEvents' (KeyUp KEY_RIGHT) = Just StopRight
121 translateEvents' _ = Nothing
122
123exitRequested = elem (KeyDown KEY_ESC)
diff --git a/Demos/Pong/Pong.hs b/Demos/Pong/Pong.hs
index 104a92e..0df05ea 100644
--- a/Demos/Pong/Pong.hs
+++ b/Demos/Pong/Pong.hs
@@ -3,12 +3,11 @@
3{-# LANGUAGE TypeSynonymInstances #-} 3{-# LANGUAGE TypeSynonymInstances #-}
4 4
5module Pong 5module Pong
6 ( GameEvent (..), 6( GameEvent (..)
7 GameObject, 7, GameObject
8 newWorld, 8, newWorld
9 stepWorld, 9, stepWorld
10 aabb, 10)
11 )
12where 11where
13 12
14import Spear.Math.AABB 13import Spear.Math.AABB
@@ -16,21 +15,23 @@ import Spear.Math.Algebra
16import Spear.Math.Spatial 15import Spear.Math.Spatial
17import Spear.Math.Spatial2 16import Spear.Math.Spatial2
18import Spear.Math.Vector 17import Spear.Math.Vector
18import Spear.Physics.Collision
19import Spear.Prelude 19import Spear.Prelude
20import Spear.Step 20import Spear.Step
21 21
22import Data.Monoid (mconcat) 22import Data.Monoid (mconcat)
23 23
24 24
25-- Configuration 25-- Configuration
26 26
27padSize = vec2 0.07 0.02 27padSize = vec2 0.070 0.015
28ballSize = 0.012 :: Float 28ballSize = vec2 0.012 0.012
29ballSpeed = 0.6 :: Float 29ballSpeed = 0.7 :: Float
30initialBallVelocity = vec2 1 1 30initialBallVelocity = vec2 1 1
31maxBounceAngle = (65::Float) * (pi::Float)/(180::Float) 31maxBounceAngle = (65::Float) * (pi::Float)/(180::Float)
32playerSpeed = 1.0 :: Float 32playerSpeed = 1.0 :: Float
33enemySpeed = 3.0 :: Float 33enemySpeed = 7.0 :: Float
34enemyMomentum = 1.0 :: Float
34initialEnemyPos = vec2 0.5 0.9 35initialEnemyPos = vec2 0.5 0.9
35initialPlayerPos = vec2 0.5 0.1 36initialPlayerPos = vec2 0.5 0.1
36initialBallPos = vec2 0.5 0.5 37initialBallPos = vec2 0.5 0.5
@@ -40,16 +41,22 @@ initialBallPos = vec2 0.5 0.5
40data GameEvent 41data GameEvent
41 = MoveLeft 42 = MoveLeft
42 | MoveRight 43 | MoveRight
43 | StopLeft 44 | Collision GameObjectId GameObjectId
44 | StopRight 45 deriving (Eq, Show)
45 deriving (Eq, Ord)
46 46
47-- Game objects 47-- Game objects
48 48
49data GameObjectId
50 = Ball
51 | Enemy
52 | Player
53 deriving (Eq, Show)
54
49data GameObject = GameObject 55data GameObject = GameObject
50 { aabb :: AABB2, 56 { gameObjectId :: !GameObjectId
51 basis :: Transform2, 57 , gameObjectSize :: {-# UNPACK #-} !Vector2
52 gostep :: Step [GameObject] [GameEvent] GameObject GameObject 58 , basis :: {-# UNPACK #-} !Transform2
59 , gostep :: Step [GameObject] [GameEvent] GameObject GameObject
53 } 60 }
54 61
55 62
@@ -79,108 +86,113 @@ instance Spatial GameObject Vector2 Angle Transform2 where
79 transform = basis 86 transform = basis
80 87
81 88
82stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] 89instance Bounded2 GameObject where
83stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos 90 boundingVolume obj = aabb2Volume $ translate (position obj) (AABB2 (-size) size)
84 91 where size = gameObjectSize obj
85update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
86update elapsed dt evts gos go =
87 let (go', s') = runStep (gostep go) elapsed dt gos evts go
88 in go' {gostep = s'}
89 92
90ballBox, padBox :: AABB2
91ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize
92padBox = AABB2 (-padSize) padSize
93 93
94newWorld = 94newWorld =
95 [ GameObject ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity, 95 [ GameObject Ball ballSize (makeAt initialBallPos) $ stepBall initialBallVelocity,
96 GameObject padBox (makeAt initialEnemyPos) stepEnemy, 96 GameObject Enemy padSize (makeAt initialEnemyPos) stepEnemy,
97 GameObject padBox (makeAt initialPlayerPos) stepPlayer 97 GameObject Player padSize (makeAt initialPlayerPos) stepPlayer
98 ] 98 ]
99 where makeAt = newTransform2 unitx2 unity2 99 where makeAt = newTransform2 unitx2 unity2
100 100
101
102-- Step the game world:
103-- 1. Simulate physics.
104-- 2. Collide objects and clip -> produce collision events.
105-- 3. Update game objects <- input collision events.
106stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
107stepWorld elapsed dt events gos@[ball, enemy, player] =
108 let
109 collisions = collide [ball] [enemy, player]
110 collisionEvents = (\(x,y) -> Collision (gameObjectId x) (gameObjectId y)) <$> collisions
111 events' = events ++ collisionEvents
112 in
113 map (update elapsed dt events' gos) gos
114
115update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
116update elapsed dt events gos go =
117 let (go', s') = runStep (gostep go) elapsed dt gos events go
118 in go' { gostep = s' }
119
120
101-- Ball steppers 121-- Ball steppers
102 122
103stepBall vel = collideBall vel .> moveBall 123stepBall vel = bounceBall vel .> moveBall -- .> clamp
104 124
105-- TODO: in collideBall and paddleBounce, we should an apply an offset to the 125bounceBall :: Vector2 -> Step [GameObject] [GameEvent] GameObject (Vector2, GameObject)
106-- ball when collision is detected. 126bounceBall vel = step $ \_ dt gos events ball ->
107collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) 127 let (AABB2Volume (AABB2 pmin pmax)) = boundingVolume ball
108collideBall vel = step $ \_ dt gos _ ball -> 128 sideCollision = x pmin < 0 || x pmax > 1
109 let (AABB2 pmin pmax) = translate (position ball) (aabb ball) 129 backCollision = y pmin < 0 || y pmax > 1
110 collideSide = x pmin < 0 || x pmax > 1 130 flipX v@(Vector2 x y) = if sideCollision then vec2 (-x) y else v
111 collideBack = y pmin < 0 || y pmax > 1 131 flipY v@(Vector2 x y) = if backCollision then vec2 x (-y) else v
112 collidePaddle = any (collide ball) (tail gos) 132 collideWithPaddles vel = foldl (paddleBounce ball events) vel (tail gos)
113 flipX v@(Vector2 x y) = if collideSide then vec2 (-x) y else v 133 vel' = normalise
114 flipY v@(Vector2 x y) = if collideBack then vec2 x (-y) else v 134 . collideWithPaddles
115 vel' = normalise . (\v -> foldl (paddleBounce ball) v (tail gos)) . flipX . flipY $ vel 135 . flipX
116 -- A small delta to apply when collision occurs. 136 . flipY
117 delta = (1::Float) + if collideSide || collideBack || collidePaddle then (2::Float)*dt else (0::Float) 137 $ vel
118 in ((ballSpeed * delta * vel', ball), collideBall vel') 138 collision = vel' /= vel
119 139 -- Apply offset when collision occurs to avoid sticky collisions.
120paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2 140 delta = (1::Float) + if collision then (3::Float)*dt else (0::Float)
121paddleBounce ball v paddle = 141 in ((ballSpeed * delta * vel', ball), bounceBall vel')
122 if collide ball paddle 142
143paddleBounce :: GameObject -> [GameEvent] -> Vector2 -> GameObject -> Vector2
144paddleBounce ball events vel paddle =
145 let collision = Collision Ball (gameObjectId paddle) `elem` events
146 in if collision
123 then 147 then
124 let (AABB2 pmin pmax) = translate (position paddle) (aabb paddle) 148 let (AABB2Volume (AABB2 pmin pmax)) = boundingVolume paddle
125 center = (x pmin + x pmax) / (2::Float) 149 center = (x pmin + x pmax) / (2::Float)
126 -- Normalized offset of the ball from the paddle's center, [-1, +1]. 150 -- Normalized offset of the ball from the paddle's center, [-1, +1].
127 -- It's outside the [-1, +1] range if there is no collision. 151 -- It's outside the [-1, +1] range if there is no collision.
128 offset = (x (position ball) - center) / ((x pmax - x pmin) / (2::Float)) 152 offset = (x (position ball) - center) / ((x pmax - x pmin) / (2::Float))
129 angle = offset * maxBounceAngle 153 angle = offset * maxBounceAngle
130 -- When it bounces off of a paddle, y vel is flipped. 154 -- When it bounces off of a paddle, y vel is flipped.
131 ysign = -(signum (y v)) 155 ysign = -(signum (y vel))
132 in vec2 (sin angle) (ysign * cos angle) 156 in vec2 (sin angle) (ysign * cos angle)
133 else v 157 else vel
134
135collide :: GameObject -> GameObject -> Bool
136collide go1 go2 =
137 let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) =
138 translate (position go1) (aabb go1)
139 (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) =
140 translate (position go2) (aabb go2)
141 in not $
142 xmax1 < xmin2
143 || xmin1 > xmax2
144 || ymax1 < ymin2
145 || ymin1 > ymax2
146 158
147moveBall :: Step s e (Vector2, GameObject) GameObject 159moveBall :: Step s e (Vector2, GameObject) GameObject
148moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall) 160moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall)
149 161
162
150-- Enemy stepper 163-- Enemy stepper
151 164
152stepEnemy = movePad 165stepEnemy = movePad 0 .> spure clamp
166
167movePad :: Float -> Step [GameObject] e GameObject GameObject
168movePad previousMomentumVector = step $ \_ dt gos _ pad ->
169 let ball = head gos
170 heading = (x . position $ ball) - (x . position $ pad)
171 chaseVector = enemySpeed * heading
172 momentumVector = previousMomentumVector + enemyMomentum * heading * dt
173 vx = chaseVector * dt + momentumVector
174 in (translate (vec2 vx 0) pad, movePad momentumVector)
153 175
154movePad :: Step s e GameObject GameObject
155movePad = step $ \elapsed _ _ _ pad ->
156 let enemyY = 0.9
157 p = vec2 px enemyY
158 px =
159 (sin (enemySpeed * elapsed) * (0.5::Float) + (0.5::Float))
160 * ((1::Float) - (2::Float) * x padSize)
161 + x padSize
162 in (setPosition p pad, movePad)
163 176
164-- Player stepper 177-- Player stepper
165 178
166stepPlayer = sfold moveGO .> clamp 179stepPlayer = sfold movePlayer .> spure clamp
167 180
168moveGO = 181movePlayer = mconcat
169 mconcat 182 [ swhen MoveLeft $ movePlayer' (vec2 (-playerSpeed) 0)
170 [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-playerSpeed) 0), 183 , swhen MoveRight $ movePlayer' (vec2 playerSpeed 0)
171 switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0) 184 ]
172 ]
173 185
174moveGO' :: Vector2 -> Step s e GameObject GameObject 186movePlayer' :: Vector2 -> Step s e GameObject GameObject
175moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir) 187movePlayer' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, movePlayer' dir)
176 188
177clamp :: Step s e GameObject GameObject 189clamp :: GameObject -> GameObject
178clamp = spure $ \go -> 190clamp go =
179 let p' = vec2 (clamp' x s (1 - s)) y 191 let p' = vec2 (clamp' x sx (1 - sx)) y
180 (Vector2 x y) = position go 192 (Vector2 x y) = position go
181 clamp' x a b 193 clamp' x a b
182 | x < a = a 194 | x < a = a
183 | x > b = b 195 | x > b = b
184 | otherwise = x 196 | otherwise = x
185 (Vector2 s _) = padSize 197 (Vector2 sx _) = gameObjectSize go
186 in setPosition p' go 198 in setPosition p' go