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