reworked collision again
This commit is contained in:
parent
8627f80be2
commit
430e2fff14
|
@ -26,41 +26,56 @@ class (Show c, Mass c) => Collidible c where
|
||||||
-> other -- ^ second object
|
-> other -- ^ second object
|
||||||
-> Bool -- ^ Do the objects collide?
|
-> Bool -- ^ Do the objects collide?
|
||||||
collisionCheck dt m1 m2 =
|
collisionCheck dt m1 m2 =
|
||||||
let (V2 m1x1 m1y1) = position m1 + fst (boundary m1) -- + delta1
|
let d1@(V2 d1x d1y) = (dt *) <$> velocity m1
|
||||||
(V2 m1x2 m1y2) = position m1 + snd (boundary m1) -- + delta1
|
d2@(V2 d2x d2y) = (dt *) <$> velocity m2
|
||||||
(V2 m2x1 m2y1) = position m2 + fst (boundary m2) -- + delta2
|
p1 = position m1
|
||||||
(V2 m2x2 m2y2) = position m2 + snd (boundary m2) -- + delta2
|
p2 = position m2
|
||||||
delta1@(V2 vx1 vy1) = (dt *) <$> velocity m1
|
(m1b1@(V2 m1b1x m1b1y), m1b2@(V2 m1b2x m1b2y)) = boundary m1
|
||||||
delta2@(V2 vx2 vy2) = (dt *) <$> velocity m2
|
(m2b1@(V2 m2b1x m2b1y), m2b2@(V2 m2b2x m2b2y)) = boundary m2
|
||||||
dtx 0 = dt
|
m1p1 = m1b1
|
||||||
dtx vx =
|
m1p2 = V2 m1b1x m1b2y
|
||||||
if vx > 0
|
m1p3 = m1b2
|
||||||
then ((m2x1 + vx2) - (m1x2 + vx1)) / vx
|
m1p4 = V2 m1b2x m1b1y
|
||||||
else ((m1x1 + vx1) - (m2x2 + vx2)) / (-vx)
|
m2p1 = m2b1
|
||||||
dty 0 = dt
|
m2p2 = V2 m2b1x m2b2y
|
||||||
dty vy =
|
m2p3 = m2b2
|
||||||
if vy > 0
|
m2p4 = V2 m2b2x m2b1y
|
||||||
then ((m2y1 + vy2) - (m1y2 + vy1)) / vy
|
quad1 = map (p1 + d1 +) [m1p1, m1p2, m1p3, m1p4]
|
||||||
else ((m1y1 + vy1) - (m2y2 + vy2)) / (-vy)
|
g1 = (m2p1, m2p2)
|
||||||
posColl =
|
g2 = (m2p2, m2p3)
|
||||||
or
|
g3 = (m2p3, m2p4)
|
||||||
[ m1x1 < m2x2 && m1x1 > m2x1
|
g4 = (m2p4, m2p1)
|
||||||
, m1x2 < m2x2 && m1x2 > m2x1
|
gs = map (\(s1, s2) -> (p2 + s1, p2 + s2)) [g1, g2, g3, g4]
|
||||||
, m2x1 < m1x2 && m2x1 > m1x1
|
t (V2 mqpx mqpy) (ps@(V2 mspx mspy), pt@(V2 mtpx mtpy)) =
|
||||||
, m2x2 < m1x2 && m2x2 > m1x1
|
if d1x == 0 && d1y == 0
|
||||||
] && or
|
then dt
|
||||||
[ m1y1 < m2y2 && m1y1 > m2y1
|
else
|
||||||
, m1y2 < m2y2 && m1y2 > m2y1
|
((mtpx - mqpx) * (-(mtpy - mspy)) - (-(mtpx - mspx)) * (mspy - mqpy)) /
|
||||||
, m2y1 < m1y2 && m2y1 > m1y1
|
(d1x * (-(mtpy - mspy)) - (-(mtpx - mspx)) * d1y)
|
||||||
, m2y2 < m1y2 && m2y2 > m1y1
|
s (V2 mqpx mqpy) (ps@(V2 mspx mspy), pt@(V2 mtpx mtpy)) =
|
||||||
]
|
(d1x * (mtpy - mqpy) - (mtpx - mqpx) * d1y) /
|
||||||
|
(d1x * (-(mtpy - mspy)) - (-(mtpx - mspx)) * d1y)
|
||||||
|
inside m =
|
||||||
|
let am = m - (p2 + m2p1)
|
||||||
|
ab = (p2 + m2p2) - (p2 + m2p1)
|
||||||
|
ad = (p2 + m2p4) - (p2 + m2p1)
|
||||||
|
in
|
||||||
|
(0 < am `dot` ab && am `dot` ab < ab `dot` ab) &&
|
||||||
|
(0 < am `dot` ad && am `dot` ad < ad `dot` ad)
|
||||||
in
|
in
|
||||||
-- posColl || (dt > dtx vx1 || dt > dty vy1)
|
any inside quad1 ||
|
||||||
-- (if vx1 == 0 then posColl else dt > dtx vx1)
|
any
|
||||||
(posColl || dt > dtx vx1)
|
(\gx ->
|
||||||
&&
|
any
|
||||||
-- (if vy1 == 0 then posColl else dt > dty vy1)
|
(\q ->
|
||||||
(posColl || dt > dty vy1)
|
let qs = s q gx
|
||||||
|
qt = t q gx
|
||||||
|
in
|
||||||
|
(qs > 0 && qs < 1) && (qt > 0 && qt < dt)
|
||||||
|
)
|
||||||
|
quad1
|
||||||
|
)
|
||||||
|
gs
|
||||||
|
|
||||||
-- | This Function is called for every collision on both colliding objects.
|
-- | This Function is called for every collision on both colliding objects.
|
||||||
collide
|
collide
|
||||||
|
@ -90,29 +105,14 @@ elasticCollision damping mo1 mo2 =
|
||||||
v1x' = 2 * (m1 * v1x + m2 * v2x) / (m1 + m2) - v1x
|
v1x' = 2 * (m1 * v1x + m2 * v2x) / (m1 + m2) - v1x
|
||||||
v1y' = 2 * (m1 * v1y + m2 * v2y) / (m1 + m2) - v1y
|
v1y' = 2 * (m1 * v1y + m2 * v2y) / (m1 + m2) - v1y
|
||||||
(V2 dx dy) = p2 - p1
|
(V2 dx dy) = p2 - p1
|
||||||
np = V2
|
nvel@(V2 nvx nvy) = if m1 == recip 0
|
||||||
( p1x + if v1x == 0
|
|
||||||
then 0
|
|
||||||
else
|
|
||||||
if dx < 0
|
|
||||||
then (abs m2x1 + abs m1x2 - abs dx)
|
|
||||||
else - (abs m2x2 + abs m1x1 - abs dx)
|
|
||||||
)
|
|
||||||
( p1y + if v1y == 0
|
|
||||||
then 0
|
|
||||||
else
|
|
||||||
if dy < 0
|
|
||||||
then (abs m2y1 + abs m1y2 - abs dy)
|
|
||||||
else - (abs m2y2 + abs m1y1 - abs dy)
|
|
||||||
)
|
|
||||||
in
|
|
||||||
(velocityUpdater ((positionUpdater mo1) np))
|
|
||||||
(if m1 == recip 0
|
|
||||||
then V2 0 0
|
then V2 0 0
|
||||||
else (damping *) <$>
|
else (damping *) <$>
|
||||||
if m2 == recip 0
|
if m2 == recip 0
|
||||||
then if abs dy < abs dx
|
then
|
||||||
|
if abs dy < abs dx
|
||||||
then (V2 (-v1x) v1y)
|
then (V2 (-v1x) v1y)
|
||||||
else (V2 v1x (-v1y))
|
else (V2 v1x (-v1y))
|
||||||
else (V2 v1x' v1y')
|
else (V2 v1x' v1y')
|
||||||
)
|
in
|
||||||
|
(velocityUpdater mo1) nvel
|
||||||
|
|
|
@ -59,6 +59,6 @@ class Mass m where
|
||||||
move dt m =
|
move dt m =
|
||||||
let dpos = ((dt *) <$> velocity m)
|
let dpos = ((dt *) <$> velocity m)
|
||||||
in
|
in
|
||||||
if quadrance dpos * sqrt 2 > dt
|
if quadrance dpos > 0.5
|
||||||
then (positionUpdater m) (position m + dpos)
|
then (positionUpdater m) (position m + dpos)
|
||||||
else m
|
else m
|
||||||
|
|
|
@ -22,17 +22,9 @@ singleHandler
|
||||||
-> Affection ()
|
-> Affection ()
|
||||||
singleHandler level event = do
|
singleHandler level event = do
|
||||||
let multiplier = if tmKeyMotion event == SDL.Pressed then 1 else 0
|
let multiplier = if tmKeyMotion event == SDL.Pressed then 1 else 0
|
||||||
changeDirection cat state dirVel =
|
changeDirection cat state =
|
||||||
Just cat
|
Just cat
|
||||||
{ pcMoveState = if multiplier > 0 then Just state else Nothing
|
{ pcMoveState = if multiplier > 0 then Just state else Nothing
|
||||||
, pcVel = if multiplier > 0
|
|
||||||
then pcVel cat + V2 dirVel 0
|
|
||||||
else
|
|
||||||
let (V2 vx vy) = pcVel cat
|
|
||||||
in
|
|
||||||
if abs vx - dirVel < 0
|
|
||||||
then V2 0 vy
|
|
||||||
else V2 (vx - dirVel) vy
|
|
||||||
}
|
}
|
||||||
liftIO $ atomically $ modifyTVar (testPlayer level) (\(Just pituicat) ->
|
liftIO $ atomically $ modifyTVar (testPlayer level) (\(Just pituicat) ->
|
||||||
A.log Debug ("Grounded: " <> fromString (show $ pcGrounded pituicat)) $
|
A.log Debug ("Grounded: " <> fromString (show $ pcGrounded pituicat)) $
|
||||||
|
@ -46,7 +38,7 @@ singleHandler level event = do
|
||||||
)
|
)
|
||||||
else
|
else
|
||||||
Just pituicat
|
Just pituicat
|
||||||
MoveRight -> changeDirection pituicat MoveRight catMoveVelocity
|
MoveRight -> changeDirection pituicat MoveRight
|
||||||
MoveLeft -> changeDirection pituicat MoveLeft (-catMoveVelocity)
|
MoveLeft -> changeDirection pituicat MoveLeft
|
||||||
_ -> Just pituicat
|
_ -> Just pituicat
|
||||||
)
|
)
|
||||||
|
|
|
@ -84,6 +84,7 @@ load level progress = do
|
||||||
|
|
||||||
let pituicat = Pituicat
|
let pituicat = Pituicat
|
||||||
(V2 100 1948)
|
(V2 100 1948)
|
||||||
|
(V2 0 1)
|
||||||
(V2 0 0)
|
(V2 0 0)
|
||||||
(V2 0 0)
|
(V2 0 0)
|
||||||
100
|
100
|
||||||
|
|
|
@ -24,11 +24,12 @@ import Types.Texture
|
||||||
import Types.Subsystems
|
import Types.Subsystems
|
||||||
|
|
||||||
catMoveVelocity :: Double
|
catMoveVelocity :: Double
|
||||||
catMoveVelocity = 1
|
catMoveVelocity = 10
|
||||||
|
|
||||||
data Pituicat = Pituicat
|
data Pituicat = Pituicat
|
||||||
{ pcPos :: V2 Double
|
{ pcPos :: V2 Double
|
||||||
, pcVel :: V2 Double
|
, pcVel :: V2 Double
|
||||||
|
, pcMoveVel :: V2 Double
|
||||||
, pcAcc :: V2 Double
|
, pcAcc :: V2 Double
|
||||||
, pcHealth :: Int
|
, pcHealth :: Int
|
||||||
, pcTexture :: Texture
|
, pcTexture :: Texture
|
||||||
|
@ -39,7 +40,7 @@ data Pituicat = Pituicat
|
||||||
|
|
||||||
instance Drawable Pituicat where
|
instance Drawable Pituicat where
|
||||||
|
|
||||||
toVertices (Pituicat (V2 x y) _ _ _ _ _ _) =
|
toVertices (Pituicat (V2 x y) _ _ _ _ _ _ _) =
|
||||||
( V.fromList [0, 1, 2, 2, 3, 0]
|
( V.fromList [0, 1, 2, 2, 3, 0]
|
||||||
, V.fromList
|
, V.fromList
|
||||||
[ newVertex
|
[ newVertex
|
||||||
|
@ -78,14 +79,18 @@ instance Actor Pituicat where
|
||||||
(p {pcAcc = 0})
|
(p {pcAcc = 0})
|
||||||
(V2 vx vy) = pcVel physCat
|
(V2 vx vy) = pcVel physCat
|
||||||
finalCat = physCat
|
finalCat = physCat
|
||||||
{ pcGrounded = pcGrounded physCat || (vy < 0 && abs vy < 2)
|
{ pcGrounded = (vy <= 0 && abs vy < 30 )
|
||||||
, pcVel = case pcMoveState physCat of
|
, pcMoveVel = case pcMoveState physCat of
|
||||||
Just MoveRight -> V2 (min catMoveVelocity vx) vy
|
Just MoveRight -> V2 catMoveVelocity 0
|
||||||
Just MoveLeft -> V2 (min (-catMoveVelocity) vx) vy
|
Just MoveLeft -> V2 (-catMoveVelocity) 0
|
||||||
_ -> V2 vx vy
|
_ -> V2 0 0
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
(A.log Debug ("moving with " <> fromString (show $ pcVel finalCat))) finalCat
|
(A.log Debug (
|
||||||
|
("being at " <> fromString (show $ pcPos finalCat)) <>
|
||||||
|
("; moving with " <> fromString (show $ pcVel finalCat))
|
||||||
|
)
|
||||||
|
) finalCat
|
||||||
|
|
||||||
instance Mass Pituicat where
|
instance Mass Pituicat where
|
||||||
|
|
||||||
|
@ -99,7 +104,7 @@ instance Mass Pituicat where
|
||||||
}
|
}
|
||||||
)
|
)
|
||||||
|
|
||||||
velocity = pcVel
|
velocity cat = pcVel cat + pcMoveVel cat
|
||||||
|
|
||||||
velocityUpdater cat =
|
velocityUpdater cat =
|
||||||
(\vel -> cat
|
(\vel -> cat
|
||||||
|
@ -131,6 +136,4 @@ instance Collidible Pituicat where
|
||||||
(V2 _ dy) = pcVel ncat
|
(V2 _ dy) = pcVel ncat
|
||||||
in
|
in
|
||||||
ncat
|
ncat
|
||||||
{ pcGrounded = dy > 0 && abs dy < 10
|
|
||||||
}
|
|
||||||
)
|
)
|
||||||
|
|
Loading…
Reference in New Issue