wörk wörk

This commit is contained in:
nek0 2021-07-27 01:51:51 +02:00
parent b53d93b608
commit ac8b892fda
2 changed files with 87 additions and 61 deletions

View file

@ -8,7 +8,7 @@ import Linear
import Data.String (fromString)
import Data.List (sortBy)
import Data.Bifunctor (bimap)
-- internal imports
@ -48,10 +48,11 @@ class (Show c, Mass c) => Collidible c where
d2@(V2 d2x d2y) = velocity m2
p1@(V2 p1x p1y) = position m1
p2@(V2 p2x p2y) = position m2
(V2 dpx dpy) = p2 - p1
(m1b1@(V2 m1b1x m1b1y), m1b2@(V2 m1b2x m1b2y)) = boundary m1
(m2b1@(V2 m2b1x m2b1y), m2b2@(V2 m2b2x m2b2y)) = boundary m2
(V2 pm1b1x pm1b1y, V2 pm1b2x pm1b2y) = (p1 +) <$> boundary m1
(V2 pm2b1x pm2b1y, V2 pm2b2x pm2b2y) = (p2 +) <$> boundary m2
(V2 pm1b1x pm1b1y, V2 pm1b2x pm1b2y) = bimap (p1 +) (p1 +) (boundary m1)
(V2 pm2b1x pm2b1y, V2 pm2b2x pm2b2y) = bimap (p2 +) (p2 +) (boundary m2)
m1p1@(V2 m1p1x m1p1y) = p1 + m1b1
m1p2 = p1 + V2 m1b1x m1b2y
m1p3@(V2 m1p3x m1p3y) = p1 + m1b2
@ -99,23 +100,31 @@ class (Show c, Mass c) => Collidible c where
in2 || in1
overlap =
let in1 =
(pm1b1x > pm2b1x && pm1b1x < pm2b2x &&
pm1b1y > pm2b1y && pm1b1y < pm2b2y) ||
(pm1b2x > pm2b1x && pm1b2x < pm2b2x &&
pm1b1y > pm2b1y && pm1b1y < pm2b2y) ||
(pm1b1x > pm2b1x && pm1b2x < pm2b2x &&
pm1b2y > pm2b1y && pm1b2y < pm2b2y) ||
(pm1b2x > pm2b1x && pm1b2x < pm2b2x &&
pm1b2y > pm2b1y && pm1b2y < pm2b2y)
(pm2b1x - pm1b2x <= 0 ||
pm1b1x - pm2b2x <= 0) &&
(pm2b1y - pm1b2y <= 0 ||
pm1b1y - pm2b2y <= 0)
-- (pm1b1x > pm2b1x && pm1b1x < pm2b2x &&
-- pm1b1y > pm2b1y && pm1b1y < pm2b2y) ||
-- (pm1b2x > pm2b1x && pm1b2x < pm2b2x &&
-- pm1b1y > pm2b1y && pm1b1y < pm2b2y) ||
-- (pm1b1x > pm2b1x && pm1b2x < pm2b2x &&
-- pm1b2y > pm2b1y && pm1b2y < pm2b2y) ||
-- (pm1b2x > pm2b1x && pm1b2x < pm2b2x &&
-- pm1b2y > pm2b1y && pm1b2y < pm2b2y)
in2 =
(pm2b1x > pm1b1x && pm2b1x < pm1b2x &&
pm2b1y > pm1b1y && pm2b1y < pm1b2y) ||
(pm2b2x > pm1b1x && pm2b2x < pm1b2x &&
pm2b1y > pm1b1y && pm2b1y < pm1b2y) ||
(pm2b1x > pm1b1x && pm2b2x < pm1b2x &&
pm2b2y > pm1b1y && pm2b2y < pm1b2y) ||
(pm2b2x > pm1b1x && pm2b2x < pm1b2x &&
pm2b2y > pm1b1y && pm2b2y < pm1b2y)
(pm1b1x - pm2b2x <= 0 ||
pm2b1x - pm1b2x <= 0) &&
(pm1b1y - pm2b2y <= 0 ||
pm2b1y - pm1b2y <= 0)
-- (pm2b1x > pm1b1x && pm2b1x < pm1b2x &&
-- pm2b1y > pm1b1y && pm2b1y < pm1b2y) ||
-- (pm2b2x > pm1b1x && pm2b2x < pm1b2x &&
-- pm2b1y > pm1b1y && pm2b1y < pm1b2y) ||
-- (pm2b1x > pm1b1x && pm2b2x < pm1b2x &&
-- pm2b2y > pm1b1y && pm2b2y < pm1b2y) ||
-- (pm2b2x > pm1b1x && pm2b2x < pm1b2x &&
-- pm2b2y > pm1b1y && pm2b2y < pm1b2y)
in
in2 || in1
tx =
@ -159,13 +168,13 @@ class (Show c, Mass c) => Collidible c where
any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22]
res = case (tx < dt, ty < dt, tx < ty, coll True, coll False) of
(True, _, True, True, _) ->
CollisionImminent tx (V2 (floor $ signum d1x) 0)
CollisionImminent tx (V2 (floor $ signum dpx) 0)
(_, True, False, _, True) ->
CollisionImminent ty (V2 0 (floor $ signum d1y))
(True, _, False, True, False) ->
CollisionImminent tx (V2 (floor $ signum d1x) 0)
(_, True, True, False, True) ->
CollisionImminent ty (V2 0 (floor $ signum d1y))
CollisionImminent ty (V2 0 (floor $ signum dpy))
-- (True, _, False, True, False) ->
-- CollisionImminent tx (V2 (floor $ signum d1x) 0)
-- (_, True, True, False, True) ->
-- CollisionImminent ty (V2 0 (floor $ signum d1y))
(_, _, _, False, False) ->
NoCollision
(_, _, True, _, _) ->
@ -177,43 +186,60 @@ class (Show c, Mass c) => Collidible c where
<> fromString (show x)
in
case res of
CollisionImminent _ _ ->
res
NoCollision ->
c ->
if overlap
then
let xoverlap = floor $ -- (maximum (filter (0 >)
-- [
pm2b2x - pm2b1x
-- , pm2b1x - pm1b2x
-- ]))
yoverlap = floor $ -- (maximum (filter (0 >)
-- [
pm2b1y - pm1b2y
-- , pm2b2y - pm1b1y
-- ]))
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 xoverlap < yoverlap
if abs xoverlap < abs yoverlap
then
if xoverlap < 0
then OverlapCollision
OverlapCollision
(V2 xoverlap 0)
else
NoCollision
else
if yoverlap < 0
then OverlapCollision
OverlapCollision
(V2 0 yoverlap)
else NoCollision
(True, False) ->
OverlapCollision (V2 xoverlap 0)
(False, True) ->
OverlapCollision (V2 0 yoverlap)
(False, False) ->
NoCollision
else NoCollision
c
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.Error
"Premature overlap collision detection"
@ -269,15 +295,9 @@ elasticCollision damping mo1 (mo2, OverlapCollision depth) dt =
-- v1y' = 2 * (m1 * dy + m2 * (-dy)) / (m1 + m2) - dy
v1x' = 2 * (m1 * dx) / (m1 + m2)
v1y' = 2 * (m1 * dy) / (m1 + m2)
nvel = if m1 == recip 0
then V2 0 0
else (damping *) <$>
if m2 == recip 0
then
if dx /= 0
then V2 (-v1x') v1y'
else V2 v1x' (-v1y')
else
V2 v1x' v1y'
nvel
| m1 == recip 0 = V2 0 0
| m2 == recip 0 = V2 dx dy
| otherwise = V2 v1x' v1y'
in
velocityUpdater mo1 nvel

View file

@ -58,11 +58,11 @@ update level dt = liftIO $ do
let res = collisionCheck dt tangible1 tangible2
in
case res of
c@(CollisionImminent _ _) ->
NoCollision -> jacc
c ->
if qInd /= index
then jacc `V.snoc` (qInd, c)
else jacc
_ -> jacc
)
V.empty
indexedTangibles
@ -71,7 +71,13 @@ update level dt = liftIO $ do
then iacc
else iacc `V.snoc`
( index
, sortOn (collisionTime . snd) (V.toList partners)
, sortOn
(\(_, cr) -> case cr of
CollisionImminent ddt _ -> ddt
OverlapCollision _ -> 0
NoCollision -> dt
)
(V.toList partners)
)
)
V.empty