```{-# LINE 1 "Physics/Hipmunk/Internal.hsc" #-}
-----------------------------------------------------------------------------
{-# LINE 2 "Physics/Hipmunk/Internal.hsc" #-}
-- |
-- Module      :  Physics/Hipmunk/Internal.hsc
-- Copyright   :  (c) 2008-2010 Felipe A. Lessa
-- License     :  MIT (see LICENSE)
--
-- Maintainer  :  felipe.lessa@gmail.com
-- Stability   :  provisional
-- Portability :  portable (needs FFI)
--
-----------------------------------------------------------------------------

module Physics.Hipmunk.Internal
(VectorPtr,

BodyPtr,
Body(..),
unB,

ShapePtr,
Shape(..),
unS,

ConstraintPtr,
Constraint(..),
unC,
Unknown(..),
ConstraintInit,
ConstraintType(..),

SpacePtr,
Space(..),
Callbacks(..),
HandlerFunPtrs,
unP,
retriveShape,
freeHandlerFunPtrs,

Entity(..),

ArbiterPtr,

Contact(..),
ContactPtr
)
where

import qualified Data.Map as M
import Control.Monad (when)
import Data.IORef
import Data.Map (Map)
import Foreign

{-# LINE 54 "Physics/Hipmunk/Internal.hsc" #-}

import Physics.Hipmunk.Common

type VectorPtr = Ptr Vector

-- | A rigid body representing the physical properties of an
--   object, but without a shape. It may help to think of it as a
--   particle that is able to rotate.
newtype Body = B (ForeignPtr Body)
type BodyPtr = Ptr Body

unB :: Body -> ForeignPtr Body
unB (B b) = b

instance Eq Body where
B b1 == B b2 = b1 == b2

instance Ord Body where
B b1 `compare` B b2 = b1 `compare` b2

-- | A collision shape is attached to a 'Body' to define its
--   shape. Multiple shapes may be attached, including
--   overlapping ones (shapes of a body don't generate collisions
--   with each other).
--
--   Note that to have any effect, a 'Shape' must also be
--   added to a 'Space', even if the body was already added.
data Shape = S !(ForeignPtr Shape) !Body
type ShapePtr = Ptr Shape

-- Note also that we have to maintain a reference to the
-- 'Body' to avoid garbage collection in the case that
-- the user doesn't add the body to a space and don't keep
-- a reference (common when adding bodies with infinite mass).
--
-- However, the body doesn't need to keep references to
-- the attached shapes because cpBody do not reference them,
-- so it wouldn't notice at all if they disappeared =).
-- A space would notice, but then the space will keep its
-- own reference the the shape.

unS :: Shape -> ForeignPtr Shape
unS (S s _) = s

instance Eq Shape where
S s1 _ == S s2 _ = s1 == s2

instance Ord Shape where
S s1 _ `compare` S s2 _ = s1 `compare` s2

-- | Represents a constraint between two bodies. Don't forget to
--   add the bodies and the constraint itself to the space.
--   The phantom type indicates the type of the constraint.
data Constraint a = C !(ForeignPtr (Constraint ())) !Body !Body
type ConstraintPtr = Ptr (Constraint ())

unC :: Constraint a -> ForeignPtr (Constraint ())
unC (C j _ _) = j

instance Eq (Constraint a) where
C j1 _ _ == C j2 _ _ = j1 == j2

instance Ord (Constraint a) where
C j1 _ _ `compare` C j2 _ _ = j1 `compare` j2

-- | An unknown constraint \"type\".  Note that this isn't a
--   'ConstraintType' because you can't create a constraint of
--   @Unknown@ type.
data Unknown = Unknown

-- | Type of generic constraint initializar.
type ConstraintInit = ConstraintPtr -> BodyPtr -> BodyPtr -> IO ()

-- | Internal.  Class implemented by all constraint types.
class ConstraintType a where
size  :: a -> Int
init_ :: a -> ConstraintInit
redef :: ConstraintPtr -> Body -> Body -> a -> IO ()

-- | A space is where the simulation really occurs. You add
--   bodies, shapes and constraints to a space and then @step@ it
--   to update it as whole.
data Space = P !(ForeignPtr Space)
!(IORef Entities)   -- Active and static entities
!(IORef Callbacks)  -- Added callbacks
type SpacePtr  = Ptr Space
type Entities  = Map (Ptr ()) (Either (ForeignPtr ()) Shape)
data Callbacks = CBs {cbsDefault  :: HandlerFunPtrs
,cbsHandlers :: Map (CollisionType_, CollisionType_) HandlerFunPtrs
,cbsPostStep :: [FunPtr ()]}
type HandlerFunPtrs = (FunPtr (), FunPtr (), FunPtr (), FunPtr ())
type CollisionType_ = Word32
{-# LINE 155 "Physics/Hipmunk/Internal.hsc" #-}
-- Duplicated to avoid bringing the documentation from Shape module.

unP :: Space -> ForeignPtr Space
unP (P sp _ _) = sp

instance Eq Space where
P s1 _ _ == P s2 _ _ = s1 == s2

instance Ord Space where
P s1 _ _ `compare` P s2 _ _ = s1 `compare` s2

-- | Internal. Retrive a 'Shape' from a 'ShapePtr' and a 'Space'.
retriveShape :: Space -> ShapePtr -> IO Shape
retriveShape (P _ entities _) ptr = do
ent <- readIORef entities
let Just (Right shape) = M.lookup (castPtr ptr) ent
return shape

-- | Internal.  Free all function pointers of this handler.
freeHandlerFunPtrs :: HandlerFunPtrs -> IO ()
freeHandlerFunPtrs (p1,p2,p3,p4) = f p1 >> f p2 >> f p3 >> f p4
where f p = when (p /= nullFunPtr) (freeHaskellFunPtr p)

-- | Type class implemented by entities that can be
--   added to a space.
class Entity a where
-- | Add an entity to a 'Space'. Don't add the same
--   entity twice to a space.
spaceAdd :: Space -> a -> IO ()
-- | Remove an entity from a 'Space'. Don't remove
--   an entity that wasn't added.
spaceRemove :: Space -> a -> IO ()
-- | Internal function.  Retrive the pointer of this entity.
entityPtr :: a -> ForeignPtr a

-- | Arbiters are used within callbacks.  We don't expose them to
-- the user.
data Arbiter = Arbiter
type ArbiterPtr = Ptr Arbiter

-- 'Contact's are an exception to the pattern we've been following
-- as we're going to use StorableArray with them, so we need
-- them to be Storable (like Vector).

-- | A 'Contact' contains information about a collision.
--   It is passed to 'Physics.Hipmunk.Space.Full'.
--
--   The fields 'ctJnAcc' and 'ctJtAcc' do not have any meaningfull
--   value until 'Physics.Hipmunk.Space.step' has returned
--   (i.e. during a call to a callback this information
--   contains garbage), and by extension you can only know
--   the impulse sum after @step@ returns as well.
--
--   /IMPORTANT:/ You may maintain a reference to an array of
--   @Contact@s that was passed to a callback to do any other
--   processing later. However, /a new call to/ @step@ /will/
--   /invalidate any of those arrays!/ Be careful.
data Contact = Contact {
ctPos    :: Position,
-- ^ Position of the collision in world's coordinates.

ctNormal :: Vector,
-- ^ Normal of the collision.

ctDist   :: CpFloat,
-- ^ Penetration distance of the collision.

ctJnAcc  :: CpFloat,
-- ^ Normal component of final impulse applied.
--   (Valid only after @step@ finishes.)

ctJtAcc  :: CpFloat
-- ^ Tangential component of final impulse applied.
--   (Valid only after @step@ finishes.)
}
deriving (Eq, Ord, Show)

type ContactPtr = Ptr Contact

instance Storable Contact where
sizeOf _    = (132)
{-# LINE 242 "Physics/Hipmunk/Internal.hsc" #-}
alignment _ = alignment (undefined :: Vector)
peek ptr    = do
p     <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
{-# LINE 245 "Physics/Hipmunk/Internal.hsc" #-}
n     <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
{-# LINE 246 "Physics/Hipmunk/Internal.hsc" #-}
dist  <- (\hsc_ptr -> peekByteOff hsc_ptr 32) ptr
{-# LINE 247 "Physics/Hipmunk/Internal.hsc" #-}
jnAcc <- (\hsc_ptr -> peekByteOff hsc_ptr 96) ptr
{-# LINE 248 "Physics/Hipmunk/Internal.hsc" #-}
jtAcc <- (\hsc_ptr -> peekByteOff hsc_ptr 104) ptr
{-# LINE 249 "Physics/Hipmunk/Internal.hsc" #-}
return \$ Contact {ctPos    = p
,ctNormal = n
,ctDist   = dist
,ctJnAcc  = jnAcc
,ctJtAcc  = jtAcc}
poke ptr c = do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (ctPos c)
{-# LINE 256 "Physics/Hipmunk/Internal.hsc" #-}
(\hsc_ptr -> pokeByteOff hsc_ptr 16) ptr (ctNormal c)
{-# LINE 257 "Physics/Hipmunk/Internal.hsc" #-}
(\hsc_ptr -> pokeByteOff hsc_ptr 32) ptr (ctDist c)
{-# LINE 258 "Physics/Hipmunk/Internal.hsc" #-}
(\hsc_ptr -> pokeByteOff hsc_ptr 96) ptr (ctJnAcc c)
{-# LINE 259 "Physics/Hipmunk/Internal.hsc" #-}
(\hsc_ptr -> pokeByteOff hsc_ptr 104) ptr (ctJtAcc c)
{-# LINE 260 "Physics/Hipmunk/Internal.hsc" #-}
```