From 92e7a93d8c1475bdc802d10a1722bcf8a295449d Mon Sep 17 00:00:00 2001 From: 3gg <3gg@shellblade.net> Date: Tue, 24 Dec 2024 12:07:05 -0800 Subject: New physics module. --- Demos/Pong/Pong.hs | 101 ++++++++++++++++++++++++++++++++--------------------- 1 file changed, 61 insertions(+), 40 deletions(-) (limited to 'Demos') diff --git a/Demos/Pong/Pong.hs b/Demos/Pong/Pong.hs index b9661ee..b12f792 100644 --- a/Demos/Pong/Pong.hs +++ b/Demos/Pong/Pong.hs @@ -16,10 +16,11 @@ import Spear.Math.Algebra import Spear.Math.Spatial import Spear.Math.Spatial2 import Spear.Math.Vector +import Spear.Physics.Collision import Spear.Prelude import Spear.Step -import Data.Monoid (mconcat) +import Data.Monoid (mconcat) -- Configuration @@ -41,14 +42,22 @@ initialBallPos = vec2 0.5 0.5 data GameEvent = MoveLeft | MoveRight - deriving (Eq, Ord, Show) + | Collision GameObjectId GameObjectId + deriving (Eq, Show) -- Game objects +data GameObjectId + = Ball + | Enemy + | Player + deriving (Eq, Show) + data GameObject = GameObject - { aabb :: AABB2, - basis :: Transform2, - gostep :: Step [GameObject] [GameEvent] GameObject GameObject + { gameObjectId :: !GameObjectId + , aabb :: {-# UNPACK #-} !AABB2 + , basis :: {-# UNPACK #-} !Transform2 + , gostep :: Step [GameObject] [GameEvent] GameObject GameObject } @@ -78,46 +87,68 @@ instance Spatial GameObject Vector2 Angle Transform2 where transform = basis +instance Bounded2 GameObject where + boundingVolume obj = aabb2Volume $ translate (position obj) (aabb obj) + + ballBox, padBox :: AABB2 ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize padBox = AABB2 (-padSize) padSize newWorld = - [ GameObject ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity, - GameObject padBox (makeAt initialEnemyPos) stepEnemy, - GameObject padBox (makeAt initialPlayerPos) stepPlayer + [ GameObject Ball ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity, + GameObject Enemy padBox (makeAt initialEnemyPos) stepEnemy, + GameObject Player padBox (makeAt initialPlayerPos) stepPlayer ] where makeAt = newTransform2 unitx2 unity2 +-- Step the game world: +-- 1. Simulate physics. +-- 2. Collide objects and clip -> produce collision events. +-- 3. Update game objects <- input collision events. stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] -stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos +stepWorld elapsed dt events gos@[ball, enemy, player] = + let + collisions = collide [ball] [enemy, player] + collisionEvents = (\(x,y) -> Collision (gameObjectId x) (gameObjectId y)) <$> collisions + events' = events ++ collisionEvents + gos' = map (update elapsed dt events' gos) gos + in + gos' update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject -update elapsed dt evts gos go = - let (go', s') = runStep (gostep go) elapsed dt gos evts go - in go' {gostep = s'} +update elapsed dt events gos go = + let (go', s') = runStep (gostep go) elapsed dt gos events go + in go' { gostep = s' } + -- Ball steppers -stepBall vel = collideBall vel .> moveBall +stepBall vel = bounceBall vel .> moveBall -collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) -collideBall vel = step $ \_ dt gos _ ball -> +bounceBall :: Vector2 -> Step [GameObject] [GameEvent] GameObject (Vector2, GameObject) +bounceBall vel = step $ \_ dt gos events ball -> let (AABB2 pmin pmax) = translate (position ball) (aabb ball) sideCollision = x pmin < 0 || x pmax > 1 backCollision = y pmin < 0 || y pmax > 1 flipX v@(Vector2 x y) = if sideCollision then vec2 (-x) y else v flipY v@(Vector2 x y) = if backCollision then vec2 x (-y) else v - vel' = normalise . (\v -> foldl (paddleBounce ball) v (tail gos)) . flipX . flipY $ vel + collideWithPaddles vel = foldl (paddleBounce ball events) vel (tail gos) + vel' = normalise + . collideWithPaddles + . flipX + . flipY + $ vel collision = vel' /= vel -- Apply offset when collision occurs to avoid sticky collisions. delta = (1::Float) + if collision then (3::Float)*dt else (0::Float) - in ((ballSpeed * delta * vel', ball), collideBall vel') + in ((ballSpeed * delta * vel', ball), bounceBall vel') -paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2 -paddleBounce ball v paddle = - if collide ball paddle +paddleBounce :: GameObject -> [GameEvent] -> Vector2 -> GameObject -> Vector2 +paddleBounce ball events vel paddle = + let collision = Collision Ball (gameObjectId paddle) `elem` events + in if collision then let (AABB2 pmin pmax) = translate (position paddle) (aabb paddle) center = (x pmin + x pmax) / (2::Float) @@ -126,25 +157,14 @@ paddleBounce ball v paddle = offset = (x (position ball) - center) / ((x pmax - x pmin) / (2::Float)) angle = offset * maxBounceAngle -- When it bounces off of a paddle, y vel is flipped. - ysign = -(signum (y v)) + ysign = -(signum (y vel)) in vec2 (sin angle) (ysign * cos angle) - else v - -collide :: GameObject -> GameObject -> Bool -collide go1 go2 = - let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) = - translate (position go1) (aabb go1) - (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) = - translate (position go2) (aabb go2) - in not $ - xmax1 < xmin2 || - xmin1 > xmax2 || - ymax1 < ymin2 || - ymin1 > ymax2 + else vel moveBall :: Step s e (Vector2, GameObject) GameObject moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall) + -- Enemy stepper stepEnemy = movePad 0 .> clamp @@ -161,17 +181,18 @@ movePad previousMomentumVector = step $ \_ dt gos _ pad -> sign :: Float -> Float sign x = if x >= 0 then 1 else -1 + -- Player stepper -stepPlayer = sfold moveGO .> clamp +stepPlayer = sfold movePlayer .> clamp -moveGO = mconcat - [ swhen MoveLeft $ moveGO' (vec2 (-playerSpeed) 0) - , swhen MoveRight $ moveGO' (vec2 playerSpeed 0) +movePlayer = mconcat + [ swhen MoveLeft $ movePlayer' (vec2 (-playerSpeed) 0) + , swhen MoveRight $ movePlayer' (vec2 playerSpeed 0) ] -moveGO' :: Vector2 -> Step s e GameObject GameObject -moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir) +movePlayer' :: Vector2 -> Step s e GameObject GameObject +movePlayer' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, movePlayer' dir) clamp :: Step s e GameObject GameObject clamp = spure $ \go -> -- cgit v1.2.3