From a99a70eb9db989189a265297ebc9f5a1d5efb467 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 17 Jan 2021 02:30:45 +0100 Subject: [PATCH] make better collision reaction --- src/Classes/Physics/Collidible.hs | 120 +++++++++++++++++++++++------- src/Classes/Physics/Mass.hs | 8 +- src/Scenes/Test/Load.hs | 1 + src/Scenes/Test/Update.hs | 19 ++--- src/Types/Player.hs | 61 ++++++++++----- 5 files changed, 146 insertions(+), 63 deletions(-) diff --git a/src/Classes/Physics/Collidible.hs b/src/Classes/Physics/Collidible.hs index f32ebf9..faf8225 100644 --- a/src/Classes/Physics/Collidible.hs +++ b/src/Classes/Physics/Collidible.hs @@ -7,6 +7,11 @@ import Linear import Classes.Physics.Mass +data CollisionResult a + = NoCollision + | Collision a + deriving (Show, Eq) + -- | Typeclass for implementing collision results on objects. class (Show c, Mass c) => Collidible c where @@ -24,7 +29,7 @@ class (Show c, Mass c) => Collidible c where => Double -- ^ Time step length -> c -- ^ First object -> other -- ^ second object - -> Bool -- ^ Do the objects collide? + -> CollisionResult Double -- ^ Do the objects collide? collisionCheck dt m1 m2 = let d1@(V2 d1x d1y) = (dt *) <$> velocity m1 d2@(V2 d2x d2y) = (dt *) <$> velocity m2 @@ -56,33 +61,48 @@ class (Show c, Mass c) => Collidible c where (d1x * (mtpy - mqpy) - (mtpx - mqpx) * d1y) / (d1x * (-(mtpy - mspy)) - (-(mtpx - mspx)) * d1y) inside m = - let am = m - (p2 + m2p1) - ab = (p2 + m2p2) - (p2 + m2p1) - ad = (p2 + m2p4) - (p2 + m2p1) + let dm = m - (p2 + m2p4) + dc = (p2 + m2p3) - (p2 + m2p4) + da = (p2 + m2p1) - (p2 + m2p4) in - (0 < am `dot` ab && am `dot` ab < ab `dot` ab) && - (0 < am `dot` ad && am `dot` ad < ad `dot` ad) + (0 < dm `dot` dc && dm `dot` dc < dc `dot` dc) && + (0 < dm `dot` da && dm `dot` da < da `dot` da) in - any inside quad1 || - any - (\gx -> - any - (\q -> - let qs = s q gx - qt = t q gx - in - (qs > 0 && qs < 1) && (qt > 0 && qt < dt) - ) - quad1 - ) - gs + if any inside quad1 + then Collision 0 + else + let res = foldl + (\acc1 gx -> + let gt = foldl + (\acc2 q -> + let qt = t q gx + qs = s q gx + in + if (qs > 0 && qs < 1) && (qt > 0 && qt < acc2) + then qt + else acc2 + ) + acc1 + quad1 + in + if gt < acc1 + then gt + else acc1 + ) + dt + gs + in + if res < dt + then Collision res + else NoCollision -- | This Function is called for every collision on both colliding objects. collide :: (Collidible other) - => c -- ^ Original object - -> other -- ^ Collision partner - -> c -- ^ Updated original object + => c -- ^ Original object + -> other -- ^ Collision partner + -> CollisionResult Double -- ^ Collision reaction + -> c -- ^ Updated original object collide = elasticCollision 1 -- | Implementation of a dampened elastic collision used as default collision @@ -92,9 +112,11 @@ elasticCollision => Double -> c1 -> c2 + -> CollisionResult Double -> c1 -elasticCollision damping mo1 mo2 = - let (V2 v1x v1y) = velocity mo1 +elasticCollision _ mo1 _ NoCollision = mo1 +elasticCollision damping mo1 mo2 (Collision ddt) = + let v1@(V2 v1x v1y) = velocity mo1 (V2 v2x v2y) = velocity mo2 p1@(V2 p1x p1y) = position mo1 p2 = position mo2 @@ -114,5 +136,53 @@ elasticCollision damping mo1 mo2 = then (V2 (-v1x) v1y) else (V2 v1x (-v1y)) else (V2 v1x' v1y') + bx = if dx <= 0 + then + if abs dx >= abs m1x1 + abs m2x2 && + (if dy > 0 + then abs dy >= abs m1y2 + abs m2y1 + else abs dy >= abs m1y1 + abs m2y2 + ) + then 0 + else (abs m1x1 + abs m2x2) - abs dx + 1 + else + if abs dx >= abs m1x2 + abs m2x1 && + (if dy > 0 + then abs dy >= abs m1y2 + abs m2y1 + else abs dy >= abs m1y1 + abs m2y2 + ) + then 0 + else -((abs m1x2 + abs m2x1) - abs dx + 1) + by = if dy <= 0 + then + if abs dy >= abs m1y1 + abs m2y2 && + (if dx > 0 + then abs dx >= abs m1x2 + abs m2x1 + else abs dx >= abs m1x1 + abs m2x2 + ) + then 0 + else (abs m1y1 + abs m2y2) - abs dy + 1 + else + if abs dy >= abs m1y2 + abs m2y1 && + (if dx > 0 + then abs dx >= abs m1x2 + abs m2x1 + else abs dx >= abs m1x1 + abs m2x2 + ) + then 0 + else -((abs m1y2 + abs m2y1) - abs dy + 1) in - (velocityUpdater mo1) nvel + (velocityUpdater + ((positionUpdater mo1) + (p1 + + if ddt == 0 + then + if abs by > abs bx + then + V2 bx 0 + else + V2 0 by + else + V2 0 0 + ) + ) + ) nvel diff --git a/src/Classes/Physics/Mass.hs b/src/Classes/Physics/Mass.hs index 830b912..e76d5aa 100644 --- a/src/Classes/Physics/Mass.hs +++ b/src/Classes/Physics/Mass.hs @@ -57,8 +57,8 @@ class Mass m where -> m -- ^ Original mass object -> m -- ^ Updated mass object move dt m = - let dpos = ((dt *) <$> velocity m) + let dpos@(V2 dx dy) = (dt *) <$> velocity m in - if quadrance dpos > 0.5 - then (positionUpdater m) (position m + dpos) - else m + if dy < 0 && abs dy < 1 + then (positionUpdater m) (position m + (V2 dx 0)) + else (positionUpdater m) (position m + dpos) diff --git a/src/Scenes/Test/Load.hs b/src/Scenes/Test/Load.hs index b26a284..3d6d01d 100644 --- a/src/Scenes/Test/Load.hs +++ b/src/Scenes/Test/Load.hs @@ -87,6 +87,7 @@ load level progress = do (V2 0 1) (V2 0 0) (V2 0 0) + (V2 0 0) 100 tex False diff --git a/src/Scenes/Test/Update.hs b/src/Scenes/Test/Update.hs index e600c01..9596580 100644 --- a/src/Scenes/Test/Update.hs +++ b/src/Scenes/Test/Update.hs @@ -35,18 +35,13 @@ update level dt = liftIO $ do cast collidedCast = (\(Cast c1) (Cast c2) -> - Cast $ - if collisionCheck dt c1 c2 - then collide c1 c2 - else c1 + Cast $ collide c1 c2 (collisionCheck dt c1 c2) ) <$> playedCast <*> playedCast wallCast (Cast c) = Cast $ V.foldl (\member tile -> - if collisionCheck dt member tile - then collide member tile - else member + collide member tile (collisionCheck dt member tile) ) c layer @@ -65,19 +60,15 @@ update level dt = liftIO $ do collidedCat = V.foldl (\cat (Cast c) -> - if collisionCheck dt cat c - then collide cat c - else cat + collide cat c (collisionCheck dt cat c) ) playedCat updatedCast walledCat = V.foldl (\cat tile -> - if collisionCheck dt cat tile - then collide cat tile - else cat + collide cat tile (collisionCheck dt cat tile) ) collidedCat layer - in Just $ walledCat + in Just $ move dt walledCat diff --git a/src/Types/Player.hs b/src/Types/Player.hs index 0666e95..a4da283 100644 --- a/src/Types/Player.hs +++ b/src/Types/Player.hs @@ -24,12 +24,13 @@ import Types.Texture import Types.Subsystems catMoveVelocity :: Double -catMoveVelocity = 10 +catMoveVelocity = 100 data Pituicat = Pituicat { pcPos :: V2 Double , pcVel :: V2 Double , pcMoveVel :: V2 Double + , pcTMoveVel :: V2 Double , pcAcc :: V2 Double , pcHealth :: Int , pcTexture :: Texture @@ -40,7 +41,7 @@ data Pituicat = Pituicat instance Drawable Pituicat where - toVertices (Pituicat (V2 x y) _ _ _ _ _ _ _) = + toVertices (Pituicat (V2 x y) _ _ _ _ _ _ _ _) = ( V.fromList [0, 1, 2, 2, 3, 0] , V.fromList [ newVertex @@ -75,20 +76,25 @@ instance Prop Pituicat where instance Actor Pituicat where perform dt p = - let physCat = (move dt . accelerate dt . gravitate constG) - (p {pcAcc = 0}) - (V2 vx vy) = pcVel physCat + let physCat = (accelerate dt . gravitate constG) + (p + { pcAcc = 0 + , pcTMoveVel = + case pcMoveState physCat of + Just MoveRight -> V2 catMoveVelocity 0 + Just MoveLeft -> V2 (-catMoveVelocity) 0 + _ -> V2 0 0 + } + ) finalCat = physCat - { pcGrounded = (vy <= 0 && abs vy < 30 ) - , pcMoveVel = case pcMoveState physCat of - Just MoveRight -> V2 catMoveVelocity 0 - Just MoveLeft -> V2 (-catMoveVelocity) 0 - _ -> V2 0 0 + { pcMoveVel = + -- lerp (min 0.9 (59 * dt)) (pcMoveVel physCat) (pcTMoveVel physCat) + pcTMoveVel physCat } in (A.log Debug ( - ("being at " <> fromString (show $ pcPos finalCat)) <> - ("; moving with " <> fromString (show $ pcVel finalCat)) + ("being at " <> fromString (show $ position finalCat)) <> + ("; moving with " <> fromString (show $ velocity finalCat)) ) ) finalCat @@ -107,9 +113,20 @@ instance Mass Pituicat where velocity cat = pcVel cat + pcMoveVel cat velocityUpdater cat = - (\vel -> cat - { pcVel = vel - } + (\vel@(V2 vx vy) -> + let (V2 mx my) = pcMoveVel cat + nx = + if abs mx > abs vx + then 0 + else vx - mx + ny = + if abs my > abs vy + then 0 + else vy - my + in + cat + { pcVel = (V2 nx ny) + } ) position = pcPos @@ -127,13 +144,17 @@ instance Collidible Pituicat where , V2 25 25 ) - collide cat other = + collide cat _ NoCollision = cat + collide cat other collr@(Collision ddt) = A.log Debug ("*boing* meow! other: " <> fromString (show other)) - (let ncat = (elasticCollision 0.3 cat other) - (V2 _ dy) = pcVel ncat - in - ncat + ( + let ncat = (elasticCollision 0.3 cat other collr) + (V2 dx dy) = (ddt *) <$> velocity ncat + in + ncat + { pcGrounded = abs dy < 2 + } )