pituicat/src/Classes/Physics/Collidible.hs

119 lines
3.7 KiB
Haskell

{-# LANGUAGE AllowAmbiguousTypes #-}
module Classes.Physics.Collidible where
import Linear
-- internal imports
import Classes.Physics.Mass
-- | Typeclass for implementing collision results on objects.
class (Show c, Mass c) => Collidible c where
-- | returns the bottom left and top right corners relative to the objects
-- positional vector of the axis aligned bounding box (AABB) serving here
-- as collision boundaries.
boundary
:: c -- ^ Object
-> ( V2 Double -- ^ Bottom left corner of AABB relative to position
, V2 Double -- ^ Top right corner of AABB relative to position
)
collisionCheck
:: (Collidible other)
=> Double -- ^ Time step length
-> c -- ^ First object
-> other -- ^ second object
-> Bool -- ^ Do the objects collide?
collisionCheck dt m1 m2 =
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
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
:: (Collidible other)
=> c -- ^ Original object
-> other -- ^ Collision partner
-> c -- ^ Updated original object
collide = elasticCollision 1
-- | Implementation of a dampened elastic collision used as default collision
-- implementation of the collision reaction
elasticCollision
:: (Collidible c1, Collidible c2)
=> Double
-> c1
-> c2
-> c1
elasticCollision damping mo1 mo2 =
let (V2 v1x v1y) = velocity mo1
(V2 v2x v2y) = velocity mo2
p1@(V2 p1x p1y) = position mo1
p2 = position mo2
(V2 m1x1 m1y1, V2 m1x2 m1y2) = boundary mo1
(V2 m2x1 m2y1, V2 m2x2 m2y2) = boundary mo2
m1 = mass mo1
m2 = mass mo2
v1x' = 2 * (m1 * v1x + m2 * v2x) / (m1 + m2) - v1x
v1y' = 2 * (m1 * v1y + m2 * v2y) / (m1 + m2) - v1y
(V2 dx dy) = p2 - p1
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 (V2 (-v1x) v1y)
else (V2 v1x (-v1y))
else (V2 v1x' v1y')
in
(velocityUpdater mo1) nvel