aboutsummaryrefslogtreecommitdiff
path: root/Demos
diff options
context:
space:
mode:
Diffstat (limited to 'Demos')
-rw-r--r--Demos/Balls/Main.hs176
-rw-r--r--Demos/Pong/Main.hs104
-rw-r--r--Demos/Pong/Pong.hs186
3 files changed, 332 insertions, 134 deletions
diff --git a/Demos/Balls/Main.hs b/Demos/Balls/Main.hs
new file mode 100644
index 0000000..d266d85
--- /dev/null
+++ b/Demos/Balls/Main.hs
@@ -0,0 +1,176 @@
1{-# LANGUAGE MultiParamTypeClasses #-}
2--{-# LANGUAGE NoImplicitPrelude #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE TypeSynonymInstances #-}
5
6module Main where
7
8import Spear.App
9import Spear.Game
10import Spear.Math.AABB
11import qualified Spear.Math.Matrix3 as Matrix3
12import qualified Spear.Math.Matrix4 as Matrix4
13import Spear.Math.Spatial
14import Spear.Math.Spatial2
15import Spear.Math.Vector
16import Spear.Physics.Collision
17--import Spear.Prelude
18import Spear.Render.Core.Pipeline
19import Spear.Render.Core.State
20import Spear.Render.Immediate
21import Spear.Sound.Sound
22import Spear.Sound.State
23import Spear.Window
24
25import Control.Monad (when)
26
27
28ballSize = 0.01
29numBalls = 1000
30
31data Ball = Ball
32 { ballPosition :: {-# UNPACK #-} !Vector2
33 , ballVelocity :: {-# UNPACK #-} !Vector2
34 }
35
36instance Positional Ball Vector2 where
37 setPosition p ball = ball { ballPosition = p }
38 position = ballPosition
39 translate v ball = ball { ballPosition = v + ballPosition ball }
40
41instance Bounded2 Ball where
42 boundingVolume ball = aabb2Volume $ translate (ballPosition ball) (AABB2 (-size) size)
43 where size = vec2 s s
44 s = ballSize / (2::Float)
45
46data World = World
47 { viewProjection :: Matrix4.Matrix4
48 , balls :: [Ball]
49 }
50
51type GameState = AppState World
52
53
54options = defaultAppOptions { title = "Balls" }
55
56app = App options initGame endGame step render resize
57
58
59main :: IO ()
60main = runApp app
61
62initGame :: Game AppContext World
63initGame =
64 let
65 world = zipWith Ball positions velocities
66 positions = (+vec2 0.5 0.5) . makePosition <$> numbers
67 makePosition i = radius * vec2 (sin (f*i)) (cos (f*i))
68 velocities = makeVelocity <$> numbers
69 makeVelocity i = scale speed $ vec2 (sin (f*i)) (cos (f*i))
70 numbers = [1..numBalls]
71 f = 2*pi / numBalls
72 radius = 0.05
73 speed = 0.4
74 in
75 return $ World Matrix4.id world
76
77endGame :: Game GameState ()
78endGame = return ()
79
80
81step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
82step elapsed dt inputEvents = do
83 modifyGameState $ \world -> world
84 { balls = moveBalls dt $ balls world
85 }
86 return (not $ exitRequested inputEvents)
87
88exitRequested = elem (KeyDown KEY_ESC)
89
90moveBalls :: Elapsed -> [Ball] -> [Ball]
91moveBalls dt = (bounceBall dt . moveBall dt <$>)
92
93moveBall :: Elapsed -> Ball -> Ball
94moveBall dt ball = translate (scale (realToFrac dt) $ ballVelocity ball) ball
95
96bounceBall :: Elapsed -> Ball -> Ball
97bounceBall dt ball =
98 let
99 (AABB2Volume (AABB2 pmin pmax)) = boundingVolume ball
100 sideCollision = x pmin < 0 || x pmax > 1
101 backCollision = y pmin < 0 || y pmax > 1
102 flipX v@(Vector2 x y) = if sideCollision then vec2 (-x) y else v
103 flipY v@(Vector2 x y) = if backCollision then vec2 x (-y) else v
104 velocity = ballVelocity ball
105 velocity'
106 = flipX
107 . flipY
108 $ velocity
109 collision = velocity' /= velocity
110 -- Apply offset when collision occurs to avoid sticky collisions.
111 delta = if collision then 1 else 0
112 dt' = realToFrac dt
113 in
114 ball
115 { ballPosition = ballPosition ball + scale (delta * dt') velocity'
116 , ballVelocity = velocity'
117 }
118
119
120render :: Game GameState ()
121render = do
122 gameState <- getGameState
123 siblingGame $ do
124 immStart
125 immSetViewProjectionMatrix (viewProjection gameState)
126 -- Clear the background to a different colour than the playable area to make
127 -- the latter distinguishable.
128 setClearColour (0.2, 0.2, 0.2, 0.0)
129 clearBuffers [ColourBuffer]
130 render' $ balls gameState
131 immEnd
132
133render' :: [Ball] -> Game ImmRenderState ()
134render' balls = do
135 immLoadIdentity
136 renderBackground
137 -- Draw objects.
138 immSetColour (vec4 1.0 1.0 1.0 1.0)
139 mapM_ renderBall balls
140
141renderBackground :: Game ImmRenderState ()
142renderBackground =
143 let pmin = 0 :: Float
144 pmax = 1 :: Float
145 in do
146 immSetColour (vec4 0.0 0.25 0.41 1.0)
147 immDrawQuads2d [
148 (vec2 pmin pmin
149 ,vec2 pmax pmin
150 ,vec2 pmax pmax
151 ,vec2 pmin pmax)]
152
153renderBall :: Ball -> Game ImmRenderState ()
154renderBall ball =
155 let (AABB2Volume (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax))) = boundingVolume ball
156 in
157 immDrawQuads2d [
158 (vec2 xmin ymin
159 ,vec2 xmax ymin
160 ,vec2 xmax ymax
161 ,vec2 xmin ymax)]
162
163
164resize :: WindowEvent -> Game GameState ()
165resize (ResizeEvent w h) =
166 let r = fromIntegral w / fromIntegral h
167 pad = if r > 1 then (r-1) / 2 else (1/r - 1) / 2
168 left = if r > 1 then -pad else 0
169 right = if r > 1 then 1 + pad else 1
170 bottom = if r > 1 then 0 else -pad
171 top = if r > 1 then 1 else 1 + pad
172 in do
173 setViewport 0 0 w h
174 modifyGameState $ \pong -> pong {
175 viewProjection = Matrix4.ortho left right bottom top (-1) 1
176 }
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