77 lines
2.2 KiB
Haskell
77 lines
2.2 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)
|
|
=> c -- ^ First object
|
|
-> other -- ^ second object
|
|
-> Bool -- ^ Do the objects collide?
|
|
collisionCheck m1 m2 =
|
|
let (V2 m1x1 m1y1) = position m1 + fst (boundary m1)
|
|
(V2 m1x2 m1y2) = position m1 + snd (boundary m1)
|
|
(V2 m2x1 m2y1) = position m2 + fst (boundary m2)
|
|
(V2 m2x2 m2y2) = position m2 + snd (boundary m2)
|
|
in
|
|
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
|
|
]
|
|
|
|
|
|
-- | 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 0.9
|
|
|
|
-- | 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
|
|
m1 = mass mo1
|
|
m2 = mass mo2
|
|
v1x' = 2 * (m1 * v1x + m2 * v2x) / (m1 + m2) - v1x
|
|
v1y' = 2 * (m1 * v1y + m2 * v2y) / (m1 + m2) - v1y
|
|
in
|
|
(velocityUpdater mo1)
|
|
(if m1 == recip 0
|
|
then V2 0 0
|
|
else (damping *) <$>
|
|
if m2 == recip 0
|
|
then negate <$> velocity mo1
|
|
else (V2 v1x' v1y')
|
|
)
|