pituicat/src/Physics/Classes/Collidible.hs

137 lines
4.1 KiB
Haskell
Raw Normal View History

{-# LANGUAGE AllowAmbiguousTypes #-}
2021-01-19 20:46:07 +00:00
{-# LANGUAGE OverloadedStrings #-}
module Physics.Classes.Collidible where
2020-12-27 04:19:51 +00:00
2021-01-19 20:46:07 +00:00
import Affection as A
2020-12-27 04:19:51 +00:00
import Linear
2021-01-19 20:46:07 +00:00
import Data.String (fromString)
2021-07-25 13:51:42 +00:00
import Data.List (sortBy)
-- internal imports
import Physics.Classes.Mass
2021-01-17 19:29:27 +00:00
data CollisionResult time direction
2021-01-17 01:30:45 +00:00
= NoCollision
2021-07-25 13:51:42 +00:00
| CollisionImminent
2021-02-27 15:08:45 +00:00
{ collisionTime :: time
, collisionDirection :: direction
}
2021-07-25 13:51:42 +00:00
| OverlapCollision
{ collisionDepth :: direction
}
2021-01-17 01:30:45 +00:00
deriving (Show, Eq)
2020-12-27 04:19:51 +00:00
-- | Typeclass for implementing collision results on objects.
class (Show c, Mass c) => Collidible c where
2020-12-27 04:19:51 +00:00
-- | 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
-- | 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.
2020-12-27 04:19:51 +00:00
boundary
:: c -- ^ Object
2021-07-09 17:49:09 +00:00
-> ( V2 Double
, V2 Double
) -- ^ Bottom left and top right corner of AABB relative to position
collisionCheck
:: (Collidible other)
=> c -- ^ First object
2021-01-17 19:29:27 +00:00
-> other -- ^ second object
-> CollisionResult Double (V2 Int) -- ^ Do the objects collide?
collisionCheck m1 m2 =
2021-08-31 00:15:33 +00:00
let p1@(V2 p1x p1y) = position m1
p2@(V2 p2x p2y) = position m2
v1@(V2 v1x v1y) = velocity m1
v2@(V2 v2x v2y) = velocity m2
(V2 dvx dvy) = v1 - v2
(V2 dx dy) = p1 - p2
in
error "collisionCheck: Not yet implemented!"
-- | This Function is called for every collision on both colliding objects.
2020-12-27 04:19:51 +00:00
collide
:: (Collidible other)
2021-07-24 07:35:41 +00:00
=> c -- ^ Original object
-> [(other, CollisionResult Double (V2 Int))] -- ^ Collision partners and results
-> Double -- ^ Timestep length
-> c -- ^ Updated original object
collide coll1 collrs = elasticCollision 0.9 coll1 (head collrs)
-- | Implementation of a dampened elastic collision used as default collision
-- implementation of the collision reaction
elasticCollision
:: (Collidible c1, Collidible c2)
=> Double
-> c1
2021-07-24 07:35:41 +00:00
-> (c2, CollisionResult Double (V2 Int))
-> Double -- ^ Timestep length
-> c1
2021-07-24 07:35:41 +00:00
elasticCollision _ mo1 (_, NoCollision) _ = mo1
2021-07-25 13:51:42 +00:00
elasticCollision damping mo1 (mo2, CollisionImminent ddt (V2 dirx diry)) dt =
2021-01-17 01:30:45 +00:00
let v1@(V2 v1x v1y) = velocity mo1
(V2 v2x v2y) = velocity mo2
2021-04-17 02:53:21 +00:00
p1 = position mo1
m1 = mass mo1
m2 = mass mo2
v1x' = 2 * (m1 * v1x + m2 * v2x) / (m1 + m2) - v1x
v1y' = 2 * (m1 * v1y + m2 * v2y) / (m1 + m2) - v1y
2021-04-17 02:53:21 +00:00
nvel = if m1 == recip 0
then V2 0 0
else (damping *) <$>
if m2 == recip 0
2021-01-14 22:08:24 +00:00
then
if dirx /= 0
2021-07-09 17:49:09 +00:00
then V2 (-v1x) v1y
else V2 v1x (-v1y)
else V2 v1x' v1y'
2021-01-14 22:08:24 +00:00
in
2021-07-09 17:49:09 +00:00
velocityUpdater
2021-07-24 07:35:41 +00:00
mo1
nvel
2021-07-25 13:51:42 +00:00
elasticCollision damping mo1 (mo2, OverlapCollision depth) dt =
let m1 = mass mo1
m2 = mass mo2
(V2 dx dy) = (/ dt) . fromIntegral <$> depth
v1x' = 2 * (m1 * dx + m2 * (-dx)) / (m1 + m2) - dx
v1y' = 2 * (m1 * dy + m2 * (-dy)) / (m1 + m2) - dy
nvel = if m1 == recip 0
then V2 0 0
2021-07-25 14:14:05 +00:00
else (damping *) <$>
if m2 == recip 0
then
if dx /= 0
then V2 (-v1x') v1y'
else V2 v1x' (-v1y')
else
V2 v1x' v1y'
2021-07-25 13:51:42 +00:00
in
velocityUpdater mo1 nvel