diff --git a/src/Classes/Physics/Collidible.hs b/src/Classes/Physics/Collidible.hs index 7706e32..1875c11 100644 --- a/src/Classes/Physics/Collidible.hs +++ b/src/Classes/Physics/Collidible.hs @@ -16,7 +16,10 @@ import Classes.Physics.Mass data CollisionResult time direction = NoCollision - | Collision time direction + | Collision + { collisionTime :: time + , collisionDirection :: direction + } deriving (Show, Eq) -- | Typeclass for implementing collision results on objects. @@ -44,16 +47,14 @@ class (Show c, Mass c) => Collidible c where p2 = position m2 (m1b1@(V2 m1b1x m1b1y), m1b2@(V2 m1b2x m1b2y)) = boundary m1 (m2b1@(V2 m2b1x m2b1y), m2b2@(V2 m2b2x m2b2y)) = boundary m2 - m1p1 = m1b1 - m1p2 = V2 m1b1x m1b2y - m1p3 = m1b2 - m1p4 = V2 m1b2x m1b1y - m2p1 = m2b1 - m2p2 = V2 m2b1x m2b2y - m2p3 = m2b2 - m2p4 = V2 m2b2x m2b1y - quad1 = map (p1 +) [m1p1, m1p2, m1p3, m1p4] - quad2 = map (p2 +) [m2p1, m2p2, m2p3, m2p4] + m1p1 = p1 + m1b1 + m1p2 = p1 + V2 m1b1x m1b2y + m1p3 = p1 + m1b2 + m1p4 = p1 + V2 m1b2x m1b1y + m2p1 = p2 + m2b1 + m2p2 = p2 + V2 m2b1x m2b2y + m2p3 = p2 + m2b2 + m2p4 = p2 + V2 m2b2x m2b1y g11 = (m1p1, m1p2) g12 = (m1p2, m1p3) g13 = (m1p3, m1p4) @@ -62,118 +63,117 @@ class (Show c, Mass c) => Collidible c where g22 = (m2p2, m2p3) g23 = (m2p3, m2p4) g24 = (m2p4, m2p1) - g1s = map (\(s1, s2) -> (p1 + s1, p1 + s2)) [g11, g12, g13, g14] - g2s = map (\(s1, s2) -> (p2 + s1, p2 + s2)) [g21, g22, g23, g24] - t1 q@(V2 mqpx mqpy) (ps@(V2 mspx mspy), pt@(V2 mtpx mtpy)) = - if d1x == 0 && d1y == 0 - then dt - else - let (V2 cx cy) = ps - q - (V2 rx ry) = pt - ps - in - (cx * (-ry) - (-rx) * cy) / - (d1x * (-ry) - (-rx) * d1y) - t2 q@(V2 mqpx mqpy) (ps@(V2 mspx mspy), pt@(V2 mtpx mtpy)) = - if d2x == 0 && d2y == 0 - then dt - else - let (V2 cx cy) = ps - q - (V2 rx ry) = pt - ps - in - (cx * (-ry) - (-rx) * cy) / - (d2x * (-ry) - (-rx) * d2y) - s1 q@(V2 mqpx mqpy) (ps@(V2 mspx mspy), pt@(V2 mtpx mtpy)) = - let (V2 cx cy) = ps - q - (V2 rx ry) = pt - ps - in - (d1x * cy - cx * d1y) / - (d1x * (-ry) - (-rx) * d1y) - s2 q@(V2 mqpx mqpy) (ps@(V2 mspx mspy), pt@(V2 mtpx mtpy)) = - let (V2 cx cy) = ps - q - (V2 rx ry) = pt - ps - in - (d2x * cy - cx * d2y) / - (d2x * (-ry) - (-rx) * d2y) - inside1 m = - let dm = m - (p1 + m1p4) - dc = (p1 + m1p3) - (p1 + m1p4) - da = (p1 + m1p1) - (p1 + m1p4) - in - (0 < dm `dot` dc && dm `dot` dc < dc `dot` dc) && - (0 < dm `dot` da && dm `dot` da < da `dot` da) - inside2 m = - let dm = m - (p2 + m2p4) - dc = (p2 + m2p3) - (p2 + m2p4) - da = (p2 + m2p1) - (p2 + m2p4) - in - (0 < dm `dot` dc && dm `dot` dc < dc `dot` dc) && - (0 < dm `dot` da && dm `dot` da < da `dot` da) - in - if any inside1 quad2 || any inside2 quad1 - then Collision 0 - (if abs d1x > abs d1y - then V2 (round $ signum d1x) 0 - else V2 0 (round $ signum d1y) + g1s = [g11, g12, g13, g14] + g2s = [g21, g22, g23, g24] + b1 = + ( V2 + ((\(V2 x _) -> x) (if d1x < 0 then m1p1 + ((dt *) <$> d1) else m1p1)) + ((\(V2 _ y) -> y) (if d1y < 0 then m1p1 + ((dt *) <$> d1) else m1p1)) + , V2 + ((\(V2 x _) -> x) (if d1x < 0 then m1p3 else m1p3 + ((dt *) <$> d1))) + ((\(V2 _ y) -> y) (if d1y < 0 then m1p3 else m1p3 + ((dt *) <$> d1))) ) + b2 = + ( V2 + ((\(V2 x _) -> x) (if d2x < 0 then m2p1 + ((dt *) <$> d2) else m2p1)) + ((\(V2 _ y) -> y) (if d2y < 0 then m2p1 + ((dt *) <$> d2) else m2p1)) + , V2 + ((\(V2 x _) -> x) (if d2x < 0 then m2p3 else m2p3 + ((dt *) <$> d2))) + ((\(V2 _ y) -> y) (if d2y < 0 then m2p3 else m2p3 + ((dt *) <$> d2))) + ) + broadphaseOverlap = + let b11@(V2 b1minx b1miny) = fst b1 + b12@(V2 b1maxx b1maxy) = snd b1 + b21@(V2 b2minx b2miny) = fst b2 + b22@(V2 b2maxx b2maxy) = snd b2 + in2 = + (b1minx > b2minx && b1minx < b2maxx && b1miny > b2miny && b1miny < b2maxy) || + (b1maxx > b2minx && b1maxx < b2maxx && b1miny > b2miny && b1miny < b2maxy) || + (b1minx > b2minx && b1minx < b2maxx && b1maxy > b2miny && b1maxy < b2maxy) || + (b1maxx > b2minx && b1maxx < b2maxx && b1maxy > b2miny && b1maxy < b2maxy) + in1 = + (b2minx > b1minx && b2minx < b1maxx && b2miny > b1miny && b2miny < b1maxy) || + (b2maxx > b1minx && b2maxx < b1maxx && b2miny > b1miny && b2miny < b1maxy) || + (b2minx > b1minx && b2minx < b1maxx && b2maxy > b1miny && b2maxy < b1maxy) || + (b2maxx > b1minx && b2maxx < b1maxx && b2maxy > b1miny && b2maxy < b1maxy) + in + in2 || in1 + tx = + let p1x = (\(V2 x _) -> x) (if d1x < 0 then m1p1 else m1p3) + p2x = (\(V2 x _) -> x) (if d1x < 0 then m2p3 else m2p1) + in + (p1x - p2x) / (d2x - d1x) + ty = + let p1y = (\(V2 _ y) -> y) (if d1y < 0 then m1p1 else m1p3) + p2y = (\(V2 _ y) -> y) (if d1y < 0 then m2p3 else m2p1) + in + (p1y - p2y) / (d2y - d1y) + in + if tx < ty + then + if tx < dt + then + if d1x < 0 + then + let g1s = m1p1 + ((tx *) <$> d1) + g1e = m1p2 + ((tx *) <$> d1) + g2s = m2p3 + ((tx *) <$> d2) + g2e = m2p4 + ((tx *) <$> d2) + s11 = (g1s - g2s) / (g2e - g2s) + s12 = (g1e - g2s) / (g2e - g2s) + s21 = (g2s - g1s) / (g1e - g1s) + s22 = (g2e - g1s) / (g1e - g1s) + in + if any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22] + then Collision tx (V2 (floor $ signum (-d1x)) 0) + else NoCollision + else + let g1s = m1p3 + ((tx *) <$> d1) + g1e = m1p4 + ((tx *) <$> d1) + g2s = m2p1 + ((tx *) <$> d2) + g2e = m2p2 + ((tx *) <$> d2) + s11 = (g1s - g2s) / (g2e - g2s) + s12 = (g1e - g2s) / (g2e - g2s) + s21 = (g2s - g1s) / (g1e - g1s) + s22 = (g2e - g1s) / (g1e - g1s) + in + if any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22] + then Collision tx (V2 (floor $ signum (-d1x)) 0) + else NoCollision + else + NoCollision else - let res1 = foldl - (\acc1 gx -> - let gt = foldl - (\acc2 q -> - let qt = t1 q gx - qs = s1 q gx - in - if (qs > 0 && qs < 1) && (qt > 0 && qt < acc2) - then qt - else acc2 - ) - (fst acc1) - quad1 - in - if gt < fst acc1 - then - ( gt - , if gx == (p2 + fst g21, p2 + snd g22) || - gx == (p2 + fst g23, p2 + snd g23) - then V2 (round $ signum d1x) 0 - else V2 0 (round $ signum d1y) - ) - else acc1 - ) - (dt, V2 0 0) - g2s - res2 = foldl - (\acc1 gx -> - let gt = foldl - (\acc2 q -> - let qt = t2 q gx - qs = s2 q gx - in - if (qs > 0 && qs < 1) && (qt > 0 && qt < acc2) - then qt - else acc2 - ) - (fst acc1) - quad1 - in - if gt < fst acc1 - then - ( gt - , if gx == (p1 + fst g11, p2 + snd g12) || - gx == (p1 + fst g13, p2 + snd g13) - then V2 (round $ signum d1x) 0 - else V2 0 (round $ signum d1y) - ) - else acc1 - ) - (dt, V2 0 0) - g1s - res = minimumBy (\a b -> fst a `compare` fst b) [res1, res2] - in - if fst res < dt - then Collision `uncurry` - A.log Debug ("Collision Imminent!!! " <> fromString (show res)) res - else NoCollision + if ty < dt + then + if d1y < 0 + then + let g1s = m1p2 + ((ty *) <$> d1) + g1e = m1p3 + ((ty *) <$> d1) + g2s = m2p4 + ((ty *) <$> d2) + g2e = m2p1 + ((ty *) <$> d2) + s11 = (g1s - g2s) / (g2e - g2s) + s12 = (g1e - g2s) / (g2e - g2s) + s21 = (g2s - g1s) / (g1e - g1s) + s22 = (g2e - g1s) / (g1e - g1s) + in + if any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22] + then Collision ty (V2 0 (floor $ signum (-d1y))) + else NoCollision + else + let g1s = m1p4 + ((ty *) <$> d1) + g1e = m1p1 + ((ty *) <$> d1) + g2s = m2p2 + ((ty *) <$> d2) + g2e = m2p3 + ((ty *) <$> d2) + s11 = (g1s - g2s) / (g2e - g2s) + s12 = (g1e - g2s) / (g2e - g2s) + s21 = (g2s - g1s) / (g1e - g1s) + s22 = (g2e - g1s) / (g1e - g1s) + in + if any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22] + then Collision ty (V2 0 (floor $ signum (-d1y))) + else NoCollision + else + NoCollision -- | This Function is called for every collision on both colliding objects. collide diff --git a/src/Scenes/Test/Update.hs b/src/Scenes/Test/Update.hs index 9596580..1170650 100644 --- a/src/Scenes/Test/Update.hs +++ b/src/Scenes/Test/Update.hs @@ -9,6 +9,8 @@ import qualified Data.Vector as V import Data.String (fromString) +import Linear + -- internal imports import Scenes.Test.Types @@ -34,17 +36,40 @@ update level dt = liftIO $ do (\(Cast c) -> Cast (perform dt c)) cast collidedCast = - (\(Cast c1) (Cast c2) -> - Cast $ collide c1 c2 (collisionCheck dt c1 c2) - ) - <$> playedCast <*> playedCast - wallCast (Cast c) = Cast $ + V.map + (\(Cast c1) -> + let partners = V.foldl + (\acc@(Cast _, ires) (Cast c2) -> + let res = collisionCheck dt c1 c2 + in + if res /= NoCollision && + collisionTime res < collisionTime ires + then (Cast c2, res) + else acc + ) + (Cast c1, Collision dt (V2 0 0)) + playedCast + in + if null partners + then Cast c1 + else + uncurry + (\(Cast c2) result -> Cast $ collide c1 c2 result) + partners + ) + playedCast + wallCast (Cast c) = Cast $ uncurry (collide c) $ V.foldl - (\member tile -> - collide member tile (collisionCheck dt member tile) - ) - c - layer + (\acc@(_, ires) tile -> + let res = collisionCheck dt c tile + in + if res /= NoCollision && + collisionTime res < collisionTime ires + then (tile, res) + else acc + ) + (V.head layer, Collision dt (V2 0 0)) + layer walledCast = V.map wallCast collidedCast in @@ -58,17 +83,39 @@ update level dt = liftIO $ do (testPlayer level) $ \(Just pituicat) -> let playedCat = perform dt pituicat collidedCat = - V.foldl - (\cat (Cast c) -> - collide cat c (collisionCheck dt cat c) - ) - playedCat - updatedCast + let partner = + V.foldl + (\acc@(_, ires) (Cast c) -> + let res = collisionCheck dt playedCat c + in + if res /= NoCollision && + collisionTime res < collisionTime ires + then (Cast c, res) + else acc + ) + (V.head updatedCast, Collision dt (V2 0 0)) + updatedCast + in + if (collisionTime $ snd partner) == dt + then playedCat + else uncurry + (\(Cast cx) res -> collide playedCat cx res) + partner walledCat = - V.foldl - (\cat tile -> - collide cat tile (collisionCheck dt cat tile) - ) - collidedCat - layer + let partner = + V.foldl + (\acc@(_, ires) tile -> + let res = collisionCheck dt collidedCat tile + in + if res /= NoCollision && + collisionTime res < collisionTime ires + then (tile, res) + else acc + ) + (V.head layer, Collision dt (V2 0 0)) + layer + in + if (collisionTime $ snd partner) == dt + then collidedCat + else uncurry (collide collidedCat) partner in Just $ move dt walledCat