Compare commits

...

2 Commits

Author SHA1 Message Date
nek0 ac8b892fda wörk wörk 2021-07-27 01:51:51 +02:00
nek0 b53d93b608 trying to shove things around 2021-07-26 06:28:40 +02:00
3 changed files with 103 additions and 64 deletions

View File

@ -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,33 +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
[ pm2b2x - pm2b1x (min 0 $ pm2b2x - pm2b1x)
, pm2b1x - pm1b2x (min 0 $ pm2b1x - pm1b2x)
])) yoverlap = floor $ max
yoverlap = floor (maximum (filter (0 >) (min 0 $ pm2b1y - pm1b2y)
[ pm2b1y - pm1b2y (min 0 $ pm2b2y - pm1b1y)
, pm2b2y - pm1b1y
]))
in in
if xoverlap < yoverlap case (xoverlap < 0, yoverlap < 0) of
then (True, True) ->
if xoverlap < 0 if abs xoverlap < abs yoverlap
then OverlapCollision then
(V2 xoverlap 0) OverlapCollision
else (V2 xoverlap 0)
NoCollision else
else OverlapCollision
if yoverlap < 0 (V2 0 yoverlap)
then OverlapCollision (True, False) ->
(V2 0 yoverlap) OverlapCollision (V2 xoverlap 0)
else NoCollision (False, True) ->
else NoCollision OverlapCollision (V2 0 yoverlap)
(False, False) ->
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.log
A.Error A.Error
"Premature overlap collision detection" "Premature overlap collision detection"
@ -255,17 +291,13 @@ elasticCollision damping mo1 (mo2, OverlapCollision depth) dt =
let m1 = mass mo1 let m1 = mass mo1
m2 = mass mo2 m2 = mass mo2
(V2 dx dy) = (/ dt) . fromIntegral <$> depth (V2 dx dy) = (/ dt) . fromIntegral <$> depth
v1x' = 2 * (m1 * dx + m2 * (-dx)) / (m1 + m2) - dx -- v1x' = 2 * (m1 * dx + m2 * (-dx)) / (m1 + m2) - dx
v1y' = 2 * (m1 * dy + m2 * (-dy)) / (m1 + m2) - dy -- v1y' = 2 * (m1 * dy + m2 * (-dy)) / (m1 + m2) - dy
nvel = if m1 == recip 0 v1x' = 2 * (m1 * dx) / (m1 + m2)
then V2 0 0 v1y' = 2 * (m1 * dy) / (m1 + m2)
else (damping *) <$> nvel
if m2 == recip 0 | m1 == recip 0 = V2 0 0
then | m2 == recip 0 = V2 dx dy
if dx /= 0 | otherwise = V2 v1x' v1y'
then V2 (-v1x') v1y'
else V2 v1x' (-v1y')
else
V2 v1x' v1y'
in in
velocityUpdater mo1 nvel velocityUpdater mo1 nvel

View File

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

View File

@ -174,6 +174,7 @@ instance Mass Pituicat where
move dt cat = move dt cat =
let dpos = (dt *) <$> velocity cat let dpos = (dt *) <$> velocity cat
mpos = (dt *) <$> mpos = (dt *) <$>
-- pcMoveVel cat
(if pcXColl cat then V2 (-1) 1 else V2 1 1) * pcMoveVel cat (if pcXColl cat then V2 (-1) 1 else V2 1 1) * pcMoveVel cat
in in
positionUpdater cat (position cat + dpos + mpos) positionUpdater cat (position cat + dpos + mpos)