squish
This commit is contained in:
parent
9d09365e7d
commit
c7f4f00a2f
2 changed files with 190 additions and 143 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue