module Physics.Hipmunk.Space
(
Space,
newSpace,
freeSpace,
Entity(spaceAdd, spaceRemove),
StaticShape(..),
Iterations,
iterations,
ElasticIterations,
elasticIterations,
Gravity,
gravity,
damping,
TimeStamp,
timeStamp,
resizeStaticHash,
resizeActiveHash,
rehashStatic,
spaceQuery,
spaceQueryList,
step
)
where
import qualified Data.Foldable as F
import qualified Data.Map as M
import Control.Exception (bracket)
import Control.Monad (when)
import Data.IORef
import Data.StateVar
import Foreign hiding (new)
import Foreign.C.Types (CInt)
import Physics.Hipmunk.Common
import Physics.Hipmunk.Internal
import Physics.Hipmunk.Shape
newSpace :: IO Space
newSpace =
mallocForeignPtrBytes (340) >>= \sp ->
withForeignPtr sp $ \sp_ptr -> do
cpSpaceInit sp_ptr
let n = nullFunPtr
entities <- newIORef M.empty
callbacks <- newIORef $ CBs (n,n,n,n) M.empty []
return (P sp entities callbacks)
foreign import ccall unsafe "wrapper.h"
cpSpaceInit :: SpacePtr -> IO ()
freeSpace :: Space -> IO ()
freeSpace (P sp entities callbacks) = do
withForeignPtr sp cpSpaceDestroy
let err :: a
err = error "Physics.Hipmunk.Space: freeSpace already called here."
writeIORef entities err
CBs def cbs post <- readIORef callbacks
writeIORef callbacks err
freeHandlerFunPtrs def
freeAll freeHandlerFunPtrs cbs
freeAll freeHaskellFunPtr post
freeAll :: F.Foldable t => (a -> IO ()) -> t a -> IO ()
freeAll f = F.foldr ((>>) . f) (return ())
foreign import ccall unsafe "wrapper.h"
cpSpaceDestroy :: SpacePtr -> 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
modifyIORef' :: IORef a -> (a -> a) -> IO ()
modifyIORef' var f = do
old <- readIORef var
let new = f old
new `seq` writeIORef var new
instance Entity Body where
spaceAdd = spaceAddHelper unB cpSpaceAddBody (const Nothing)
spaceRemove = spaceRemoveHelper unB cpSpaceRemoveBody
entityPtr = unB
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
entityPtr = unS
foreign import ccall unsafe "wrapper.h"
cpSpaceAddShape :: SpacePtr -> ShapePtr -> IO ()
foreign import ccall safe "wrapper.h"
cpSpaceRemoveShape :: SpacePtr -> ShapePtr -> IO ()
instance Entity (Constraint a) where
spaceAdd = spaceAddHelper unC cpSpaceAddConstraint (const Nothing)
spaceRemove = spaceRemoveHelper unC cpSpaceRemoveConstraint
entityPtr = castForeignPtr . unC
foreign import ccall unsafe "wrapper.h"
cpSpaceAddConstraint :: SpacePtr -> ConstraintPtr -> IO ()
foreign import ccall unsafe "wrapper.h"
cpSpaceRemoveConstraint :: SpacePtr -> ConstraintPtr -> IO ()
newtype StaticShape = Static {unStatic :: Shape}
instance Entity StaticShape where
spaceAdd = spaceAddHelper (unS . unStatic) cpSpaceAddStaticShape (Just . unStatic)
spaceRemove = spaceRemoveHelper (unS . unStatic) cpSpaceRemoveStaticShape
entityPtr = castForeignPtr . unS . unStatic
foreign import ccall unsafe "wrapper.h"
cpSpaceAddStaticShape :: SpacePtr -> ShapePtr -> IO ()
foreign import ccall safe "wrapper.h"
cpSpaceRemoveStaticShape :: SpacePtr -> ShapePtr -> IO ()
type Iterations = CInt
iterations :: Space -> StateVar Iterations
iterations (P sp _ _) = makeStateVar getter setter
where
getter = withForeignPtr sp (\hsc_ptr -> peekByteOff hsc_ptr 0)
setter = withForeignPtr sp . flip (\hsc_ptr -> pokeByteOff hsc_ptr 0)
type ElasticIterations = CInt
elasticIterations :: Space -> StateVar ElasticIterations
elasticIterations (P sp _ _) = makeStateVar getter setter
where
getter = withForeignPtr sp (\hsc_ptr -> peekByteOff hsc_ptr 4)
setter = withForeignPtr sp . flip (\hsc_ptr -> pokeByteOff hsc_ptr 4)
type Gravity = Vector
gravity :: Space -> StateVar Gravity
gravity (P sp _ _) = makeStateVar getter setter
where
getter = withForeignPtr sp (\hsc_ptr -> peekByteOff hsc_ptr 8)
setter = withForeignPtr sp . flip (\hsc_ptr -> pokeByteOff hsc_ptr 8)
damping :: Space -> StateVar Damping
damping (P sp _ _) = makeStateVar getter setter
where
getter = withForeignPtr sp (\hsc_ptr -> peekByteOff hsc_ptr 24)
setter = withForeignPtr sp . flip (\hsc_ptr -> pokeByteOff hsc_ptr 24)
type TimeStamp = CInt
timeStamp :: Space -> GettableStateVar TimeStamp
timeStamp (P sp _ _) = makeGettableStateVar $
withForeignPtr sp (\hsc_ptr -> peekByteOff hsc_ptr 52)
resizeStaticHash :: Space -> Distance -> CInt -> 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
-> CInt -> IO ()
resizeActiveHash :: Space -> Distance -> CInt -> 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
-> CInt -> IO ()
rehashStatic :: Space -> IO ()
rehashStatic (P sp _ _) =
withForeignPtr sp cpSpaceRehashStatic
foreign import ccall unsafe "wrapper.h"
cpSpaceRehashStatic :: SpacePtr -> IO ()
spaceQuery :: Space -> Position -> Layers -> Group -> (Shape -> IO ()) -> IO ()
spaceQuery spce@(P sp _ _) pos layers_ group_ callback =
withForeignPtr sp $ \sp_ptr ->
bracket (makePointQueryFunc cb) freeHaskellFunPtr $ \cb_ptr ->
with pos $ \pos_ptr ->
wrSpacePointQuery sp_ptr pos_ptr layers_ group_ cb_ptr
where
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"
wrSpacePointQuery :: SpacePtr -> VectorPtr -> Layers -> Group
-> PointQueryFuncPtr -> IO ()
spaceQueryList :: Space -> Position -> Layers -> Group -> IO [Shape]
spaceQueryList spce pos layers_ group_ = do
var <- newIORef []
spaceQuery spce pos layers_ group_ $ modifyIORef var . (:)
readIORef var
step :: Space -> Time -> IO ()
step (P sp _ callbacks) dt = do
withForeignPtr sp $ \sp_ptr -> do
cpSpaceStep sp_ptr dt
cbs@(CBs {cbsPostStep = post}) <- readIORef callbacks
when (not $ null post) $ do
freeAll freeHaskellFunPtr post
writeIORef callbacks (cbs {cbsPostStep = []})
foreign import ccall safe
cpSpaceStep :: SpacePtr -> Time -> IO ()