diff options
Diffstat (limited to 'demos/pong/Pong.hs')
| -rw-r--r-- | demos/pong/Pong.hs | 125 |
1 files changed, 64 insertions, 61 deletions
diff --git a/demos/pong/Pong.hs b/demos/pong/Pong.hs index 1761823..232c69a 100644 --- a/demos/pong/Pong.hs +++ b/demos/pong/Pong.hs | |||
| @@ -1,66 +1,64 @@ | |||
| 1 | module Pong | 1 | module Pong |
| 2 | ( | 2 | ( GameEvent (..), |
| 3 | GameEvent(..) | 3 | GameObject, |
| 4 | , GameObject | 4 | newWorld, |
| 5 | , newWorld | 5 | stepWorld, |
| 6 | , stepWorld | 6 | aabb, |
| 7 | , aabb | 7 | ) |
| 8 | ) | ||
| 9 | where | 8 | where |
| 10 | 9 | ||
| 10 | import Data.Monoid (mconcat) | ||
| 11 | import GHC.Float (double2Float) | ||
| 11 | import Spear.Math.AABB | 12 | import Spear.Math.AABB |
| 12 | import Spear.Math.Spatial2 | 13 | import Spear.Math.Spatial2 |
| 13 | import Spear.Math.Vector | 14 | import Spear.Math.Vector |
| 14 | import Spear.Step | 15 | import Spear.Step |
| 15 | 16 | ||
| 16 | import Data.Monoid (mconcat) | ||
| 17 | import GHC.Float (double2Float) | ||
| 18 | |||
| 19 | -- Game events | 17 | -- Game events |
| 20 | 18 | ||
| 21 | data GameEvent | 19 | data GameEvent |
| 22 | = MoveLeft | 20 | = MoveLeft |
| 23 | | MoveRight | 21 | | MoveRight |
| 24 | | StopLeft | 22 | | StopLeft |
| 25 | | StopRight | 23 | | StopRight |
| 26 | deriving (Eq, Ord) | 24 | deriving (Eq, Ord) |
| 27 | 25 | ||
| 28 | -- Game objects | 26 | -- Game objects |
| 29 | 27 | ||
| 30 | data GameObject = GameObject | 28 | data GameObject = GameObject |
| 31 | { aabb :: AABB2 | 29 | { aabb :: AABB2, |
| 32 | , obj :: Obj2 | 30 | obj :: Obj2, |
| 33 | , gostep :: Step [GameObject] [GameEvent] GameObject GameObject | 31 | gostep :: Step [GameObject] [GameEvent] GameObject GameObject |
| 34 | } | 32 | } |
| 35 | 33 | ||
| 36 | instance Spatial2 GameObject where | 34 | instance Spatial2 GameObject where |
| 37 | getObj2 = obj | 35 | getObj2 = obj |
| 38 | setObj2 s o = s { obj = o } | 36 | setObj2 s o = s {obj = o} |
| 39 | 37 | ||
| 40 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] | 38 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] |
| 41 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos | 39 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos |
| 42 | 40 | ||
| 43 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject | 41 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject |
| 44 | update elapsed dt evts gos go = | 42 | update elapsed dt evts gos go = |
| 45 | let (go', s') = runStep (gostep go) elapsed dt gos evts go | 43 | let (go', s') = runStep (gostep go) elapsed dt gos evts go |
| 46 | in go' { gostep = s' } | 44 | in go' {gostep = s'} |
| 47 | 45 | ||
| 48 | ballBox :: AABB2 | 46 | ballBox :: AABB2 |
| 49 | ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = 0.01 | 47 | ballBox = AABB2 (vec2 (- s) (- s)) (vec2 s s) where s = 0.01 |
| 50 | 48 | ||
| 51 | padSize = vec2 0.05 0.02 | 49 | padSize = vec2 0.05 0.02 |
| 52 | 50 | ||
| 53 | padBox = AABB2 (-padSize) padSize | 51 | padBox = AABB2 (- padSize) padSize |
| 54 | 52 | ||
| 55 | obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y) | 53 | obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y) |
| 56 | 54 | ||
| 57 | ballVelocity = Vector2 0.3 0.3 | 55 | ballVelocity = Vector2 0.3 0.3 |
| 58 | 56 | ||
| 59 | newWorld = | 57 | newWorld = |
| 60 | [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity | 58 | [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity, |
| 61 | , GameObject padBox (obj2 0.5 0.9) stepEnemy | 59 | GameObject padBox (obj2 0.5 0.9) stepEnemy, |
| 62 | , GameObject padBox (obj2 0.5 0.1) stepPlayer | 60 | GameObject padBox (obj2 0.5 0.1) stepPlayer |
| 63 | ] | 61 | ] |
| 64 | 62 | ||
| 65 | -- Ball steppers | 63 | -- Ball steppers |
| 66 | 64 | ||
| @@ -68,27 +66,30 @@ stepBall vel = collideBall vel .> moveBall | |||
| 68 | 66 | ||
| 69 | collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) | 67 | collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) |
| 70 | collideBall vel = step $ \_ _ gos _ ball -> | 68 | collideBall vel = step $ \_ _ gos _ ball -> |
| 71 | let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball | 69 | let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball |
| 72 | collideCol = x pmin < 0 || x pmax > 1 | 70 | collideCol = x pmin < 0 || x pmax > 1 |
| 73 | collideRow = y pmin < 0 || y pmax > 1 | 71 | collideRow = |
| 74 | || any (collide ball) (tail gos) | 72 | y pmin < 0 || y pmax > 1 |
| 75 | negx v@(Vector2 x y) = if collideCol then vec2 (-x) y else v | 73 | || any (collide ball) (tail gos) |
| 76 | negy v@(Vector2 x y) = if collideRow then vec2 x (-y) else v | 74 | negx v@(Vector2 x y) = if collideCol then vec2 (- x) y else v |
| 77 | vel' = negx . negy $ vel | 75 | negy v@(Vector2 x y) = if collideRow then vec2 x (- y) else v |
| 78 | in ((vel', ball), collideBall vel') | 76 | vel' = negx . negy $ vel |
| 77 | in ((vel', ball), collideBall vel') | ||
| 79 | 78 | ||
| 80 | collide go1 go2 = | 79 | collide go1 go2 = |
| 81 | let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) | 80 | let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) = |
| 82 | = aabb go1 `aabbAdd` pos go1 | 81 | aabb go1 `aabbAdd` pos go1 |
| 83 | (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) | 82 | (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) = |
| 84 | = aabb go2 `aabbAdd` pos go2 | 83 | aabb go2 `aabbAdd` pos go2 |
| 85 | in not $ xmax1 < xmin2 || xmin1 > xmax2 | 84 | in not $ |
| 86 | || ymax1 < ymin2 || ymin1 > ymax2 | 85 | xmax1 < xmin2 || xmin1 > xmax2 |
| 86 | || ymax1 < ymin2 | ||
| 87 | || ymin1 > ymax2 | ||
| 87 | 88 | ||
| 88 | aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax) | 89 | aabbAdd (AABB2 pmin pmax) p = AABB2 (p + pmin) (p + pmax) |
| 89 | 90 | ||
| 90 | moveBall :: Step s e (Vector2, GameObject) GameObject | 91 | moveBall :: Step s e (Vector2, GameObject) GameObject |
| 91 | moveBall = step $ \_ dt _ _ (vel,ball) -> (move (scale dt vel) ball, moveBall) | 92 | moveBall = step $ \_ dt _ _ (vel, ball) -> (move (scale dt vel) ball, moveBall) |
| 92 | 93 | ||
| 93 | -- Enemy stepper | 94 | -- Enemy stepper |
| 94 | 95 | ||
| @@ -96,32 +97,34 @@ stepEnemy = movePad | |||
| 96 | 97 | ||
| 97 | movePad :: Step s e GameObject GameObject | 98 | movePad :: Step s e GameObject GameObject |
| 98 | movePad = step $ \elapsed _ _ _ pad -> | 99 | movePad = step $ \elapsed _ _ _ pad -> |
| 99 | let p = vec2 px 0.9 | 100 | let p = vec2 px 0.9 |
| 100 | px = double2Float (sin elapsed * 0.5 + 0.5) | 101 | px = |
| 101 | * (1 - 2 * x padSize) | 102 | double2Float (sin elapsed * 0.5 + 0.5) |
| 102 | + x padSize | 103 | * (1 - 2 * x padSize) |
| 103 | in (setPos p pad, movePad) | 104 | + x padSize |
| 105 | in (setPos p pad, movePad) | ||
| 104 | 106 | ||
| 105 | -- Player stepper | 107 | -- Player stepper |
| 106 | 108 | ||
| 107 | stepPlayer = sfold moveGO .> clamp | 109 | stepPlayer = sfold moveGO .> clamp |
| 108 | 110 | ||
| 109 | moveGO = mconcat | 111 | moveGO = |
| 110 | [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-1) 0) | 112 | mconcat |
| 111 | , switch StopRight sid MoveRight (moveGO' $ vec2 1 0) | 113 | [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-1) 0), |
| 112 | ] | 114 | switch StopRight sid MoveRight (moveGO' $ vec2 1 0) |
| 115 | ] | ||
| 113 | 116 | ||
| 114 | moveGO' :: Vector2 -> Step s e GameObject GameObject | 117 | moveGO' :: Vector2 -> Step s e GameObject GameObject |
| 115 | moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir) | 118 | moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir) |
| 116 | 119 | ||
| 117 | clamp :: Step s e GameObject GameObject | 120 | clamp :: Step s e GameObject GameObject |
| 118 | clamp = spure $ \go -> | 121 | clamp = spure $ \go -> |
| 119 | let p' = vec2 (clamp' x s (1 - s)) y | 122 | let p' = vec2 (clamp' x s (1 - s)) y |
| 120 | (Vector2 x y) = pos go | 123 | (Vector2 x y) = pos go |
| 121 | clamp' x a b = if x < a then a else if x > b then b else x | 124 | clamp' x a b = if x < a then a else if x > b then b else x |
| 122 | (Vector2 s _) = padSize | 125 | (Vector2 s _) = padSize |
| 123 | in setPos p' go | 126 | in setPos p' go |
| 124 | 127 | ||
| 125 | toDir True MoveLeft = vec2 (-1) 0 | 128 | toDir True MoveLeft = vec2 (-1) 0 |
| 126 | toDir True MoveRight = vec2 1 0 | 129 | toDir True MoveRight = vec2 1 0 |
| 127 | toDir _ _ = vec2 0 0 \ No newline at end of file | 130 | toDir _ _ = vec2 0 0 |
