squish
This commit is contained in:
parent
9d09365e7d
commit
c7f4f00a2f
|
@ -16,7 +16,10 @@ import Classes.Physics.Mass
|
||||||
|
|
||||||
data CollisionResult time direction
|
data CollisionResult time direction
|
||||||
= NoCollision
|
= NoCollision
|
||||||
| Collision time direction
|
| Collision
|
||||||
|
{ collisionTime :: time
|
||||||
|
, collisionDirection :: direction
|
||||||
|
}
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
-- | Typeclass for implementing collision results on objects.
|
-- | Typeclass for implementing collision results on objects.
|
||||||
|
@ -44,16 +47,14 @@ class (Show c, Mass c) => Collidible c where
|
||||||
p2 = position m2
|
p2 = position m2
|
||||||
(m1b1@(V2 m1b1x m1b1y), m1b2@(V2 m1b2x m1b2y)) = boundary m1
|
(m1b1@(V2 m1b1x m1b1y), m1b2@(V2 m1b2x m1b2y)) = boundary m1
|
||||||
(m2b1@(V2 m2b1x m2b1y), m2b2@(V2 m2b2x m2b2y)) = boundary m2
|
(m2b1@(V2 m2b1x m2b1y), m2b2@(V2 m2b2x m2b2y)) = boundary m2
|
||||||
m1p1 = m1b1
|
m1p1 = p1 + m1b1
|
||||||
m1p2 = V2 m1b1x m1b2y
|
m1p2 = p1 + V2 m1b1x m1b2y
|
||||||
m1p3 = m1b2
|
m1p3 = p1 + m1b2
|
||||||
m1p4 = V2 m1b2x m1b1y
|
m1p4 = p1 + V2 m1b2x m1b1y
|
||||||
m2p1 = m2b1
|
m2p1 = p2 + m2b1
|
||||||
m2p2 = V2 m2b1x m2b2y
|
m2p2 = p2 + V2 m2b1x m2b2y
|
||||||
m2p3 = m2b2
|
m2p3 = p2 + m2b2
|
||||||
m2p4 = V2 m2b2x m2b1y
|
m2p4 = p2 + V2 m2b2x m2b1y
|
||||||
quad1 = map (p1 +) [m1p1, m1p2, m1p3, m1p4]
|
|
||||||
quad2 = map (p2 +) [m2p1, m2p2, m2p3, m2p4]
|
|
||||||
g11 = (m1p1, m1p2)
|
g11 = (m1p1, m1p2)
|
||||||
g12 = (m1p2, m1p3)
|
g12 = (m1p2, m1p3)
|
||||||
g13 = (m1p3, m1p4)
|
g13 = (m1p3, m1p4)
|
||||||
|
@ -62,118 +63,117 @@ class (Show c, Mass c) => Collidible c where
|
||||||
g22 = (m2p2, m2p3)
|
g22 = (m2p2, m2p3)
|
||||||
g23 = (m2p3, m2p4)
|
g23 = (m2p3, m2p4)
|
||||||
g24 = (m2p4, m2p1)
|
g24 = (m2p4, m2p1)
|
||||||
g1s = map (\(s1, s2) -> (p1 + s1, p1 + s2)) [g11, g12, g13, g14]
|
g1s = [g11, g12, g13, g14]
|
||||||
g2s = map (\(s1, s2) -> (p2 + s1, p2 + s2)) [g21, g22, g23, g24]
|
g2s = [g21, g22, g23, g24]
|
||||||
t1 q@(V2 mqpx mqpy) (ps@(V2 mspx mspy), pt@(V2 mtpx mtpy)) =
|
b1 =
|
||||||
if d1x == 0 && d1y == 0
|
( V2
|
||||||
then dt
|
((\(V2 x _) -> x) (if d1x < 0 then m1p1 + ((dt *) <$> d1) else m1p1))
|
||||||
else
|
((\(V2 _ y) -> y) (if d1y < 0 then m1p1 + ((dt *) <$> d1) else m1p1))
|
||||||
let (V2 cx cy) = ps - q
|
, V2
|
||||||
(V2 rx ry) = pt - ps
|
((\(V2 x _) -> x) (if d1x < 0 then m1p3 else m1p3 + ((dt *) <$> d1)))
|
||||||
in
|
((\(V2 _ y) -> y) (if d1y < 0 then m1p3 else m1p3 + ((dt *) <$> d1)))
|
||||||
(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)
|
|
||||||
)
|
)
|
||||||
|
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
|
else
|
||||||
let res1 = foldl
|
if ty < dt
|
||||||
(\acc1 gx ->
|
then
|
||||||
let gt = foldl
|
if d1y < 0
|
||||||
(\acc2 q ->
|
then
|
||||||
let qt = t1 q gx
|
let g1s = m1p2 + ((ty *) <$> d1)
|
||||||
qs = s1 q gx
|
g1e = m1p3 + ((ty *) <$> d1)
|
||||||
in
|
g2s = m2p4 + ((ty *) <$> d2)
|
||||||
if (qs > 0 && qs < 1) && (qt > 0 && qt < acc2)
|
g2e = m2p1 + ((ty *) <$> d2)
|
||||||
then qt
|
s11 = (g1s - g2s) / (g2e - g2s)
|
||||||
else acc2
|
s12 = (g1e - g2s) / (g2e - g2s)
|
||||||
)
|
s21 = (g2s - g1s) / (g1e - g1s)
|
||||||
(fst acc1)
|
s22 = (g2e - g1s) / (g1e - g1s)
|
||||||
quad1
|
in
|
||||||
in
|
if any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22]
|
||||||
if gt < fst acc1
|
then Collision ty (V2 0 (floor $ signum (-d1y)))
|
||||||
then
|
else NoCollision
|
||||||
( gt
|
else
|
||||||
, if gx == (p2 + fst g21, p2 + snd g22) ||
|
let g1s = m1p4 + ((ty *) <$> d1)
|
||||||
gx == (p2 + fst g23, p2 + snd g23)
|
g1e = m1p1 + ((ty *) <$> d1)
|
||||||
then V2 (round $ signum d1x) 0
|
g2s = m2p2 + ((ty *) <$> d2)
|
||||||
else V2 0 (round $ signum d1y)
|
g2e = m2p3 + ((ty *) <$> d2)
|
||||||
)
|
s11 = (g1s - g2s) / (g2e - g2s)
|
||||||
else acc1
|
s12 = (g1e - g2s) / (g2e - g2s)
|
||||||
)
|
s21 = (g2s - g1s) / (g1e - g1s)
|
||||||
(dt, V2 0 0)
|
s22 = (g2e - g1s) / (g1e - g1s)
|
||||||
g2s
|
in
|
||||||
res2 = foldl
|
if any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22]
|
||||||
(\acc1 gx ->
|
then Collision ty (V2 0 (floor $ signum (-d1y)))
|
||||||
let gt = foldl
|
else NoCollision
|
||||||
(\acc2 q ->
|
else
|
||||||
let qt = t2 q gx
|
NoCollision
|
||||||
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
|
|
||||||
|
|
||||||
-- | This Function is called for every collision on both colliding objects.
|
-- | This Function is called for every collision on both colliding objects.
|
||||||
collide
|
collide
|
||||||
|
|
|
@ -9,6 +9,8 @@ import qualified Data.Vector as V
|
||||||
|
|
||||||
import Data.String (fromString)
|
import Data.String (fromString)
|
||||||
|
|
||||||
|
import Linear
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
import Scenes.Test.Types
|
import Scenes.Test.Types
|
||||||
|
@ -34,17 +36,40 @@ update level dt = liftIO $ do
|
||||||
(\(Cast c) -> Cast (perform dt c))
|
(\(Cast c) -> Cast (perform dt c))
|
||||||
cast
|
cast
|
||||||
collidedCast =
|
collidedCast =
|
||||||
(\(Cast c1) (Cast c2) ->
|
V.map
|
||||||
Cast $ collide c1 c2 (collisionCheck dt c1 c2)
|
(\(Cast c1) ->
|
||||||
)
|
let partners = V.foldl
|
||||||
<$> playedCast <*> playedCast
|
(\acc@(Cast _, ires) (Cast c2) ->
|
||||||
wallCast (Cast c) = Cast $
|
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
|
V.foldl
|
||||||
(\member tile ->
|
(\acc@(_, ires) tile ->
|
||||||
collide member tile (collisionCheck dt member tile)
|
let res = collisionCheck dt c tile
|
||||||
)
|
in
|
||||||
c
|
if res /= NoCollision &&
|
||||||
layer
|
collisionTime res < collisionTime ires
|
||||||
|
then (tile, res)
|
||||||
|
else acc
|
||||||
|
)
|
||||||
|
(V.head layer, Collision dt (V2 0 0))
|
||||||
|
layer
|
||||||
walledCast =
|
walledCast =
|
||||||
V.map wallCast collidedCast
|
V.map wallCast collidedCast
|
||||||
in
|
in
|
||||||
|
@ -58,17 +83,39 @@ update level dt = liftIO $ do
|
||||||
(testPlayer level) $ \(Just pituicat) ->
|
(testPlayer level) $ \(Just pituicat) ->
|
||||||
let playedCat = perform dt pituicat
|
let playedCat = perform dt pituicat
|
||||||
collidedCat =
|
collidedCat =
|
||||||
V.foldl
|
let partner =
|
||||||
(\cat (Cast c) ->
|
V.foldl
|
||||||
collide cat c (collisionCheck dt cat c)
|
(\acc@(_, ires) (Cast c) ->
|
||||||
)
|
let res = collisionCheck dt playedCat c
|
||||||
playedCat
|
in
|
||||||
updatedCast
|
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 =
|
walledCat =
|
||||||
V.foldl
|
let partner =
|
||||||
(\cat tile ->
|
V.foldl
|
||||||
collide cat tile (collisionCheck dt cat tile)
|
(\acc@(_, ires) tile ->
|
||||||
)
|
let res = collisionCheck dt collidedCat tile
|
||||||
collidedCat
|
in
|
||||||
layer
|
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
|
in Just $ move dt walledCat
|
||||||
|
|
Loading…
Reference in New Issue