aboutsummaryrefslogtreecommitdiff
path: root/Demos/Pong
diff options
context:
space:
mode:
Diffstat (limited to 'Demos/Pong')
-rw-r--r--Demos/Pong/Main.hs26
-rw-r--r--Demos/Pong/Pong.hs85
2 files changed, 55 insertions, 56 deletions
diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs
index 0237a26..21fcb0c 100644
--- a/Demos/Pong/Main.hs
+++ b/Demos/Pong/Main.hs
@@ -14,6 +14,7 @@ import Spear.Render.Core.State
14import Spear.Render.Immediate 14import Spear.Render.Immediate
15import Spear.Window 15import Spear.Window
16 16
17import Control.Monad (when)
17import Data.Maybe (mapMaybe) 18import Data.Maybe (mapMaybe)
18 19
19 20
@@ -28,7 +29,7 @@ data GameState = GameState
28app = App step render resize 29app = App step render resize
29 30
30main = 31main =
31 withWindow (900, 600) (Just "Pong") initGame endGame $ 32 withWindow (1920, 1200) (Just "Pong") initGame endGame $
32 loop app 33 loop app
33 34
34initGame :: Window -> Game () GameState 35initGame :: Window -> Game () GameState
@@ -44,13 +45,22 @@ endGame = do
44step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool 45step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
45step elapsed dt inputEvents = do 46step elapsed dt inputEvents = do
46 gs <- getGameState 47 gs <- getGameState
47 let events = translateEvents inputEvents 48 events <- processInput (window gs)
49 --when (events /= []) $ gameIO . putStrLn $ show events
48 modifyGameState $ \gs -> 50 modifyGameState $ \gs ->
49 gs 51 gs
50 { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gs) 52 { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gs)
51 } 53 }
52 return (not $ exitRequested inputEvents) 54 return (not $ exitRequested inputEvents)
53 55
56processInput :: Window -> Game GameState [GameEvent]
57processInput window = processKeys window
58 [ (KEY_A, MoveLeft)
59 , (KEY_D, MoveRight)
60 ]
61
62exitRequested = elem (KeyDown KEY_ESC)
63
54render :: Game GameState () 64render :: Game GameState ()
55render = do 65render = do
56 gameState <- getGameState 66 gameState <- getGameState
@@ -79,7 +89,7 @@ renderBackground =
79 let pmin = 0 :: Float 89 let pmin = 0 :: Float
80 pmax = 1 :: Float 90 pmax = 1 :: Float
81 in do 91 in do
82 immSetColour (vec4 0.6 0.35 0.6 1.0) 92 immSetColour (vec4 0.0 0.25 0.41 1.0)
83 immDrawQuads2d [ 93 immDrawQuads2d [
84 (vec2 pmin pmin 94 (vec2 pmin pmin
85 ,vec2 pmax pmin 95 ,vec2 pmax pmin
@@ -98,7 +108,6 @@ renderGO go = do
98 ,vec2 xmax ymax 108 ,vec2 xmax ymax
99 ,vec2 xmin ymax)] 109 ,vec2 xmin ymax)]
100 110
101-- TODO: Fix the resize hang.
102resize :: WindowEvent -> Game GameState () 111resize :: WindowEvent -> Game GameState ()
103resize (ResizeEvent w h) = 112resize (ResizeEvent w h) =
104 let r = fromIntegral w / fromIntegral h 113 let r = fromIntegral w / fromIntegral h
@@ -112,12 +121,3 @@ resize (ResizeEvent w h) =
112 modifyGameState $ \state -> state { 121 modifyGameState $ \state -> state {
113 viewProjection = Matrix4.ortho left right bottom top (-1) 1 122 viewProjection = Matrix4.ortho left right bottom top (-1) 1
114 } 123 }
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..dd8855b 100644
--- a/Demos/Pong/Pong.hs
+++ b/Demos/Pong/Pong.hs
@@ -24,13 +24,14 @@ import Data.Monoid (mconcat)
24 24
25-- Configuration 25-- Configuration
26 26
27padSize = vec2 0.07 0.02 27padSize = vec2 0.07 0.015
28ballSize = 0.012 :: Float 28ballSize = 0.012 :: Float
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 = 0.1 :: 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,9 +41,7 @@ initialBallPos = vec2 0.5 0.5
40data GameEvent 41data GameEvent
41 = MoveLeft 42 = MoveLeft
42 | MoveRight 43 | MoveRight
43 | StopLeft 44 deriving (Eq, Ord, Show)
44 | StopRight
45 deriving (Eq, Ord)
46 45
47-- Game objects 46-- Game objects
48 47
@@ -79,17 +78,9 @@ instance Spatial GameObject Vector2 Angle Transform2 where
79 transform = basis 78 transform = basis
80 79
81 80
82stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
83stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos
84
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
90ballBox, padBox :: AABB2 81ballBox, padBox :: AABB2
91ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize 82ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize
92padBox = AABB2 (-padSize) padSize 83padBox = AABB2 (-padSize) padSize
93 84
94newWorld = 85newWorld =
95 [ GameObject ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity, 86 [ GameObject ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity,
@@ -98,23 +89,30 @@ newWorld =
98 ] 89 ]
99 where makeAt = newTransform2 unitx2 unity2 90 where makeAt = newTransform2 unitx2 unity2
100 91
92
93stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
94stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos
95
96update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
97update elapsed dt evts gos go =
98 let (go', s') = runStep (gostep go) elapsed dt gos evts go
99 in go' {gostep = s'}
100
101-- Ball steppers 101-- Ball steppers
102 102
103stepBall vel = collideBall vel .> moveBall 103stepBall vel = collideBall vel .> moveBall
104 104
105-- TODO: in collideBall and paddleBounce, we should an apply an offset to the
106-- ball when collision is detected.
107collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) 105collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject)
108collideBall vel = step $ \_ dt gos _ ball -> 106collideBall vel = step $ \_ dt gos _ ball ->
109 let (AABB2 pmin pmax) = translate (position ball) (aabb ball) 107 let (AABB2 pmin pmax) = translate (position ball) (aabb ball)
110 collideSide = x pmin < 0 || x pmax > 1 108 sideCollision = x pmin < 0 || x pmax > 1
111 collideBack = y pmin < 0 || y pmax > 1 109 backCollision = y pmin < 0 || y pmax > 1
112 collidePaddle = any (collide ball) (tail gos) 110 flipX v@(Vector2 x y) = if sideCollision then vec2 (-x) y else v
113 flipX v@(Vector2 x y) = if collideSide then vec2 (-x) y else v 111 flipY v@(Vector2 x y) = if backCollision then vec2 x (-y) else v
114 flipY v@(Vector2 x y) = if collideBack then vec2 x (-y) else v
115 vel' = normalise . (\v -> foldl (paddleBounce ball) v (tail gos)) . flipX . flipY $ vel 112 vel' = normalise . (\v -> foldl (paddleBounce ball) v (tail gos)) . flipX . flipY $ vel
116 -- A small delta to apply when collision occurs. 113 collision = vel' /= vel
117 delta = (1::Float) + if collideSide || collideBack || collidePaddle then (2::Float)*dt else (0::Float) 114 -- Apply offset when collision occurs to avoid sticky collisions.
115 delta = (1::Float) + if collision then (3::Float)*dt else (0::Float)
118 in ((ballSpeed * delta * vel', ball), collideBall vel') 116 in ((ballSpeed * delta * vel', ball), collideBall vel')
119 117
120paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2 118paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2
@@ -139,37 +137,38 @@ collide go1 go2 =
139 (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) = 137 (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) =
140 translate (position go2) (aabb go2) 138 translate (position go2) (aabb go2)
141 in not $ 139 in not $
142 xmax1 < xmin2 140 xmax1 < xmin2 ||
143 || xmin1 > xmax2 141 xmin1 > xmax2 ||
144 || ymax1 < ymin2 142 ymax1 < ymin2 ||
145 || ymin1 > ymax2 143 ymin1 > ymax2
146 144
147moveBall :: Step s e (Vector2, GameObject) GameObject 145moveBall :: Step s e (Vector2, GameObject) GameObject
148moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall) 146moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall)
149 147
150-- Enemy stepper 148-- Enemy stepper
151 149
152stepEnemy = movePad 150stepEnemy = movePad 0 .> clamp
153 151
154movePad :: Step s e GameObject GameObject 152movePad :: Float -> Step [GameObject] e GameObject GameObject
155movePad = step $ \elapsed _ _ _ pad -> 153movePad previousMomentum = step $ \_ dt gos _ pad ->
156 let enemyY = 0.9 154 let ball = head gos
157 p = vec2 px enemyY 155 offset = (x . position $ ball) - (x . position $ pad)
158 px = 156 chaseVector = enemySpeed * offset
159 (sin (enemySpeed * elapsed) * (0.5::Float) + (0.5::Float)) 157 momentum = previousMomentum + enemyMomentum * chaseVector
160 * ((1::Float) - (2::Float) * x padSize) 158 vx = chaseVector + momentum
161 + x padSize 159 in (translate (vec2 (vx * dt) 0) pad, movePad momentum)
162 in (setPosition p pad, movePad) 160
161sign :: Float -> Float
162sign x = if x >= 0 then 1 else -1
163 163
164-- Player stepper 164-- Player stepper
165 165
166stepPlayer = sfold moveGO .> clamp 166stepPlayer = sfold moveGO .> clamp
167 167
168moveGO = 168moveGO = mconcat
169 mconcat 169 [ swhen MoveLeft $ moveGO' (vec2 (-playerSpeed) 0)
170 [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-playerSpeed) 0), 170 , swhen MoveRight $ moveGO' (vec2 playerSpeed 0)
171 switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0) 171 ]
172 ]
173 172
174moveGO' :: Vector2 -> Step s e GameObject GameObject 173moveGO' :: Vector2 -> Step s e GameObject GameObject
175moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir) 174moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir)