137 lines
4.6 KiB
Haskell
137 lines
4.6 KiB
Haskell
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Physics.Classes.Collidible where
|
|
|
|
import Affection as A
|
|
|
|
import Linear
|
|
|
|
-- internal imports
|
|
|
|
import Physics.Classes.Mass
|
|
|
|
data CollisionResult direction
|
|
= NoCollision
|
|
-- | CollisionImminent
|
|
-- { collisionTime :: time
|
|
-- , collisionDirection :: direction
|
|
-- }
|
|
| OverlapCollision
|
|
{ collisionDepth :: direction
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
-- | Typeclass for implementing collision results on objects.
|
|
class (Show c, Mass c) => Collidible c where
|
|
|
|
-- | Final position of the object in the previous timestep
|
|
prevPosition :: c -> V2 Double
|
|
|
|
-- | Aggregated impact forces in a simulation step
|
|
impactForces :: c -> V2 Double
|
|
|
|
-- | Overwrite the impact forces of the mass object
|
|
impactForcesUpdater :: c -> (V2 Double -> c)
|
|
|
|
-- | reset impact forces vector at the beginning of a simulation step
|
|
resetImpactForces :: c -> c
|
|
resetImpactForces c = impactForcesUpdater c (V2 0 0)
|
|
|
|
-- | Add a impact force to the impact forces acting on the mass object
|
|
addImpactForce
|
|
:: c
|
|
-> V2 Double
|
|
-> c
|
|
addImpactForce c force =
|
|
impactForcesUpdater c (impactForces c + force)
|
|
|
|
-- | Flag indicating a collision during the current time step
|
|
collisionOccured :: c -> Bool
|
|
|
|
-- | Update the collision occurence flag
|
|
updateCollisionOccurence :: c -> (Bool -> c)
|
|
|
|
-- | 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
|
|
, V2 Double
|
|
) -- ^ Bottom left and top right corner of AABB relative to position
|
|
|
|
collisionCheck
|
|
:: (Collidible other)
|
|
=> c -- ^ First object
|
|
-> other -- ^ second object
|
|
-> CollisionResult (V2 Double) -- ^ Do the objects collide?
|
|
collisionCheck m1 m2 =
|
|
let (V2 p1x p1y) = position m1
|
|
(V2 p2x p2y) = position m2
|
|
(V2 b1minx b1miny, V2 b1maxx b1maxy) = boundary m1
|
|
(V2 b2minx b2miny, V2 b2maxx b2maxy) = boundary m2
|
|
getCoordinates
|
|
| p1x <= p2x && p1y <= p2y =
|
|
let x1 = p1x + b1maxx
|
|
y1 = p1y + b1maxy
|
|
x2 = p2x + b2minx
|
|
y2 = p2y + b2minx
|
|
in (x1, y1, x2, y2)
|
|
| p1x > p2x && p1y <= p2y =
|
|
let x1 = p1x + b1minx
|
|
y1 = p1y + b1maxy
|
|
x2 = p2x + b2maxx
|
|
y2 = p2y + b2miny
|
|
in (x1, y1, x2, y2)
|
|
| p1x <= p2x && p1y > p2y =
|
|
let x1 = p1x + b1maxx
|
|
y1 = p1y + b1miny
|
|
x2 = p2x + b2minx
|
|
y2 = p2y + b2maxy
|
|
in (x1, y1, x2, y2)
|
|
| otherwise =
|
|
let x1 = p1x + b1minx
|
|
y1 = p1y + b1miny
|
|
x2 = p2x + b2maxx
|
|
y2 = p2y + b2maxy
|
|
in (x1, y1, x2, y2)
|
|
(ox1, oy1, ox2, oy2) = getCoordinates
|
|
in
|
|
if ox2 - ox1 < 0 || oy2 - oy1 < 0
|
|
then OverlapCollision
|
|
(V2
|
|
(min 0 (ox2 - ox1) * (- 1))
|
|
(min 0 (oy2 - oy1) * (- 1))
|
|
)
|
|
else
|
|
NoCollision
|
|
|
|
-- | This Function is called for every collision on both colliding objects.
|
|
collide
|
|
:: (Collidible other)
|
|
=> c -- ^ Original object
|
|
-> [(other, CollisionResult (V2 Double))] -- ^ Collision partners and results
|
|
-> Double -- ^ Timestep length
|
|
-> c -- ^ Updated original object
|
|
collide coll1 collrs dt =
|
|
foldl (\acc a -> elasticCollision 0.9 acc a dt) coll1 collrs
|
|
|
|
-- | Implementation of a dampened elastic collision used as default collision
|
|
-- implementation of the collision reaction
|
|
elasticCollision
|
|
:: (Collidible c1, Collidible c2)
|
|
=> Double -- ^ Restitution coefficient
|
|
-> c1 -- ^ First collision partner
|
|
-> (c2, CollisionResult (V2 Double)) -- ^ Second collision partner with collision result
|
|
-> Double -- ^ Timestep length
|
|
-> c1 -- ^ Updated first collision partner
|
|
elasticCollision _ mo1 (_, NoCollision) _ = mo1
|
|
elasticCollision restitution mo1 (mo2, OverlapCollision depth) dt =
|
|
let dvel = (velocity mo1 - velocity mo2) * normalize depth
|
|
j = (restitution + 1) * (- (dvel `dot` dvel)) /
|
|
(1 / mass mo1 + 1 / mass mo2)
|
|
fi = (* (j / dt)) <$> normalize depth
|
|
in
|
|
positionUpdater (addImpactForce (updateCollisionOccurence mo1 True) fi)
|
|
(position mo1 - depth)
|