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.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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue