switch to deltatime-based collision detection to prevent tunneling

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

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
                   )