haskanoid-0.1.2: src/Objects.hs

-- | Game objects and collisions.
module Objects where

import FRP.Yampa.VectorSpace

import Data.Extra.Num
import Physics.TwoDimensions.Dimensions
import Physics.TwoDimensions.Collisions
import Physics.TwoDimensions.Physics

import Constants

-- * Objects

type ObjectName = String

-- | Objects have logical properties (ID, kind, dead, hit), shape properties
-- (kind), physical properties (kind, pos, vel, acc) and collision properties
-- (hit, 'canCauseCollisions', energy, displaced).
data Object = Object { objectName           :: ObjectName
                     , objectKind           :: ObjectKind
                     , objectPos            :: Pos2D
                     , objectVel            :: Vel2D
                     , objectAcc            :: Acc2D
                     , objectDead           :: Bool
                     , objectHit            :: Bool
                     , canCauseCollisions   :: Bool
                     , collisionEnergy      :: Double
                     , displacedOnCollision :: Bool       -- Theoretically, setting cE == 0 should suffice
                     }
 deriving (Show)

type Objects   = [Object]

-- | The kind of object and any size properties.
--
-- TODO: Use a GADT to separate these properties in two types and guarantee a
-- proper correspondence in 'Object'.
data ObjectKind = Ball    Double -- radius?
                | Paddle  Size2D 
                | Block   Energy Size2D
                | Side    Side
  deriving (Show,Eq)

type Energy = Int

isBall :: ObjectKind -> Bool
isBall (Ball _) = True
isBall _        = False

isBlock :: ObjectKind -> Bool
isBlock (Block {}) = True
isBlock _          = False

isPaddle :: Object -> Bool
isPaddle o = case objectKind o of
  (Paddle _) -> True
  _          -> False

objShape :: Object -> Shape
objShape obj = case objectKind obj of
  (Ball r)    -> Rectangle (p ^-^ (r,r)) (2*r, 2*r)
  (Paddle s)  -> Rectangle p s
  (Block _ s) -> Rectangle p s
  (Side   s)  -> sideToShape p s
 where p = objectPos obj
       width'  = gameWidth
       height' = gameHeight
       d = collisionErrorMargin
       sideToShape p TopSide    = Rectangle (p ^-^ (d, d)) (width' + 2*d, d)
       sideToShape p LeftSide   = Rectangle (p ^-^ (d, d)) (d, height' + 2*d)
       sideToShape p RightSide  = Rectangle (p ^-^ (0, d)) (d, height' + 2*d)
       sideToShape p BottomSide = Rectangle (p ^-^ (d, 0)) (width' + 2*d, d)

-- * Collisions
type Collisions = [Collision]

-- | A collision is a list of objects that collided, plus their velocities as
-- modified by the collision.
-- 
-- Take into account that the same object could take part in several
-- simultaneous collitions, so these velocities should be added (per object).
data Collision = Collision
  { collisionData :: [(ObjectName, Vel2D)] } -- ObjectId x Velocity
 deriving Show

-- | Detects a collision between one object and another regardless of
-- everything else
--
-- FIXME: should we use the last known positions? Or should velocities suffice?
detectCollision :: Object -> Object -> Maybe Collision
detectCollision obj1 obj2
  | overlap obj1 obj2 = Just (collisionResponseObj obj1 obj2)
  | otherwise         = Nothing

overlap obj1 obj2 = overlapShape (objShape obj1) (objShape obj2)

collisionSide :: Object -> Object -> Side
collisionSide obj1 obj2 = shapeCollisionSide (objShape obj1) (objShape obj2)

collisionResponseObj o1 o2 =
  Collision $
    map objectToCollision [(o1, side, o2), (o2, side', o1)]
  where side  = collisionSide o1 o2
        side' = oppositeSide side
        objectReacts      o             = collisionEnergy o > 0 || displacedOnCollision o
        objectToCollision (o,s,o')      = (objectName o, correctVel (objectVel o ^+^ (velTrans *^ objectVel o')) (collisionEnergy o) s)
        correctVel (vx,vy) e TopSide    = (vx, ensurePos (vy * (-e)))
        correctVel (vx,vy) e BottomSide = (vx, ensureNeg (vy * (-e)))
        correctVel (vx,vy) e LeftSide   = (ensureNeg (vx * (-e)),vy)
        correctVel (vx,vy) e RightSide  = (ensurePos (vx * (-e)),vy)