diff --git a/src/Physics/Classes/Collidible.hs b/src/Physics/Classes/Collidible.hs index 334ff58..5c37e9b 100644 --- a/src/Physics/Classes/Collidible.hs +++ b/src/Physics/Classes/Collidible.hs @@ -8,7 +8,7 @@ import Linear import Data.String (fromString) -import Data.List (sortBy) +import Data.Bifunctor (bimap) -- internal imports @@ -48,10 +48,11 @@ class (Show c, Mass c) => Collidible c where d2@(V2 d2x d2y) = velocity m2 p1@(V2 p1x p1y) = position m1 p2@(V2 p2x p2y) = position m2 + (V2 dpx dpy) = p2 - p1 (m1b1@(V2 m1b1x m1b1y), m1b2@(V2 m1b2x m1b2y)) = boundary m1 (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 + (V2 pm1b1x pm1b1y, V2 pm1b2x pm1b2y) = bimap (p1 +) (p1 +) (boundary m1) + (V2 pm2b1x pm2b1y, V2 pm2b2x pm2b2y) = bimap (p2 +) (p2 +) (boundary m2) m1p1@(V2 m1p1x m1p1y) = p1 + m1b1 m1p2 = p1 + V2 m1b1x m1b2y m1p3@(V2 m1p3x m1p3y) = p1 + m1b2 @@ -99,23 +100,31 @@ class (Show c, Mass c) => Collidible c where in2 || in1 overlap = let in1 = - (pm1b1x > pm2b1x && pm1b1x < pm2b2x && - pm1b1y > pm2b1y && pm1b1y < pm2b2y) || - (pm1b2x > pm2b1x && pm1b2x < pm2b2x && - pm1b1y > pm2b1y && pm1b1y < pm2b2y) || - (pm1b1x > pm2b1x && pm1b2x < pm2b2x && - pm1b2y > pm2b1y && pm1b2y < pm2b2y) || - (pm1b2x > pm2b1x && pm1b2x < pm2b2x && - pm1b2y > pm2b1y && pm1b2y < pm2b2y) + (pm2b1x - pm1b2x <= 0 || + pm1b1x - pm2b2x <= 0) && + (pm2b1y - pm1b2y <= 0 || + pm1b1y - pm2b2y <= 0) + -- (pm1b1x > pm2b1x && pm1b1x < pm2b2x && + -- pm1b1y > pm2b1y && pm1b1y < pm2b2y) || + -- (pm1b2x > pm2b1x && pm1b2x < pm2b2x && + -- pm1b1y > pm2b1y && pm1b1y < pm2b2y) || + -- (pm1b1x > pm2b1x && pm1b2x < pm2b2x && + -- pm1b2y > pm2b1y && pm1b2y < pm2b2y) || + -- (pm1b2x > pm2b1x && pm1b2x < pm2b2x && + -- pm1b2y > pm2b1y && pm1b2y < pm2b2y) in2 = - (pm2b1x > pm1b1x && pm2b1x < pm1b2x && - pm2b1y > pm1b1y && pm2b1y < pm1b2y) || - (pm2b2x > pm1b1x && pm2b2x < pm1b2x && - pm2b1y > pm1b1y && pm2b1y < pm1b2y) || - (pm2b1x > pm1b1x && pm2b2x < pm1b2x && - pm2b2y > pm1b1y && pm2b2y < pm1b2y) || - (pm2b2x > pm1b1x && pm2b2x < pm1b2x && - pm2b2y > pm1b1y && pm2b2y < pm1b2y) + (pm1b1x - pm2b2x <= 0 || + pm2b1x - pm1b2x <= 0) && + (pm1b1y - pm2b2y <= 0 || + pm2b1y - pm1b2y <= 0) + -- (pm2b1x > pm1b1x && pm2b1x < pm1b2x && + -- pm2b1y > pm1b1y && pm2b1y < pm1b2y) || + -- (pm2b2x > pm1b1x && pm2b2x < pm1b2x && + -- pm2b1y > pm1b1y && pm2b1y < pm1b2y) || + -- (pm2b1x > pm1b1x && pm2b2x < pm1b2x && + -- pm2b2y > pm1b1y && pm2b2y < pm1b2y) || + -- (pm2b2x > pm1b1x && pm2b2x < pm1b2x && + -- pm2b2y > pm1b1y && pm2b2y < pm1b2y) in in2 || in1 tx = @@ -159,13 +168,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, _) -> - CollisionImminent tx (V2 (floor $ signum d1x) 0) + CollisionImminent tx (V2 (floor $ signum dpx) 0) (_, True, False, _, True) -> - CollisionImminent ty (V2 0 (floor $ signum d1y)) - (True, _, False, True, False) -> - CollisionImminent tx (V2 (floor $ signum d1x) 0) - (_, True, True, False, True) -> - CollisionImminent ty (V2 0 (floor $ signum d1y)) + CollisionImminent ty (V2 0 (floor $ signum dpy)) + -- (True, _, False, True, False) -> + -- CollisionImminent tx (V2 (floor $ signum d1x) 0) + -- (_, True, True, False, True) -> + -- CollisionImminent ty (V2 0 (floor $ signum d1y)) (_, _, _, False, False) -> NoCollision (_, _, True, _, _) -> @@ -177,43 +186,60 @@ class (Show c, Mass c) => Collidible c where <> fromString (show x) in case res of - CollisionImminent _ _ -> - res - NoCollision -> + c -> if overlap then - let xoverlap = floor $ -- (maximum (filter (0 >) - -- [ - pm2b2x - pm2b1x - -- , pm2b1x - pm1b2x - -- ])) - yoverlap = floor $ -- (maximum (filter (0 >) - -- [ - pm2b1y - pm1b2y - -- , pm2b2y - pm1b1y - -- ])) + let xoverlap = floor $ max + (min 0 $ pm2b2x - pm2b1x) + (min 0 $ pm2b1x - pm1b2x) + yoverlap = floor $ max + (min 0 $ pm2b1y - pm1b2y) + (min 0 $ pm2b2y - pm1b1y) in case (xoverlap < 0, yoverlap < 0) of (True, True) -> - if xoverlap < yoverlap + if abs xoverlap < abs yoverlap then - if xoverlap < 0 - then OverlapCollision + OverlapCollision (V2 xoverlap 0) - else - NoCollision else - if yoverlap < 0 - then OverlapCollision + OverlapCollision (V2 0 yoverlap) - else NoCollision (True, False) -> OverlapCollision (V2 xoverlap 0) (False, True) -> OverlapCollision (V2 0 yoverlap) (False, False) -> - NoCollision - else NoCollision + c + else + c + -- NoCollision -> + -- if overlap + -- then + -- let xoverlap = floor $ max + -- (min 0 $ pm2b2x - pm2b1x) + -- (min 0 $ pm2b1x - pm1b2x) + -- yoverlap = floor $ max + -- (min 0 $ pm2b1y - pm1b2y) + -- (min 0 $ pm2b2y - pm1b1y) + -- in + -- case (xoverlap < 0, yoverlap < 0) of + -- (True, True) -> + -- if abs xoverlap < abs yoverlap + -- then + -- OverlapCollision + -- (V2 xoverlap 0) + -- else + -- OverlapCollision + -- (V2 0 yoverlap) + -- (True, False) -> + -- OverlapCollision (V2 xoverlap 0) + -- (False, True) -> + -- OverlapCollision (V2 0 yoverlap) + -- (False, False) -> + -- NoCollision + -- else + -- NoCollision _ -> A.log A.Error "Premature overlap collision detection" @@ -269,15 +295,9 @@ elasticCollision damping mo1 (mo2, OverlapCollision depth) dt = -- v1y' = 2 * (m1 * dy + m2 * (-dy)) / (m1 + m2) - dy v1x' = 2 * (m1 * dx) / (m1 + m2) v1y' = 2 * (m1 * dy) / (m1 + m2) - nvel = if m1 == recip 0 - then V2 0 0 - else (damping *) <$> - if m2 == recip 0 - then - if dx /= 0 - then V2 (-v1x') v1y' - else V2 v1x' (-v1y') - else - V2 v1x' v1y' + nvel + | m1 == recip 0 = V2 0 0 + | m2 == recip 0 = V2 dx dy + | otherwise = V2 v1x' v1y' in velocityUpdater mo1 nvel diff --git a/src/Scenes/Test/Update.hs b/src/Scenes/Test/Update.hs index 67f71d9..d9761bc 100644 --- a/src/Scenes/Test/Update.hs +++ b/src/Scenes/Test/Update.hs @@ -58,11 +58,11 @@ update level dt = liftIO $ do let res = collisionCheck dt tangible1 tangible2 in case res of - c@(CollisionImminent _ _) -> + NoCollision -> jacc + c -> if qInd /= index then jacc `V.snoc` (qInd, c) else jacc - _ -> jacc ) V.empty indexedTangibles @@ -71,7 +71,13 @@ update level dt = liftIO $ do then iacc else iacc `V.snoc` ( index - , sortOn (collisionTime . snd) (V.toList partners) + , sortOn + (\(_, cr) -> case cr of + CollisionImminent ddt _ -> ddt + OverlapCollision _ -> 0 + NoCollision -> dt + ) + (V.toList partners) ) ) V.empty