fix collision halfway
This commit is contained in:
parent
d9a0128958
commit
9da16fc6a7
|
@ -55,16 +55,16 @@ class (Show c, Mass c) => Collidible c where
|
||||||
m2p2 = p2 + V2 m2b1x m2b2y
|
m2p2 = p2 + V2 m2b1x m2b2y
|
||||||
m2p3 = p2 + m2b2
|
m2p3 = p2 + m2b2
|
||||||
m2p4 = p2 + V2 m2b2x m2b1y
|
m2p4 = p2 + V2 m2b2x m2b1y
|
||||||
g11 = (m1p1, m1p2)
|
-- g11 = (m1p1, m1p2)
|
||||||
g12 = (m1p2, m1p3)
|
-- g12 = (m1p2, m1p3)
|
||||||
g13 = (m1p3, m1p4)
|
-- g13 = (m1p3, m1p4)
|
||||||
g14 = (m1p4, m1p1)
|
-- g14 = (m1p4, m1p1)
|
||||||
g21 = (m2p1, m2p2)
|
-- g21 = (m2p1, m2p2)
|
||||||
g22 = (m2p2, m2p3)
|
-- g22 = (m2p2, m2p3)
|
||||||
g23 = (m2p3, m2p4)
|
-- g23 = (m2p3, m2p4)
|
||||||
g24 = (m2p4, m2p1)
|
-- g24 = (m2p4, m2p1)
|
||||||
g1s = [g11, g12, g13, g14]
|
-- g1s = [g11, g12, g13, g14]
|
||||||
g2s = [g21, g22, g23, g24]
|
-- g2s = [g21, g22, g23, g24]
|
||||||
b1 =
|
b1 =
|
||||||
( V2
|
( V2
|
||||||
((\(V2 x _) -> x) (if d1x < 0 then m1p1 + ((dt *) <$> d1) else m1p1))
|
((\(V2 x _) -> x) (if d1x < 0 then m1p1 + ((dt *) <$> d1) else m1p1))
|
||||||
|
@ -107,13 +107,13 @@ class (Show c, Mass c) => Collidible c where
|
||||||
in
|
in
|
||||||
in2 || in1
|
in2 || in1
|
||||||
tx =
|
tx =
|
||||||
let p1x = (\(V2 x _) -> x) (if d1x < 0 then m1p1 else m1p2)
|
let p1x = (\(V2 x _) -> x) (if d1x < 0 then m1p1 else m1p4)
|
||||||
p2x = (\(V2 x _) -> x) (if d1x < 0 then m2p2 else m2p1)
|
p2x = (\(V2 x _) -> x) (if d1x < 0 then m2p4 else m2p1)
|
||||||
in
|
in
|
||||||
if d2x - d1x == 0 then dt else (p1x - p2x) / (d2x - d1x)
|
if d2x - d1x == 0 then dt else (p1x - p2x) / (d2x - d1x)
|
||||||
ty =
|
ty =
|
||||||
let p1y = (\(V2 _ y) -> y) (if d1y < 0 then m1p1 else m1p4)
|
let p1y = (\(V2 _ y) -> y) (if d1y < 0 then m1p1 else m1p2)
|
||||||
p2y = (\(V2 _ y) -> y) (if d1y < 0 then m2p4 else m2p1)
|
p2y = (\(V2 _ y) -> y) (if d1y < 0 then m2p2 else m2p1)
|
||||||
in
|
in
|
||||||
if d2y - d1y == 0 then dt else (p1y - p2y) / (d2y - d1y)
|
if d2y - d1y == 0 then dt else (p1y - p2y) / (d2y - d1y)
|
||||||
in
|
in
|
||||||
|
@ -262,18 +262,18 @@ elasticCollision damping mo1 mo2 (Collision ddt (V2 dirx diry)) =
|
||||||
then 0
|
then 0
|
||||||
else -((abs m1y2 + abs m2y1) - abs dy)
|
else -((abs m1y2 + abs m2y1) - abs dy)
|
||||||
in
|
in
|
||||||
(velocityUpdater
|
(velocityUpdater mo1
|
||||||
((positionUpdater mo1)
|
-- ((positionUpdater mo1)
|
||||||
(p1 + ((ddt *) <$> v1)
|
-- (p1 + ((ddt *) <$> v1)
|
||||||
-- if ddt == 0
|
-- -- if ddt == 0
|
||||||
-- then
|
-- -- then
|
||||||
-- if abs bx < abs by
|
-- -- if abs bx < abs by
|
||||||
-- then
|
-- -- then
|
||||||
-- V2 bx 0
|
-- -- V2 bx 0
|
||||||
-- else
|
-- -- else
|
||||||
-- V2 0 by
|
-- -- V2 0 by
|
||||||
-- else
|
-- -- else
|
||||||
-- V2 0 0
|
-- -- V2 0 0
|
||||||
)
|
-- )
|
||||||
)
|
-- )
|
||||||
) nvel
|
) nvel
|
||||||
|
|
|
@ -75,25 +75,25 @@ update level dt = liftIO $ do
|
||||||
modifyTVar
|
modifyTVar
|
||||||
(testPlayer level) $ \(Just pituicat) ->
|
(testPlayer level) $ \(Just pituicat) ->
|
||||||
let playedCat = perform dt pituicat
|
let playedCat = perform dt pituicat
|
||||||
collidedCat =
|
-- collidedCat =
|
||||||
let partner =
|
-- let partner =
|
||||||
V.foldl
|
-- V.foldl
|
||||||
(\acc@(_, ires) (Cast c) ->
|
-- (\acc@(_, ires) (Cast c) ->
|
||||||
let res = collisionCheck dt playedCat c
|
-- let res = collisionCheck dt playedCat c
|
||||||
in
|
-- in
|
||||||
if res /= NoCollision &&
|
-- if res /= NoCollision &&
|
||||||
collisionTime res < collisionTime ires
|
-- collisionTime res < collisionTime ires
|
||||||
then (Cast c, res)
|
-- then (Cast c, res)
|
||||||
else acc
|
-- else acc
|
||||||
)
|
-- )
|
||||||
(V.head updatedCast, NoCollision)
|
-- (V.head updatedCast, NoCollision)
|
||||||
updatedCast
|
-- updatedCast
|
||||||
in
|
-- in
|
||||||
if (collisionTime $ snd partner) == dt
|
-- if (collisionTime $ snd partner) == dt
|
||||||
then playedCat
|
-- then playedCat
|
||||||
else uncurry
|
-- else uncurry
|
||||||
(\(Cast cx) res -> collide playedCat cx res)
|
-- (\(Cast cx) res -> collide playedCat cx res)
|
||||||
partner
|
-- partner
|
||||||
walledCat =
|
walledCat =
|
||||||
performWorldCollision playedCat layer dt
|
performWorldCollision playedCat layer dt
|
||||||
in Just $ move dt walledCat
|
in Just $ move dt walledCat
|
||||||
|
@ -106,22 +106,26 @@ performWorldCollision
|
||||||
-> c -- ^ Updated cast member
|
-> c -- ^ Updated cast member
|
||||||
performWorldCollision c layer dt =
|
performWorldCollision c layer dt =
|
||||||
let partner = V.foldl
|
let partner = V.foldl
|
||||||
(\acc tile ->
|
(\acc@(part, cr) tile ->
|
||||||
let res = collisionCheck dt c tile
|
let res = collisionCheck dt c tile
|
||||||
ret = if isNothing acc
|
ret = if cr == NoCollision && res == NoCollision
|
||||||
then if res /= NoCollision && collisionTime res < dt
|
then
|
||||||
then Just (c, res)
|
acc
|
||||||
else Nothing
|
else
|
||||||
else if res /= NoCollision &&
|
if cr == NoCollision && res /= NoCollision
|
||||||
collisionTime res < collisionTime (snd (fromJust acc))
|
then (tile, res)
|
||||||
then Just (c, res)
|
else
|
||||||
else acc
|
if cr /= NoCollision && res == NoCollision
|
||||||
|
then
|
||||||
|
acc
|
||||||
|
else
|
||||||
|
if collisionTime cr < collisionTime res
|
||||||
|
then acc
|
||||||
|
else (tile, res)
|
||||||
in
|
in
|
||||||
ret
|
ret
|
||||||
)
|
)
|
||||||
Nothing
|
(V.head layer, collisionCheck dt c $ V.head layer)
|
||||||
layer
|
layer
|
||||||
in
|
in
|
||||||
if isNothing partner
|
uncurry (collide c) partner
|
||||||
then c
|
|
||||||
else uncurry (collide c) (fromJust partner)
|
|
||||||
|
|
Loading…
Reference in New Issue