From 0a2e3f05d4129a6b91059381a278213091df9d4c Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 25 Jul 2021 15:51:42 +0200 Subject: [PATCH] halfway interactable objects --- src/Physics/Classes/Collidible.hs | 65 +++++++++++++++++++++++++------ src/Scenes/Test/Update.hs | 9 +++-- src/Types/Player.hs | 6 ++- 3 files changed, 63 insertions(+), 17 deletions(-) diff --git a/src/Physics/Classes/Collidible.hs b/src/Physics/Classes/Collidible.hs index 2288db2..93517bb 100644 --- a/src/Physics/Classes/Collidible.hs +++ b/src/Physics/Classes/Collidible.hs @@ -8,16 +8,21 @@ import Linear import Data.String (fromString) +import Data.List (sortBy) + -- internal imports import Physics.Classes.Mass data CollisionResult time direction = NoCollision - | Collision + | CollisionImminent { collisionTime :: time , collisionDirection :: direction } + | OverlapCollision + { collisionDepth :: direction + } deriving (Show, Eq) -- | Typeclass for implementing collision results on objects. @@ -47,13 +52,13 @@ class (Show c, Mass c) => Collidible c where (m2b1@(V2 m2b1x m2b1y), m2b2@(V2 m2b2x m2b2y)) = boundary m2 (V2 pm1b1x pm1b1y, V2 pm1b2x pm1b2y) = (p1 +) <$> boundary m1 (V2 pm2b1x pm2b1y, V2 pm2b2x pm2b2y) = (p2 +) <$> boundary m2 - m1p1 = p1 + m1b1 + m1p1@(V2 m1p1x m1p1y) = p1 + m1b1 m1p2 = p1 + V2 m1b1x m1b2y - m1p3 = p1 + m1b2 + m1p3@(V2 m1p3x m1p3y) = p1 + m1b2 m1p4@(V2 m1p4x _) = p1 + V2 m1b2x m1b1y - m2p1@(V2 m2p1x _) = p2 + m2b1 + m2p1@(V2 m2p1x m2p1y) = p2 + m2b1 m2p2 = p2 + V2 m2b1x m2b2y - m2p3 = p2 + m2b2 + m2p3@(V2 m2p3x m2p3y) = p2 + m2b2 m2p4 = p2 + V2 m2b2x m2b1y (V2 b1minx b1miny, V2 b1maxx b1maxy) = ( V2 @@ -154,13 +159,13 @@ class (Show c, Mass c) => Collidible c where any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22] res = case (tx < dt, ty < dt, tx < ty, coll True, coll False) of (True, _, True, True, _) -> - Collision tx (V2 (floor $ signum d1x) 0) + CollisionImminent tx (V2 (floor $ signum d1x) 0) (_, True, False, _, True) -> - Collision ty (V2 0 (floor $ signum d1y)) + CollisionImminent ty (V2 0 (floor $ signum d1y)) (True, _, False, True, False) -> - Collision tx (V2 (floor $ signum d1x) 0) + CollisionImminent tx (V2 (floor $ signum d1x) 0) (_, True, True, False, True) -> - Collision ty (V2 0 (floor $ signum d1y)) + CollisionImminent ty (V2 0 (floor $ signum d1y)) (_, _, _, False, False) -> NoCollision (_, _, True, _, _) -> @@ -172,12 +177,37 @@ class (Show c, Mass c) => Collidible c where <> fromString (show x) in case res of - Collision _ _ -> + CollisionImminent _ _ -> res NoCollision -> if overlap - then Collision 0 (V2 0 0) + then + let xoverlap = floor (minimum + [ pm2b2x - pm2b1x + , pm2b1x - pm1b2x + ]) + yoverlap = floor (minimum + [ pm2b1y - pm1b2y + , pm2b2y - pm1b1y + ]) + in + if xoverlap < yoverlap + then + if xoverlap < 0 + then OverlapCollision + (V2 xoverlap 0) + else + NoCollision + else + if yoverlap < 0 + then OverlapCollision + (V2 yoverlap 0) + else NoCollision else NoCollision + _ -> A.log + A.Error + "Premature overlap collision detection" + NoCollision else NoCollision @@ -200,7 +230,7 @@ elasticCollision -> Double -- ^ Timestep length -> c1 elasticCollision _ mo1 (_, NoCollision) _ = mo1 -elasticCollision damping mo1 (mo2, Collision ddt (V2 dirx diry)) dt = +elasticCollision damping mo1 (mo2, CollisionImminent ddt (V2 dirx diry)) dt = let v1@(V2 v1x v1y) = velocity mo1 (V2 v2x v2y) = velocity mo2 p1 = position mo1 @@ -221,3 +251,14 @@ elasticCollision damping mo1 (mo2, Collision ddt (V2 dirx diry)) dt = velocityUpdater mo1 nvel +elasticCollision damping mo1 (mo2, OverlapCollision depth) dt = + let m1 = mass mo1 + m2 = mass mo2 + (V2 dx dy) = (/ dt) . fromIntegral <$> depth + v1x' = 2 * (m1 * dx + m2 * (-dx)) / (m1 + m2) - dx + v1y' = 2 * (m1 * dy + m2 * (-dy)) / (m1 + m2) - dy + nvel = if m1 == recip 0 + then V2 0 0 + else (damping *) <$> V2 v1x' v1y' + in + velocityUpdater mo1 nvel diff --git a/src/Scenes/Test/Update.hs b/src/Scenes/Test/Update.hs index efdb2a6..67f71d9 100644 --- a/src/Scenes/Test/Update.hs +++ b/src/Scenes/Test/Update.hs @@ -57,9 +57,12 @@ update level dt = liftIO $ do (\jacc (qInd, tangible2) -> let res = collisionCheck dt tangible1 tangible2 in - if res /= NoCollision && qInd /= index - then jacc `V.snoc` (qInd, res) - else jacc + case res of + c@(CollisionImminent _ _) -> + if qInd /= index + then jacc `V.snoc` (qInd, c) + else jacc + _ -> jacc ) V.empty indexedTangibles diff --git a/src/Types/Player.hs b/src/Types/Player.hs index 739c8e5..2fb0b07 100644 --- a/src/Types/Player.hs +++ b/src/Types/Player.hs @@ -196,10 +196,12 @@ instance Collidible Pituicat where } collide cat collrs@((_, NoCollision):_) _ = cat { pcXColl = any - (\(_, Collision _ (V2 cx _)) -> cx /= 0) + (\(_, CollisionImminent _ (V2 cx _)) -> cx /= 0) (filter ((NoCollision /= ) . snd) collrs) } - collide cat collrs@(collr@((other, Collision ddt (V2 dirx diry))):_) dt = + collide cat collrs@(collr@(_, OverlapCollision direction):_) dt = + elasticCollision 0.3 cat collr dt + collide cat collrs@(collr@(other, CollisionImminent ddt (V2 dirx diry)):_) dt = let ncat = elasticCollision 0.3 cat collr dt vel@(V2 vx vy) = velocity ncat moveVel@(V2 mx my) = pcMoveVel cat