pituicat/src/Classes/Physics/Collidible.hs

{-# 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 (V2 m1x1 m1y1) = position m1 + fst (boundary m1) -- + delta1
        (V2 m1x2 m1y2) = position m1 + snd (boundary m1) -- + delta1
        (V2 m2x1 m2y1) = position m2 + fst (boundary m2) -- + delta2
        (V2 m2x2 m2y2) = position m2 + snd (boundary m2) -- + delta2
        delta1@(V2 vx1 vy1) = (dt *) <$> velocity m1
        delta2@(V2 vx2 vy2) = (dt *) <$> velocity m2
        dtx 0 = dt
        dtx vx =
          if vx > 0
          then ((m2x1 + vx2) - (m1x2 + vx1)) / vx
          else ((m1x1 + vx1) - (m2x2 + vx2)) / (-vx)
        dty 0 = dt
        dty vy =
          if vy > 0
          then ((m2y1 + vy2) - (m1y2 + vy1)) / vy
          else ((m1y1 + vy1) - (m2y2 + vy2)) / (-vy)
        posColl =
          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
          ]
    in
      -- posColl || (dt > dtx vx1 || dt > dty vy1)
      -- (if vx1 == 0 then posColl else dt > dtx vx1)
      (posColl || dt > dtx vx1)
      &&
      -- (if vy1 == 0 then posColl else dt > dty vy1)
      (posColl || dt > dty vy1)

  -- | 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
      np = V2
        ( p1x + if v1x == 0
          then 0
          else 
            if dx < 0
            then (abs m2x1 + abs m1x2 - abs dx)
            else - (abs m2x2 + abs m1x1 - abs dx)
          )
        ( p1y + if v1y == 0
          then 0
          else 
            if dy < 0
            then (abs m2y1 + abs m1y2 - abs dy)
            else - (abs m2y2 + abs m1y1 - abs dy)
          )
  in
    (velocityUpdater ((positionUpdater mo1) np))
      (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')
        )