wörk wörk
This commit is contained in:
parent
b53d93b608
commit
ac8b892fda
2 changed files with 87 additions and 61 deletions
|
@ -8,7 +8,7 @@ import Linear
|
||||||
|
|
||||||
import Data.String (fromString)
|
import Data.String (fromString)
|
||||||
|
|
||||||
import Data.List (sortBy)
|
import Data.Bifunctor (bimap)
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
|
@ -48,10 +48,11 @@ class (Show c, Mass c) => Collidible c where
|
||||||
d2@(V2 d2x d2y) = velocity m2
|
d2@(V2 d2x d2y) = velocity m2
|
||||||
p1@(V2 p1x p1y) = position m1
|
p1@(V2 p1x p1y) = position m1
|
||||||
p2@(V2 p2x p2y) = position m2
|
p2@(V2 p2x p2y) = position m2
|
||||||
|
(V2 dpx dpy) = p2 - p1
|
||||||
(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
|
||||||
(V2 pm1b1x pm1b1y, V2 pm1b2x pm1b2y) = (p1 +) <$> boundary m1
|
(V2 pm1b1x pm1b1y, V2 pm1b2x pm1b2y) = bimap (p1 +) (p1 +) (boundary m1)
|
||||||
(V2 pm2b1x pm2b1y, V2 pm2b2x pm2b2y) = (p2 +) <$> boundary m2
|
(V2 pm2b1x pm2b1y, V2 pm2b2x pm2b2y) = bimap (p2 +) (p2 +) (boundary m2)
|
||||||
m1p1@(V2 m1p1x m1p1y) = p1 + m1b1
|
m1p1@(V2 m1p1x m1p1y) = p1 + m1b1
|
||||||
m1p2 = p1 + V2 m1b1x m1b2y
|
m1p2 = p1 + V2 m1b1x m1b2y
|
||||||
m1p3@(V2 m1p3x m1p3y) = p1 + m1b2
|
m1p3@(V2 m1p3x m1p3y) = p1 + m1b2
|
||||||
|
@ -99,23 +100,31 @@ class (Show c, Mass c) => Collidible c where
|
||||||
in2 || in1
|
in2 || in1
|
||||||
overlap =
|
overlap =
|
||||||
let in1 =
|
let in1 =
|
||||||
(pm1b1x > pm2b1x && pm1b1x < pm2b2x &&
|
(pm2b1x - pm1b2x <= 0 ||
|
||||||
pm1b1y > pm2b1y && pm1b1y < pm2b2y) ||
|
pm1b1x - pm2b2x <= 0) &&
|
||||||
(pm1b2x > pm2b1x && pm1b2x < pm2b2x &&
|
(pm2b1y - pm1b2y <= 0 ||
|
||||||
pm1b1y > pm2b1y && pm1b1y < pm2b2y) ||
|
pm1b1y - pm2b2y <= 0)
|
||||||
(pm1b1x > pm2b1x && pm1b2x < pm2b2x &&
|
-- (pm1b1x > pm2b1x && pm1b1x < pm2b2x &&
|
||||||
pm1b2y > pm2b1y && pm1b2y < pm2b2y) ||
|
-- pm1b1y > pm2b1y && pm1b1y < pm2b2y) ||
|
||||||
(pm1b2x > pm2b1x && pm1b2x < pm2b2x &&
|
-- (pm1b2x > pm2b1x && pm1b2x < pm2b2x &&
|
||||||
pm1b2y > pm2b1y && pm1b2y < pm2b2y)
|
-- pm1b1y > pm2b1y && pm1b1y < pm2b2y) ||
|
||||||
|
-- (pm1b1x > pm2b1x && pm1b2x < pm2b2x &&
|
||||||
|
-- pm1b2y > pm2b1y && pm1b2y < pm2b2y) ||
|
||||||
|
-- (pm1b2x > pm2b1x && pm1b2x < pm2b2x &&
|
||||||
|
-- pm1b2y > pm2b1y && pm1b2y < pm2b2y)
|
||||||
in2 =
|
in2 =
|
||||||
(pm2b1x > pm1b1x && pm2b1x < pm1b2x &&
|
(pm1b1x - pm2b2x <= 0 ||
|
||||||
pm2b1y > pm1b1y && pm2b1y < pm1b2y) ||
|
pm2b1x - pm1b2x <= 0) &&
|
||||||
(pm2b2x > pm1b1x && pm2b2x < pm1b2x &&
|
(pm1b1y - pm2b2y <= 0 ||
|
||||||
pm2b1y > pm1b1y && pm2b1y < pm1b2y) ||
|
pm2b1y - pm1b2y <= 0)
|
||||||
(pm2b1x > pm1b1x && pm2b2x < pm1b2x &&
|
-- (pm2b1x > pm1b1x && pm2b1x < pm1b2x &&
|
||||||
pm2b2y > pm1b1y && pm2b2y < pm1b2y) ||
|
-- pm2b1y > pm1b1y && pm2b1y < pm1b2y) ||
|
||||||
(pm2b2x > pm1b1x && pm2b2x < pm1b2x &&
|
-- (pm2b2x > pm1b1x && pm2b2x < pm1b2x &&
|
||||||
pm2b2y > pm1b1y && pm2b2y < pm1b2y)
|
-- pm2b1y > pm1b1y && pm2b1y < pm1b2y) ||
|
||||||
|
-- (pm2b1x > pm1b1x && pm2b2x < pm1b2x &&
|
||||||
|
-- pm2b2y > pm1b1y && pm2b2y < pm1b2y) ||
|
||||||
|
-- (pm2b2x > pm1b1x && pm2b2x < pm1b2x &&
|
||||||
|
-- pm2b2y > pm1b1y && pm2b2y < pm1b2y)
|
||||||
in
|
in
|
||||||
in2 || in1
|
in2 || in1
|
||||||
tx =
|
tx =
|
||||||
|
@ -159,13 +168,13 @@ class (Show c, Mass c) => Collidible c where
|
||||||
any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22]
|
any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22]
|
||||||
res = case (tx < dt, ty < dt, tx < ty, coll True, coll False) of
|
res = case (tx < dt, ty < dt, tx < ty, coll True, coll False) of
|
||||||
(True, _, True, True, _) ->
|
(True, _, True, True, _) ->
|
||||||
CollisionImminent tx (V2 (floor $ signum d1x) 0)
|
CollisionImminent tx (V2 (floor $ signum dpx) 0)
|
||||||
(_, True, False, _, True) ->
|
(_, True, False, _, True) ->
|
||||||
CollisionImminent ty (V2 0 (floor $ signum d1y))
|
CollisionImminent ty (V2 0 (floor $ signum dpy))
|
||||||
(True, _, False, True, False) ->
|
-- (True, _, False, True, False) ->
|
||||||
CollisionImminent tx (V2 (floor $ signum d1x) 0)
|
-- CollisionImminent tx (V2 (floor $ signum d1x) 0)
|
||||||
(_, True, True, False, True) ->
|
-- (_, True, True, False, True) ->
|
||||||
CollisionImminent ty (V2 0 (floor $ signum d1y))
|
-- CollisionImminent ty (V2 0 (floor $ signum d1y))
|
||||||
(_, _, _, False, False) ->
|
(_, _, _, False, False) ->
|
||||||
NoCollision
|
NoCollision
|
||||||
(_, _, True, _, _) ->
|
(_, _, True, _, _) ->
|
||||||
|
@ -177,43 +186,60 @@ class (Show c, Mass c) => Collidible c where
|
||||||
<> fromString (show x)
|
<> fromString (show x)
|
||||||
in
|
in
|
||||||
case res of
|
case res of
|
||||||
CollisionImminent _ _ ->
|
c ->
|
||||||
res
|
|
||||||
NoCollision ->
|
|
||||||
if overlap
|
if overlap
|
||||||
then
|
then
|
||||||
let xoverlap = floor $ -- (maximum (filter (0 >)
|
let xoverlap = floor $ max
|
||||||
-- [
|
(min 0 $ pm2b2x - pm2b1x)
|
||||||
pm2b2x - pm2b1x
|
(min 0 $ pm2b1x - pm1b2x)
|
||||||
-- , pm2b1x - pm1b2x
|
yoverlap = floor $ max
|
||||||
-- ]))
|
(min 0 $ pm2b1y - pm1b2y)
|
||||||
yoverlap = floor $ -- (maximum (filter (0 >)
|
(min 0 $ pm2b2y - pm1b1y)
|
||||||
-- [
|
|
||||||
pm2b1y - pm1b2y
|
|
||||||
-- , pm2b2y - pm1b1y
|
|
||||||
-- ]))
|
|
||||||
in
|
in
|
||||||
case (xoverlap < 0, yoverlap < 0) of
|
case (xoverlap < 0, yoverlap < 0) of
|
||||||
(True, True) ->
|
(True, True) ->
|
||||||
if xoverlap < yoverlap
|
if abs xoverlap < abs yoverlap
|
||||||
then
|
then
|
||||||
if xoverlap < 0
|
OverlapCollision
|
||||||
then OverlapCollision
|
|
||||||
(V2 xoverlap 0)
|
(V2 xoverlap 0)
|
||||||
else
|
|
||||||
NoCollision
|
|
||||||
else
|
else
|
||||||
if yoverlap < 0
|
OverlapCollision
|
||||||
then OverlapCollision
|
|
||||||
(V2 0 yoverlap)
|
(V2 0 yoverlap)
|
||||||
else NoCollision
|
|
||||||
(True, False) ->
|
(True, False) ->
|
||||||
OverlapCollision (V2 xoverlap 0)
|
OverlapCollision (V2 xoverlap 0)
|
||||||
(False, True) ->
|
(False, True) ->
|
||||||
OverlapCollision (V2 0 yoverlap)
|
OverlapCollision (V2 0 yoverlap)
|
||||||
(False, False) ->
|
(False, False) ->
|
||||||
NoCollision
|
c
|
||||||
else NoCollision
|
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.log
|
||||||
A.Error
|
A.Error
|
||||||
"Premature overlap collision detection"
|
"Premature overlap collision detection"
|
||||||
|
@ -269,15 +295,9 @@ elasticCollision damping mo1 (mo2, OverlapCollision depth) dt =
|
||||||
-- v1y' = 2 * (m1 * dy + m2 * (-dy)) / (m1 + m2) - dy
|
-- v1y' = 2 * (m1 * dy + m2 * (-dy)) / (m1 + m2) - dy
|
||||||
v1x' = 2 * (m1 * dx) / (m1 + m2)
|
v1x' = 2 * (m1 * dx) / (m1 + m2)
|
||||||
v1y' = 2 * (m1 * dy) / (m1 + m2)
|
v1y' = 2 * (m1 * dy) / (m1 + m2)
|
||||||
nvel = if m1 == recip 0
|
nvel
|
||||||
then V2 0 0
|
| m1 == recip 0 = V2 0 0
|
||||||
else (damping *) <$>
|
| m2 == recip 0 = V2 dx dy
|
||||||
if m2 == recip 0
|
| otherwise = V2 v1x' v1y'
|
||||||
then
|
|
||||||
if dx /= 0
|
|
||||||
then V2 (-v1x') v1y'
|
|
||||||
else V2 v1x' (-v1y')
|
|
||||||
else
|
|
||||||
V2 v1x' v1y'
|
|
||||||
in
|
in
|
||||||
velocityUpdater mo1 nvel
|
velocityUpdater mo1 nvel
|
||||||
|
|
|
@ -58,11 +58,11 @@ update level dt = liftIO $ do
|
||||||
let res = collisionCheck dt tangible1 tangible2
|
let res = collisionCheck dt tangible1 tangible2
|
||||||
in
|
in
|
||||||
case res of
|
case res of
|
||||||
c@(CollisionImminent _ _) ->
|
NoCollision -> jacc
|
||||||
|
c ->
|
||||||
if qInd /= index
|
if qInd /= index
|
||||||
then jacc `V.snoc` (qInd, c)
|
then jacc `V.snoc` (qInd, c)
|
||||||
else jacc
|
else jacc
|
||||||
_ -> jacc
|
|
||||||
)
|
)
|
||||||
V.empty
|
V.empty
|
||||||
indexedTangibles
|
indexedTangibles
|
||||||
|
@ -71,7 +71,13 @@ update level dt = liftIO $ do
|
||||||
then iacc
|
then iacc
|
||||||
else iacc `V.snoc`
|
else iacc `V.snoc`
|
||||||
( index
|
( index
|
||||||
, sortOn (collisionTime . snd) (V.toList partners)
|
, sortOn
|
||||||
|
(\(_, cr) -> case cr of
|
||||||
|
CollisionImminent ddt _ -> ddt
|
||||||
|
OverlapCollision _ -> 0
|
||||||
|
NoCollision -> dt
|
||||||
|
)
|
||||||
|
(V.toList partners)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
V.empty
|
V.empty
|
||||||
|
|
Loading…
Reference in a new issue