This commit is contained in:
nek0 2021-02-27 16:08:45 +01:00
parent 9d09365e7d
commit c7f4f00a2f
2 changed files with 190 additions and 143 deletions

View File

@ -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

View File

@ -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