module Physics.Hipmunk.Space
(
Space,
newSpace,
freeSpace,
Entity(..),
StaticShape(..),
Iterations,
getIterations,
setIterations,
ElasticIterations,
getElasticIterations,
setElasticIterations,
Gravity,
getGravity,
setGravity,
Damping,
getDamping,
setDamping,
TimeStamp,
getTimeStamp,
resizeStaticHash,
resizeActiveHash,
rehashStatic,
QueryType(..),
spaceQuery,
spaceQueryList,
step,
Callback(..),
setDefaultCallback,
addCallback,
removeCallback,
Contact(..),
sumImpulses,
sumImpulsesWithFriction,
)
where
import Control.Exception (bracket)
import Data.Array.Storable
import Data.IORef
import qualified Data.Map as M
import Foreign hiding (new)
import Physics.Hipmunk.Common
import Physics.Hipmunk.Internal
import Physics.Hipmunk.Shape
newSpace :: IO Space
newSpace =
mallocForeignPtrBytes (68) >>= \sp ->
withForeignPtr sp $ \sp_ptr -> do
cpSpaceInit sp_ptr
addForeignPtrFinalizer cpSpaceDestroy sp
entities <- newIORef M.empty
callbacks <- newIORef (Nothing, M.empty)
return (P sp entities callbacks)
foreign import ccall unsafe "wrapper.h"
cpSpaceInit :: SpacePtr -> IO ()
foreign import ccall unsafe "wrapper.h &cpSpaceDestroy"
cpSpaceDestroy :: FunPtr (SpacePtr -> IO ())
freeSpace :: Space -> IO ()
freeSpace (P _ entities callbacks) = do
let err :: a
err = error "Physics.Hipmunk.Space: freeSpace already called here."
writeIORef entities err
(def,cbs) <- readIORef callbacks
writeIORef callbacks err
maybe (return ()) freeHaskellFunPtr def
M.fold ((>>) . freeHaskellFunPtr) (return ()) cbs
class Entity a where
spaceAdd :: Space -> a -> IO ()
spaceRemove :: Space -> a -> IO ()
spaceAddHelper :: (a -> ForeignPtr b)
-> (SpacePtr -> Ptr b -> IO ())
-> (a -> Maybe Shape)
-> (Space -> a -> IO ())
spaceAddHelper get add toShape =
\(P sp entities _) new_c ->
let new = get new_c
key = unsafeForeignPtrToPtr $ castForeignPtr new
val = case toShape new_c of
Just shape -> Right shape
Nothing -> Left (castForeignPtr new)
in withForeignPtr sp $ \sp_ptr ->
withForeignPtr new $ \new_ptr -> do
add sp_ptr new_ptr
modifyIORef entities (M.insert key val)
spaceRemoveHelper :: (a -> ForeignPtr b)
-> (SpacePtr -> Ptr b -> IO ())
-> (Space -> a -> IO ())
spaceRemoveHelper get remove =
\(P sp entities _) old_c -> do
let old = get old_c
key = unsafeForeignPtrToPtr $ castForeignPtr old
modifyIORef entities (M.delete key)
withForeignPtr sp $ \sp_ptr ->
withForeignPtr old $ \old_ptr ->
remove sp_ptr old_ptr
instance Entity Body where
spaceAdd = spaceAddHelper unB cpSpaceAddBody (const Nothing)
spaceRemove = spaceRemoveHelper unB cpSpaceRemoveBody
foreign import ccall unsafe "wrapper.h"
cpSpaceAddBody :: SpacePtr -> BodyPtr -> IO ()
foreign import ccall unsafe "wrapper.h"
cpSpaceRemoveBody :: SpacePtr -> BodyPtr -> IO ()
instance Entity Shape where
spaceAdd = spaceAddHelper unS cpSpaceAddShape Just
spaceRemove = spaceRemoveHelper unS cpSpaceRemoveShape
foreign import ccall unsafe "wrapper.h"
cpSpaceAddShape :: SpacePtr -> ShapePtr -> IO ()
foreign import ccall unsafe "wrapper.h"
cpSpaceRemoveShape :: SpacePtr -> ShapePtr -> IO ()
instance Entity Joint where
spaceAdd = spaceAddHelper unJ cpSpaceAddJoint (const Nothing)
spaceRemove = spaceRemoveHelper unJ cpSpaceRemoveJoint
foreign import ccall unsafe "wrapper.h"
cpSpaceAddJoint :: SpacePtr -> JointPtr -> IO ()
foreign import ccall unsafe "wrapper.h"
cpSpaceRemoveJoint :: SpacePtr -> JointPtr -> IO ()
newtype StaticShape = Static {unStatic :: Shape}
instance Entity StaticShape where
spaceAdd = spaceAddHelper (unS . unStatic) cpSpaceAddStaticShape (Just . unStatic)
spaceRemove = spaceRemoveHelper (unS . unStatic) cpSpaceRemoveStaticShape
foreign import ccall unsafe "wrapper.h"
cpSpaceAddStaticShape :: SpacePtr -> ShapePtr -> IO ()
foreign import ccall unsafe "wrapper.h"
cpSpaceRemoveStaticShape :: SpacePtr -> ShapePtr -> IO ()
type Iterations = Int32
getIterations :: Space -> IO Iterations
getIterations (P sp _ _) =
withForeignPtr sp (\hsc_ptr -> peekByteOff hsc_ptr 0)
setIterations :: Space -> Iterations -> IO ()
setIterations (P sp _ _) it =
withForeignPtr sp $ \sp_ptr -> do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) sp_ptr it
type ElasticIterations = Int32
getElasticIterations :: Space -> IO ElasticIterations
getElasticIterations (P sp _ _) =
withForeignPtr sp (\hsc_ptr -> peekByteOff hsc_ptr 4)
setElasticIterations :: Space -> ElasticIterations -> IO ()
setElasticIterations (P sp _ _) it =
withForeignPtr sp $ \sp_ptr -> do
(\hsc_ptr -> pokeByteOff hsc_ptr 4) sp_ptr it
type Gravity = Vector
getGravity :: Space -> IO Gravity
getGravity (P sp _ _) =
withForeignPtr sp (\hsc_ptr -> peekByteOff hsc_ptr 8)
setGravity :: Space -> Gravity -> IO ()
setGravity (P sp _ _) g =
withForeignPtr sp $ \sp_ptr -> do
(\hsc_ptr -> pokeByteOff hsc_ptr 8) sp_ptr g
type Damping = CpFloat
getDamping :: Space -> IO Damping
getDamping (P sp _ _) =
withForeignPtr sp (\hsc_ptr -> peekByteOff hsc_ptr 16)
setDamping :: Space -> Damping -> IO ()
setDamping (P sp _ _) dm =
withForeignPtr sp $ \sp_ptr -> do
(\hsc_ptr -> pokeByteOff hsc_ptr 16) sp_ptr dm
type TimeStamp = Int32
getTimeStamp :: Space -> IO TimeStamp
getTimeStamp (P sp _ _) =
withForeignPtr sp (\hsc_ptr -> peekByteOff hsc_ptr 20)
resizeStaticHash :: Space -> CpFloat -> Int32 -> IO ()
resizeStaticHash (P sp _ _) dim count =
withForeignPtr sp $ \sp_ptr -> do
cpSpaceResizeStaticHash sp_ptr dim count
foreign import ccall unsafe "wrapper.h"
cpSpaceResizeStaticHash :: SpacePtr -> CpFloat
-> Int32 -> IO ()
resizeActiveHash :: Space -> CpFloat -> Int32 -> IO ()
resizeActiveHash (P sp _ _) dim count =
withForeignPtr sp $ \sp_ptr -> do
cpSpaceResizeActiveHash sp_ptr dim count
foreign import ccall unsafe "wrapper.h"
cpSpaceResizeActiveHash :: SpacePtr -> CpFloat
-> Int32 -> IO ()
rehashStatic :: Space -> IO ()
rehashStatic (P sp _ _) =
withForeignPtr sp cpSpaceRehashStatic
foreign import ccall unsafe "wrapper.h"
cpSpaceRehashStatic :: SpacePtr -> IO ()
data QueryType = ActiveHash | StaticHash | Both
spaceQuery :: Space -> QueryType -> Position -> (Shape -> IO ()) -> IO ()
spaceQuery spce@(P sp _ _) query pos callback =
withForeignPtr sp $ \sp_ptr ->
bracket (makePointQueryFunc cb) freeHaskellFunPtr $ \cb_ptr ->
with pos $ \pos_ptr ->
func sp_ptr pos_ptr cb_ptr
where
func = case query of
ActiveHash -> wrSpaceActiveShapePointQuery
StaticHash -> wrSpaceStaticShapePointQuery
Both -> wrSpaceBothShapePointQuery
cb shape_ptr _ = retriveShape spce shape_ptr >>= callback
type PointQueryFunc = ShapePtr -> Ptr () -> IO ()
type PointQueryFuncPtr = FunPtr PointQueryFunc
foreign import ccall "wrapper"
makePointQueryFunc :: PointQueryFunc -> IO PointQueryFuncPtr
foreign import ccall safe "wrapper.h"
wrSpaceActiveShapePointQuery
:: SpacePtr -> VectorPtr -> PointQueryFuncPtr -> IO ()
foreign import ccall safe "wrapper.h"
wrSpaceStaticShapePointQuery
:: SpacePtr -> VectorPtr -> PointQueryFuncPtr -> IO ()
foreign import ccall safe "wrapper.h"
wrSpaceBothShapePointQuery
:: SpacePtr -> VectorPtr -> PointQueryFuncPtr -> IO ()
spaceQueryList :: Space -> QueryType -> Position -> IO [Shape]
spaceQueryList spce query pos = do
var <- newIORef []
spaceQuery spce query pos $ modifyIORef var . (:)
readIORef var
step :: Space -> Time -> IO ()
step (P sp _ _) dt =
withForeignPtr sp $ \sp_ptr -> do
cpSpaceStep sp_ptr dt
foreign import ccall safe
cpSpaceStep :: SpacePtr -> Time -> IO ()
data Callback = Full (Shape -> Shape -> StorableArray Int Contact
-> CpFloat -> IO Bool)
| Basic (Shape -> Shape -> IO Bool)
| Constant !Bool
type ChipmunkCB = ShapePtr -> ShapePtr -> ContactPtr -> Int32
-> CpFloat -> Ptr () -> IO Int
type ChipmunkCBPtr = FunPtr ChipmunkCB
adaptChipmunkCB :: Space -> Callback
-> IO (ChipmunkCBPtr, Ptr (), Maybe (FunPtr ()))
adaptChipmunkCB _ (Constant bool) =
let data_ = intPtrToPtr (if bool then 1 else 0)
in return (wrConstantCallback, data_, Nothing)
adaptChipmunkCB spce (Basic basic) = makeChipmunkCB' $
\ptr1 ptr2 _ _ _ _ -> do
shape1 <- retriveShape spce ptr1
shape2 <- retriveShape spce ptr2
okay <- basic shape1 shape2
return (if okay then 1 else 0)
adaptChipmunkCB spce (Full full) = makeChipmunkCB' $
\ptr1 ptr2 cont_ptr cont_num normal_coef _ -> do
shape1 <- retriveShape spce ptr1
shape2 <- retriveShape spce ptr2
cont_fptr <- newForeignPtr_ cont_ptr
let bounds = (0, fromIntegral $ cont_num1)
array <- unsafeForeignPtrToStorableArray cont_fptr bounds
okay <- full shape1 shape2 array normal_coef
return (if okay then 1 else 0)
makeChipmunkCB' :: ChipmunkCB
-> IO (ChipmunkCBPtr, Ptr (), Maybe (FunPtr ()))
makeChipmunkCB' f = do
f' <- makeChipmunkCB f
return (f', nullPtr, Just $ castFunPtr f')
foreign import ccall "wrapper"
makeChipmunkCB :: ChipmunkCB -> IO ChipmunkCBPtr
foreign import ccall unsafe "wrapper.h &wrConstantCallback"
wrConstantCallback :: ChipmunkCBPtr
retriveShape :: Space -> ShapePtr -> IO Shape
retriveShape (P _ entities _) ptr = do
ent <- readIORef entities
Right shape <- M.lookup (castPtr ptr) ent
return shape
setDefaultCallback :: Space -> Callback -> IO ()
setDefaultCallback spce@(P sp _ callbacks) func = do
(cb,data_,hask) <-
case func of
Constant True -> return (nullFunPtr, nullPtr, Nothing)
_ -> adaptChipmunkCB spce func
(def,cbs) <- readIORef callbacks
case def of
Nothing -> return ()
Just ptr -> freeHaskellFunPtr ptr
writeIORef callbacks (hask,cbs)
withForeignPtr sp $ \sp_ptr -> do
cpSpaceSetDefaultCollisionPairFunc sp_ptr cb data_
foreign import ccall unsafe "wrapper.h"
cpSpaceSetDefaultCollisionPairFunc
:: SpacePtr -> ChipmunkCBPtr -> Ptr () -> IO ()
addCallback :: Space -> (CollisionType, CollisionType) -> Callback -> IO ()
addCallback spce@(P sp _ callbacks) (cta,ctb) func = do
(cb,data_,hask) <-
case func of
Constant False -> return (nullFunPtr, nullPtr, Nothing)
_ -> adaptChipmunkCB spce func
(def,cbs) <- readIORef callbacks
let (old,cbs') = M.updateLookupWithKey (\_ _ -> hask) (cta,ctb) cbs
case old of
Nothing -> return ()
Just ptr -> freeHaskellFunPtr ptr
writeIORef callbacks (def,cbs')
withForeignPtr sp $ \sp_ptr -> do
cpSpaceAddCollisionPairFunc sp_ptr cta ctb cb data_
foreign import ccall unsafe "wrapper.h"
cpSpaceAddCollisionPairFunc
:: SpacePtr -> CollisionType -> CollisionType
-> ChipmunkCBPtr -> Ptr () -> IO ()
removeCallback :: Space -> (CollisionType, CollisionType) -> IO ()
removeCallback (P sp _ callbacks) (cta,ctb) = do
(def,cbs) <- readIORef callbacks
let (old,cbs') = M.updateLookupWithKey (\_ _ -> Nothing) (cta,ctb) cbs
case old of
Nothing -> return ()
Just ptr -> freeHaskellFunPtr ptr
writeIORef callbacks (def,cbs')
withForeignPtr sp $ \sp_ptr -> do
cpSpaceRemoveCollisionPairFunc sp_ptr cta ctb
foreign import ccall unsafe "wrapper.h"
cpSpaceRemoveCollisionPairFunc
:: SpacePtr -> CollisionType -> CollisionType -> IO ()
sumImpulses :: StorableArray Int Contact -> IO Vector
sumImpulses = sumImpulsesInternal wrContactsSumImpulses
foreign import ccall unsafe "wrapper.h"
wrContactsSumImpulses :: ContactPtr -> Int32
-> VectorPtr -> IO ()
sumImpulsesWithFriction :: StorableArray Int Contact -> IO Vector
sumImpulsesWithFriction =
sumImpulsesInternal wrContactsSumImpulsesWithFriction
foreign import ccall unsafe "wrapper.h"
wrContactsSumImpulsesWithFriction :: ContactPtr -> Int32
-> VectorPtr -> IO ()
sumImpulsesInternal :: (ContactPtr -> Int32 -> VectorPtr -> IO ())
-> StorableArray Int Contact -> IO Vector
sumImpulsesInternal func sa = do
(i1,i2) <- getBounds sa
withStorableArray sa $ \sa_ptr ->
with 0 $ \vec_ptr -> do
func sa_ptr (fromIntegral $ i2i1) vec_ptr
peek vec_ptr