halfway interactable objects

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

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
+                                case res of
-                                then jacc `V.snoc` (qInd, res)
+                                  c@(CollisionImminent _ _) ->
-                                else jacc
+                                    if qInd /= index
+                                    then jacc `V.snoc` (qInd, c)
+                                    else jacc
+                                  _ -> jacc
                               )
                             V.empty
                             indexedTangibles

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