pituicat/src/Classes/Physics/Collidible.hs

279 lines
10 KiB
Haskell

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module Classes.Physics.Collidible where
import Affection as A
import Linear
import Data.String (fromString)
import Data.List (minimumBy)
-- internal imports
import Classes.Physics.Mass
data CollisionResult time direction
= NoCollision
| Collision
{ collisionTime :: time
, collisionDirection :: direction
}
deriving (Show, Eq)
-- | 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
-> CollisionResult Double (V2 Int) -- ^ Do the objects collide?
collisionCheck dt m1 m2 =
let d1@(V2 d1x d1y) = velocity m1
d2@(V2 d2x d2y) = 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 = p1 + m1b1
m1p2 = p1 + V2 m1b1x m1b2y
m1p3 = p1 + m1b2
m1p4 = p1 + V2 m1b2x m1b1y
m2p1 = p2 + m2b1
m2p2 = p2 + V2 m2b1x m2b2y
m2p3 = p2 + m2b2
m2p4 = p2 + V2 m2b2x m2b1y
-- g11 = (m1p1, m1p2)
-- g12 = (m1p2, m1p3)
-- g13 = (m1p3, m1p4)
-- g14 = (m1p4, m1p1)
-- g21 = (m2p1, m2p2)
-- g22 = (m2p2, m2p3)
-- g23 = (m2p3, m2p4)
-- g24 = (m2p4, m2p1)
-- g1s = [g11, g12, g13, g14]
-- g2s = [g21, g22, g23, g24]
b1 =
( V2
((\(V2 x _) -> x) (if d1x < 0 then m1p1 + ((dt *) <$> d1) else m1p1))
((\(V2 _ y) -> y) (if d1y < 0 then m1p1 + ((dt *) <$> d1) else m1p1))
, V2
((\(V2 x _) -> x) (if d1x < 0 then m1p3 else m1p3 + ((dt *) <$> d1)))
((\(V2 _ y) -> y) (if d1y < 0 then m1p3 else m1p3 + ((dt *) <$> d1)))
)
b2 =
( V2
((\(V2 x _) -> x) (if d2x < 0 then m2p1 + ((dt *) <$> d2) else m2p1))
((\(V2 _ y) -> y) (if d2y < 0 then m2p1 + ((dt *) <$> d2) else m2p1))
, V2
((\(V2 x _) -> x) (if d2x < 0 then m2p3 else m2p3 + ((dt *) <$> d2)))
((\(V2 _ y) -> y) (if d2y < 0 then m2p3 else m2p3 + ((dt *) <$> d2)))
)
broadphaseOverlap =
let b11@(V2 b1minx b1miny) = fst b1
b12@(V2 b1maxx b1maxy) = snd b1
b21@(V2 b2minx b2miny) = fst b2
b22@(V2 b2maxx b2maxy) = snd b2
in2 =
(b1minx > b2minx && b1minx < b2maxx &&
b1miny > b2miny && b1miny < b2maxy) ||
(b1maxx > b2minx && b1maxx < b2maxx &&
b1miny > b2miny && b1miny < b2maxy) ||
(b1minx > b2minx && b1minx < b2maxx &&
b1maxy > b2miny && b1maxy < b2maxy) ||
(b1maxx > b2minx && b1maxx < b2maxx &&
b1maxy > b2miny && b1maxy < b2maxy)
in1 =
(b2minx > b1minx && b2minx < b1maxx &&
b2miny > b1miny && b2miny < b1maxy) ||
(b2maxx > b1minx && b2maxx < b1maxx &&
b2miny > b1miny && b2miny < b1maxy) ||
(b2minx > b1minx && b2minx < b1maxx &&
b2maxy > b1miny && b2maxy < b1maxy) ||
(b2maxx > b1minx && b2maxx < b1maxx &&
b2maxy > b1miny && b2maxy < b1maxy)
in
in2 || in1
tx =
let p1x = (\(V2 x _) -> x) (if d1x < 0 then m1p1 else m1p4)
p2x = (\(V2 x _) -> x) (if d1x < 0 then m2p4 else m2p1)
in
if d2x - d1x == 0 then dt else (p1x - p2x) / (d2x - d1x)
ty =
let p1y = (\(V2 _ y) -> y) (if d1y < 0 then m1p1 else m1p2)
p2y = (\(V2 _ y) -> y) (if d1y < 0 then m2p2 else m2p1)
in
if d2y - d1y == 0 then dt else (p1y - p2y) / (d2y - d1y)
in
if broadphaseOverlap
then
let collx =
if d1x < 0
then
let (V2 _ g1s) = m1p1 + ((tx *) <$> d1)
(V2 _ g1e) = m1p2 + ((tx *) <$> d1)
(V2 _ g2s) = m2p4 + ((tx *) <$> d2)
(V2 _ g2e) = m2p3 + ((tx *) <$> d2)
s11 = (g1s - g2s) / (g2e - g2s)
s12 = (g1e - g2s) / (g2e - g2s)
s21 = (g2s - g1s) / (g1e - g1s)
s22 = (g2e - g1s) / (g1e - g1s)
in
any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22]
else
let (V2 _ g1s) = m1p4 + ((tx *) <$> d1)
(V2 _ g1e) = m1p3 + ((tx *) <$> d1)
(V2 _ g2s) = m2p1 + ((tx *) <$> d2)
(V2 _ g2e) = m2p2 + ((tx *) <$> d2)
s11 = (g1s - g2s) / (g2e - g2s)
s12 = (g1e - g2s) / (g2e - g2s)
s21 = (g2s - g1s) / (g1e - g1s)
s22 = (g2e - g1s) / (g1e - g1s)
in
any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22]
colly =
if d1y < 0
then
let (V2 g1s _) = m1p1 + ((ty *) <$> d1)
(V2 g1e _) = m1p4 + ((ty *) <$> d1)
(V2 g2s _) = m2p2 + ((ty *) <$> d2)
(V2 g2e _) = m2p3 + ((ty *) <$> d2)
s11 = (g1s - g2s) / (g2e - g2s)
s12 = (g1e - g2s) / (g2e - g2s)
s21 = (g2s - g1s) / (g1e - g1s)
s22 = (g2e - g1s) / (g1e - g1s)
in
any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22]
else
let (V2 g1s _) = m1p2 + ((ty *) <$> d1)
(V2 g1e _) = m1p3 + ((ty *) <$> d1)
(V2 g2s _) = m2p1 + ((ty *) <$> d2)
(V2 g2e _) = m2p4 + ((ty *) <$> d2)
s11 = (g1s - g2s) / (g2e - g2s)
s12 = (g1e - g2s) / (g2e - g2s)
s21 = (g2s - g1s) / (g1e - g1s)
s22 = (g2e - g1s) / (g1e - g1s)
in
any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22]
in
case (tx < dt, ty < dt, tx < ty, collx, colly) of
(_, _, True, True, _) ->
Collision tx (V2 (floor $ signum d1x) 0)
(_, _, False, _, True) ->
Collision ty (V2 0 (floor $ signum d1y))
(_, _, _, False, False) ->
NoCollision
--(True, _, _, False, _) ->
-- NoCollision
-- (_, True, _, _, False) ->
-- NoCollision
-- (False, _, _, _, _) ->
-- NoCollision
-- (_, False, _, _, _) ->
-- NoCollision
else
NoCollision
-- | This Function is called for every collision on both colliding objects.
collide
:: (Collidible other)
=> c -- ^ Original object
-> other -- ^ Collision partner
-> CollisionResult Double (V2 Int) -- ^ Collision reaction
-> 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
-> CollisionResult Double (V2 Int)
-> c1
elasticCollision _ mo1 _ NoCollision = mo1
elasticCollision damping mo1 mo2 (Collision ddt (V2 dirx diry)) =
let v1@(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 dirx > 0
then (V2 (-v1x) v1y)
else (V2 v1x (-v1y))
else (V2 v1x' v1y')
bx = if dx < 0
then
if abs dx > abs m1x1 + abs m2x2 &&
(if dy > 0
then abs dy > abs m1y2 + abs m2y1
else abs dy > abs m1y1 + abs m2y2
)
then 0
else (abs m1x1 + abs m2x2) - abs dx
else
if abs dx > abs m1x2 + abs m2x1 &&
(if dy > 0
then abs dy > abs m1y2 + abs m2y1
else abs dy > abs m1y1 + abs m2y2
)
then 0
else -((abs m1x2 + abs m2x1) - abs dx)
by = if dy < 0
then
if abs dy > abs m1y1 + abs m2y2 &&
(if dx > 0
then abs dx > abs m1x2 + abs m2x1
else abs dx > abs m1x1 + abs m2x2
)
then 0
else (abs m1y1 + abs m2y2) - abs dy
else
if abs dy > abs m1y2 + abs m2y1 &&
(if dx > 0
then abs dx > abs m1x2 + abs m2x1
else abs dx > abs m1x1 + abs m2x2
)
then 0
else -((abs m1y2 + abs m2y1) - abs dy)
in
(velocityUpdater mo1
-- ((positionUpdater mo1)
-- (p1 + ((ddt *) <$> v1)
-- -- if ddt == 0
-- -- then
-- -- if abs bx < abs by
-- -- then
-- -- V2 bx 0
-- -- else
-- -- V2 0 by
-- -- else
-- -- V2 0 0
-- )
-- )
) nvel