From b043ff7707fe7883b5abd73f3dad3723dec05f0d Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 2 Jan 2021 22:46:46 +0100 Subject: [PATCH] switch to deltatime-based collision detection to prevent tunneling --- src/Classes/Physics/Collidible.hs | 56 ++++++++++++++++++++----------- src/Scenes/Test.hs | 4 +-- 2 files changed, 38 insertions(+), 22 deletions(-) diff --git a/src/Classes/Physics/Collidible.hs b/src/Classes/Physics/Collidible.hs index 3e54a9d..eb8f1da 100644 --- a/src/Classes/Physics/Collidible.hs +++ b/src/Classes/Physics/Collidible.hs @@ -21,27 +21,43 @@ class (Show c, Mass c) => Collidible c where collisionCheck :: (Collidible other) - => c -- ^ First object - -> other -- ^ second object - -> Bool -- ^ Do the objects collide? - collisionCheck m1 m2 = - let (V2 m1x1 m1y1) = position m1 + fst (boundary m1) - (V2 m1x2 m1y2) = position m1 + snd (boundary m1) - (V2 m2x1 m2y1) = position m2 + fst (boundary m2) - (V2 m2x2 m2y2) = position m2 + snd (boundary m2) + => Double -- Time step length + -> c -- ^ First object + -> other -- ^ second object + -> Bool -- ^ Do the objects collide? + collisionCheck dt m1 m2 = + let (V2 m1x1 m1y1) = position m1 + fst (boundary m1) + delta1 + (V2 m1x2 m1y2) = position m1 + snd (boundary m1) + delta1 + (V2 m2x1 m2y1) = position m2 + fst (boundary m2) + delta2 + (V2 m2x2 m2y2) = position m2 + snd (boundary m2) + delta2 + delta1@(V2 vx1 vy1) = (dt *) <$> velocity m1 + delta2@(V2 vx2 vy2) = (dt *) <$> velocity m2 + dtx 0 = dt + dtx vx = + if vx1 > 0 + then (m2x1 - m1x2) / vx + else (m1x1 - m2x2) / (-vx) + dty 0 = dt + dty vy = + if vy1 > 0 + then (m2y1 - m1y2) / vy + else (m1y1 - m2y2) / (-vy) + posColl = + or + [ m1x1 < m2x2 && m1x1 > m2x1 + , m1x2 < m2x2 && m1x2 > m2x1 + , m2x1 < m1x2 && m2x1 > m1x1 + , m2x2 < m1x2 && m2x2 > m1x1 + ] && or + [ m1y1 < m2y2 && m1y1 > m2y1 + , m1y2 < m2y2 && m1y2 > m2y1 + , m2y1 < m1y2 && m2y1 > m1y1 + , m2y2 < m1y2 && m2y2 > m1y1 + ] in - or - [ m1x1 < m2x2 && m1x1 > m2x1 - , m1x2 < m2x2 && m1x2 > m2x1 - , m2x1 < m1x2 && m2x1 > m1x1 - , m2x2 < m1x2 && m2x2 > m1x1 - ] && or - [ m1y1 < m2y2 && m1y1 > m2y1 - , m1y2 < m2y2 && m1y2 > m2y1 - , m2y1 < m1y2 && m2y1 > m1y1 - , m2y2 < m1y2 && m2y2 > m1y1 - ] - + (if vx1 == 0 then posColl else dt > dtx vx1) + && + (if vy1 == 0 then posColl else dt > dty vy1) -- | This Function is called for every collision on both colliding objects. collide diff --git a/src/Scenes/Test.hs b/src/Scenes/Test.hs index 6e44781..477ff64 100644 --- a/src/Scenes/Test.hs +++ b/src/Scenes/Test.hs @@ -153,7 +153,7 @@ instance Scene Test where collidedCast = (\(Cast c1) (Cast c2) -> Cast $ - if collisionCheck c1 c2 + if collisionCheck dt c1 c2 then collide c1 c2 else c1 ) @@ -161,7 +161,7 @@ instance Scene Test where wallCast (Cast c) = Cast $ V.foldl (\member tile -> - if collisionCheck member tile + if collisionCheck dt member tile then collide member tile else member )