{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE Strict                     #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE ViewPatterns               #-}

module Apecs.Physics.Collision
  ( defaultHandler
  , mkBeginCB, mkSeparateCB, mkPreSolveCB, mkPostSolveCB
  , addPostStepCallback
  ) where

import           Apecs
import           Apecs.Core
import           Control.Monad
import           Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Data.IntMap         as M
import           Data.IORef
import qualified Data.Vector.Unboxed as U
import           Foreign.ForeignPtr  (withForeignPtr)
import           Foreign.Ptr
import qualified Language.C.Inline   as C
import           Linear.V2

import           Apecs.Physics.Body  ()
import           Apecs.Physics.Space ()
import           Apecs.Physics.Types

C.context (phycsCtx `mappend` C.funCtx)
C.include "<chipmunk.h>"
C.include "<chipmunk_structs.h>"

defaultHandler :: CollisionHandler
defaultHandler :: CollisionHandler
defaultHandler = CollisionSource
-> Maybe BeginCB
-> Maybe SeparateCB
-> Maybe PreSolveCB
-> Maybe PostSolveCB
-> CollisionHandler
CollisionHandler (CollisionType -> CollisionSource
Wildcard CollisionType
0) Maybe BeginCB
forall a. Maybe a
Nothing Maybe SeparateCB
forall a. Maybe a
Nothing Maybe PreSolveCB
forall a. Maybe a
Nothing Maybe PostSolveCB
forall a. Maybe a
Nothing

mkCollision :: Ptr Collision -> IO Collision
mkCollision :: Ptr Collision -> IO Collision
mkCollision Ptr Collision
arb = do
  Double
nx <- CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac   (CDouble -> Double) -> IO CDouble -> IO Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [C.exp| double { cpArbiterGetNormal($(cpArbiter* arb)).x } |]
  Double
ny <- CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac   (CDouble -> Double) -> IO CDouble -> IO Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [C.exp| double { cpArbiterGetNormal($(cpArbiter* arb)).y } |]
  Int
ba <- CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt -> Int) -> IO CUInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [C.block| unsigned int { CP_ARBITER_GET_BODIES($(cpArbiter* arb), ba, bb); return (intptr_t) (ba->userData); } |]
  Int
bb <- CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt -> Int) -> IO CUInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [C.block| unsigned int { CP_ARBITER_GET_BODIES($(cpArbiter* arb), ba, bb); return (intptr_t) (bb->userData); } |]
  Int
sa <- CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt -> Int) -> IO CUInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [C.block| unsigned int { CP_ARBITER_GET_SHAPES($(cpArbiter* arb), sa, sb); return (intptr_t) (sa->userData); } |]
  Int
sb <- CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt -> Int) -> IO CUInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [C.block| unsigned int { CP_ARBITER_GET_SHAPES($(cpArbiter* arb), sa, sb); return (intptr_t) (sb->userData); } |]
  Collision -> IO Collision
forall (m :: * -> *) a. Monad m => a -> m a
return (Collision -> IO Collision) -> Collision -> IO Collision
forall a b. (a -> b) -> a -> b
$ Vec -> Entity -> Entity -> Entity -> Entity -> Collision
Collision (Double -> Double -> Vec
forall a. a -> a -> V2 a
V2 Double
nx Double
ny) (Int -> Entity
Entity Int
ba) (Int -> Entity
Entity Int
bb) (Int -> Entity
Entity Int
sa) (Int -> Entity
Entity Int
sb)

mkBeginCB :: MonadIO m => (Collision -> SystemT w IO Bool) -> SystemT w m BeginCB
mkBeginCB :: (Collision -> SystemT w IO Bool) -> SystemT w m BeginCB
mkBeginCB Collision -> SystemT w IO Bool
sys = do
    w
w <- SystemT w m w
forall r (m :: * -> *). MonadReader r m => m r
ask

    let cb :: Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar
cb Ptr Collision
arb Ptr FrnSpace
_ CUInt
_ = do
          Collision
col <- IO Collision -> IO Collision
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Collision -> IO Collision) -> IO Collision -> IO Collision
forall a b. (a -> b) -> a -> b
$ Ptr Collision -> IO Collision
mkCollision Ptr Collision
arb
          Bool
r <- SystemT w IO Bool -> w -> IO Bool
forall w (m :: * -> *) a. SystemT w m a -> w -> m a
runSystem (Collision -> SystemT w IO Bool
sys Collision
col) w
w
          CUChar -> IO CUChar
forall (m :: * -> *) a. Monad m => a -> m a
return (CUChar -> IO CUChar) -> (Bool -> CUChar) -> Bool -> IO CUChar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> CUChar
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CUChar) -> (Bool -> Int) -> Bool -> CUChar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> IO CUChar) -> Bool -> IO CUChar
forall a b. (a -> b) -> a -> b
$ Bool
r

    BeginCB -> SystemT w m BeginCB
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar) -> BeginCB
BeginCB Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar
cb)

mkSeparateCB :: MonadIO m => (Collision -> SystemT w IO ()) -> SystemT w m SeparateCB
mkSeparateCB :: (Collision -> SystemT w IO ()) -> SystemT w m SeparateCB
mkSeparateCB Collision -> SystemT w IO ()
sys = do
    w
w <- SystemT w m w
forall r (m :: * -> *). MonadReader r m => m r
ask

    let cb :: Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()
cb Ptr Collision
arb Ptr FrnSpace
_ CUInt
_ = do
          Collision
col <- IO Collision -> IO Collision
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Collision -> IO Collision) -> IO Collision -> IO Collision
forall a b. (a -> b) -> a -> b
$ Ptr Collision -> IO Collision
mkCollision Ptr Collision
arb
          SystemT w IO () -> w -> IO ()
forall w (m :: * -> *) a. SystemT w m a -> w -> m a
runSystem (Collision -> SystemT w IO ()
sys Collision
col) w
w

    SeparateCB -> SystemT w m SeparateCB
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()) -> SeparateCB
SeparateCB Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()
cb)


mkPreSolveCB :: MonadIO m => (Collision -> SystemT w IO Bool) -> SystemT w m PreSolveCB
mkPreSolveCB :: (Collision -> SystemT w IO Bool) -> SystemT w m PreSolveCB
mkPreSolveCB Collision -> SystemT w IO Bool
sys = (\(BeginCB Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar
cb) -> (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar) -> PreSolveCB
PreSolveCB Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar
cb) (BeginCB -> PreSolveCB)
-> SystemT w m BeginCB -> SystemT w m PreSolveCB
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Collision -> SystemT w IO Bool) -> SystemT w m BeginCB
forall (m :: * -> *) w.
MonadIO m =>
(Collision -> SystemT w IO Bool) -> SystemT w m BeginCB
mkBeginCB Collision -> SystemT w IO Bool
sys

mkPostSolveCB :: MonadIO m => (Collision -> SystemT w IO ()) -> SystemT w m PostSolveCB
mkPostSolveCB :: (Collision -> SystemT w IO ()) -> SystemT w m PostSolveCB
mkPostSolveCB Collision -> SystemT w IO ()
sys = (\(SeparateCB Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()
cb) -> (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()) -> PostSolveCB
PostSolveCB Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()
cb) (SeparateCB -> PostSolveCB)
-> SystemT w m SeparateCB -> SystemT w m PostSolveCB
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Collision -> SystemT w IO ()) -> SystemT w m SeparateCB
forall (m :: * -> *) w.
MonadIO m =>
(Collision -> SystemT w IO ()) -> SystemT w m SeparateCB
mkSeparateCB Collision -> SystemT w IO ()
sys

newCollisionHandler :: SpacePtr -> CollisionHandler -> Int -> IO (Ptr CollisionHandler)
newCollisionHandler :: SpacePtr -> CollisionHandler -> Int -> IO (Ptr CollisionHandler)
newCollisionHandler SpacePtr
spcPtr (CollisionHandler CollisionSource
source Maybe BeginCB
begin Maybe SeparateCB
separate Maybe PreSolveCB
presolve Maybe PostSolveCB
postsolve) (Int -> CIntPtr
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> CIntPtr
ety) =
  SpacePtr
-> (Ptr FrnSpace -> IO (Ptr CollisionHandler))
-> IO (Ptr CollisionHandler)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr SpacePtr
spcPtr ((Ptr FrnSpace -> IO (Ptr CollisionHandler))
 -> IO (Ptr CollisionHandler))
-> (Ptr FrnSpace -> IO (Ptr CollisionHandler))
-> IO (Ptr CollisionHandler)
forall a b. (a -> b) -> a -> b
$ \Ptr FrnSpace
space -> do
    Ptr CollisionHandler
handler <- case CollisionSource
source of
      Between (CollisionType CUIntPtr
cta) (CollisionType CUIntPtr
ctb)
        -> [C.exp| cpCollisionHandler* {cpSpaceAddCollisionHandler($(cpSpace* space), $(uintptr_t cta), $(uintptr_t ctb))}|]
      Wildcard (CollisionType CUIntPtr
ct)
        -> [C.exp| cpCollisionHandler* {cpSpaceAddWildcardHandler($(cpSpace* space), $(uintptr_t ct))}|]


    [C.exp| void { $(cpCollisionHandler* handler)->userData = (void*) $(intptr_t ety) }|]

    Maybe BeginCB -> (BeginCB -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe BeginCB
begin((BeginCB -> IO ()) -> IO ()) -> (BeginCB -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(BeginCB Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar
cb) -> do
      FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar)
funPtr <- IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar))
-> IO
     (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar))
 -> IO
      (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar)))
-> IO
     (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar))
-> IO
     (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar))
forall a b. (a -> b) -> a -> b
$ $(C.mkFunPtr [t| BeginFunc |]) Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar
cb
      let fn :: Ptr ()
fn = FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar)
-> Ptr ()
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar)
funPtr
      [C.exp| void { $(cpCollisionHandler* handler)->beginFunc = $(void* fn) }|]

    Maybe SeparateCB -> (SeparateCB -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe SeparateCB
separate((SeparateCB -> IO ()) -> IO ()) -> (SeparateCB -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(SeparateCB Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()
cb) -> do
      FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ())
funPtr <- IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()))
-> IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()))
 -> IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ())))
-> IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()))
-> IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()))
forall a b. (a -> b) -> a -> b
$ $(C.mkFunPtr [t| SeparateFunc |]) Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()
cb
      let fn :: Ptr ()
fn = FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()) -> Ptr ()
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ())
funPtr
      [C.exp| void { $(cpCollisionHandler* handler)->separateFunc = $(void* fn) }|]

    Maybe PreSolveCB -> (PreSolveCB -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe PreSolveCB
presolve((PreSolveCB -> IO ()) -> IO ()) -> (PreSolveCB -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(PreSolveCB Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar
cb) -> do
      FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar)
funPtr <- IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar))
-> IO
     (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar))
 -> IO
      (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar)))
-> IO
     (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar))
-> IO
     (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar))
forall a b. (a -> b) -> a -> b
$ $(C.mkFunPtr [t| PreSolveFunc |]) Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar
cb
      let fn :: Ptr ()
fn = FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar)
-> Ptr ()
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO CUChar)
funPtr
      [C.exp| void { $(cpCollisionHandler* handler)->preSolveFunc = $(void* fn) }|]

    Maybe PostSolveCB -> (PostSolveCB -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe PostSolveCB
postsolve((PostSolveCB -> IO ()) -> IO ())
-> (PostSolveCB -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(PostSolveCB Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()
cb) -> do
      FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ())
funPtr <- IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()))
-> IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()))
 -> IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ())))
-> IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()))
-> IO (FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()))
forall a b. (a -> b) -> a -> b
$ $(C.mkFunPtr [t| PostSolveFunc |]) Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()
cb
      let fn :: Ptr ()
fn = FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ()) -> Ptr ()
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr (Ptr Collision -> Ptr FrnSpace -> CUInt -> IO ())
funPtr
      [C.exp| void { $(cpCollisionHandler* handler)->postSolveFunc = $(void* fn) }|]

    Ptr CollisionHandler -> IO (Ptr CollisionHandler)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr CollisionHandler
handler

destroyCollisionHandler :: Ptr CollisionHandler -> IO ()
destroyCollisionHandler :: Ptr CollisionHandler -> IO ()
destroyCollisionHandler = [Char] -> Ptr CollisionHandler -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Destroy CollisionHandler not yet implemented"

instance Component CollisionHandler where
  type Storage CollisionHandler = Space CollisionHandler

instance (MonadIO m, Has w m Physics) => Has w m CollisionHandler where
  getStore :: SystemT w m (Storage CollisionHandler)
getStore = (Space Physics -> Space CollisionHandler
forall a b. Space a -> Space b
cast :: Space Physics -> Space CollisionHandler) (Space Physics -> Space CollisionHandler)
-> SystemT w m (Space Physics)
-> SystemT w m (Space CollisionHandler)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemT w m (Space Physics)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore

instance (MonadIO m) => ExplSet m (Space CollisionHandler) where
  explSet :: Space CollisionHandler
-> Int -> Elem (Space CollisionHandler) -> m ()
explSet sp :: Space CollisionHandler
sp@(Space IOMap BodyRecord
_ IOMap (Record Shape)
_ IOMap (Record Constraint)
_ IOMap (Record CollisionHandler)
hMap SpacePtr
spcPtr) Int
ety Elem (Space CollisionHandler)
handler = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Space CollisionHandler -> Int -> IO ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy Space CollisionHandler
sp Int
ety
    Ptr CollisionHandler
hPtr <- SpacePtr -> CollisionHandler -> Int -> IO (Ptr CollisionHandler)
newCollisionHandler SpacePtr
spcPtr Elem (Space CollisionHandler)
CollisionHandler
handler Int
ety
    IOMap (Record CollisionHandler)
-> (IntMap (Record CollisionHandler)
    -> IntMap (Record CollisionHandler))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IOMap (Record CollisionHandler)
hMap (Int
-> Record CollisionHandler
-> IntMap (Record CollisionHandler)
-> IntMap (Record CollisionHandler)
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
ety (Ptr CollisionHandler -> CollisionHandler -> Record CollisionHandler
forall a. Ptr a -> a -> Record a
Record Ptr CollisionHandler
hPtr Elem (Space CollisionHandler)
CollisionHandler
handler))

instance (MonadIO m) => ExplDestroy m (Space CollisionHandler) where
  explDestroy :: Space CollisionHandler -> Int -> m ()
explDestroy (Space IOMap BodyRecord
_ IOMap (Record Shape)
_ IOMap (Record Constraint)
_ IOMap (Record CollisionHandler)
hMap SpacePtr
_) Int
ety = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe (Record CollisionHandler)
rd <- Int
-> IntMap (Record CollisionHandler)
-> Maybe (Record CollisionHandler)
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
ety (IntMap (Record CollisionHandler)
 -> Maybe (Record CollisionHandler))
-> IO (IntMap (Record CollisionHandler))
-> IO (Maybe (Record CollisionHandler))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOMap (Record CollisionHandler)
-> IO (IntMap (Record CollisionHandler))
forall a. IORef a -> IO a
readIORef IOMap (Record CollisionHandler)
hMap
    Maybe (Record CollisionHandler)
-> (Record CollisionHandler -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Record CollisionHandler)
rd((Record CollisionHandler -> IO ()) -> IO ())
-> (Record CollisionHandler -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Record Ptr CollisionHandler
c CollisionHandler
_) -> Ptr CollisionHandler -> IO ()
destroyCollisionHandler Ptr CollisionHandler
c IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IOMap (Record CollisionHandler)
-> (IntMap (Record CollisionHandler)
    -> IntMap (Record CollisionHandler))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IOMap (Record CollisionHandler)
hMap (Int
-> IntMap (Record CollisionHandler)
-> IntMap (Record CollisionHandler)
forall a. Int -> IntMap a -> IntMap a
M.delete Int
ety)

instance (MonadIO m) => ExplMembers m (Space CollisionHandler) where
  explMembers :: Space CollisionHandler -> m (Vector Int)
explMembers (Space IOMap BodyRecord
_ IOMap (Record Shape)
_ IOMap (Record Constraint)
_ IOMap (Record CollisionHandler)
hMap SpacePtr
_) = IO (Vector Int) -> m (Vector Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Vector Int) -> m (Vector Int))
-> IO (Vector Int) -> m (Vector Int)
forall a b. (a -> b) -> a -> b
$ [Int] -> Vector Int
forall a. Unbox a => [a] -> Vector a
U.fromList ([Int] -> Vector Int)
-> (IntMap (Record CollisionHandler) -> [Int])
-> IntMap (Record CollisionHandler)
-> Vector Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap (Record CollisionHandler) -> [Int]
forall a. IntMap a -> [Int]
M.keys (IntMap (Record CollisionHandler) -> Vector Int)
-> IO (IntMap (Record CollisionHandler)) -> IO (Vector Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOMap (Record CollisionHandler)
-> IO (IntMap (Record CollisionHandler))
forall a. IORef a -> IO a
readIORef IOMap (Record CollisionHandler)
hMap

instance (MonadIO m) => ExplGet m (Space CollisionHandler) where
  explExists :: Space CollisionHandler -> Int -> m Bool
explExists (Space IOMap BodyRecord
_ IOMap (Record Shape)
_ IOMap (Record Constraint)
_ IOMap (Record CollisionHandler)
hMap SpacePtr
_) Int
ety = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Int -> IntMap (Record CollisionHandler) -> Bool
forall a. Int -> IntMap a -> Bool
M.member Int
ety (IntMap (Record CollisionHandler) -> Bool)
-> IO (IntMap (Record CollisionHandler)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOMap (Record CollisionHandler)
-> IO (IntMap (Record CollisionHandler))
forall a. IORef a -> IO a
readIORef IOMap (Record CollisionHandler)
hMap
  explGet :: Space CollisionHandler -> Int -> m (Elem (Space CollisionHandler))
explGet (Space IOMap BodyRecord
_ IOMap (Record Shape)
_ IOMap (Record Constraint)
_ IOMap (Record CollisionHandler)
hMap SpacePtr
_) Int
ety = IO CollisionHandler -> m CollisionHandler
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CollisionHandler -> m CollisionHandler)
-> IO CollisionHandler -> m CollisionHandler
forall a b. (a -> b) -> a -> b
$ do
    Just (Record Ptr CollisionHandler
_ CollisionHandler
handler) <- Int
-> IntMap (Record CollisionHandler)
-> Maybe (Record CollisionHandler)
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
ety (IntMap (Record CollisionHandler)
 -> Maybe (Record CollisionHandler))
-> IO (IntMap (Record CollisionHandler))
-> IO (Maybe (Record CollisionHandler))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOMap (Record CollisionHandler)
-> IO (IntMap (Record CollisionHandler))
forall a. IORef a -> IO a
readIORef IOMap (Record CollisionHandler)
hMap
    CollisionHandler -> IO CollisionHandler
forall (m :: * -> *) a. Monad m => a -> m a
return CollisionHandler
handler

-- | Add an action that will be executed after the physics engine is done processing the current step. Since you generally cannot modify the physics space while the engine is handling collisions, 'addPostStepCallback' is the primary way of making changes to the physics space with a 'CollisionHandler' in a safe manner.
-- Please note that you should only use this function for callbacks in conjunction with a 'CollisionHandler'!
addPostStepCallback :: (Has w m Physics, MonadIO m) => Int -> SystemT w IO () -> SystemT w m ()
addPostStepCallback :: Int -> SystemT w IO () -> SystemT w m ()
addPostStepCallback (Int -> CInt
forall a. Enum a => Int -> a
toEnum -> CInt
k) SystemT w IO ()
systemCallback= do
  w
w <- SystemT w m w
forall r (m :: * -> *). MonadReader r m => m r
ask
  let callback :: Ptr FrnSpace -> Ptr () -> Ptr () -> IO ()
callback Ptr FrnSpace
_ Ptr ()
_ Ptr ()
_ = SystemT w IO () -> w -> IO ()
forall w (m :: * -> *) a. SystemT w m a -> w -> m a
runSystem SystemT w IO ()
systemCallback w
w
  (Space IOMap BodyRecord
_ IOMap (Record Shape)
_ IOMap (Record Constraint)
_ IOMap (Record CollisionHandler)
_ SpacePtr
spcPtr) :: Space Physics <- SystemT w m (Space Physics)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  IO () -> SystemT w m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SystemT w m ()) -> IO () -> SystemT w m ()
forall a b. (a -> b) -> a -> b
$ SpacePtr -> (Ptr FrnSpace -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr SpacePtr
spcPtr ((Ptr FrnSpace -> IO ()) -> IO ())
-> (Ptr FrnSpace -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr FrnSpace
space -> do
    FunPtr (Ptr FrnSpace -> Ptr () -> Ptr () -> IO ())
funPtr <- IO (FunPtr (Ptr FrnSpace -> Ptr () -> Ptr () -> IO ()))
-> IO (FunPtr (Ptr FrnSpace -> Ptr () -> Ptr () -> IO ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO (FunPtr (Ptr FrnSpace -> Ptr () -> Ptr () -> IO ()))
 -> IO (FunPtr (Ptr FrnSpace -> Ptr () -> Ptr () -> IO ())))
-> IO (FunPtr (Ptr FrnSpace -> Ptr () -> Ptr () -> IO ()))
-> IO (FunPtr (Ptr FrnSpace -> Ptr () -> Ptr () -> IO ()))
forall a b. (a -> b) -> a -> b
$ $(C.mkFunPtr [t| Ptr FrnSpace -> Ptr () -> Ptr () -> IO () |]) Ptr FrnSpace -> Ptr () -> Ptr () -> IO ()
callback
    let fn :: Ptr ()
fn = FunPtr (Ptr FrnSpace -> Ptr () -> Ptr () -> IO ()) -> Ptr ()
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr (Ptr FrnSpace -> Ptr () -> Ptr () -> IO ())
funPtr
    [C.block| void {
      int *data = 0;
      cpSpaceAddPostStepCallback($(cpSpace *space), $(void*fn),$(int k), &data);
    } |]
  () -> SystemT w m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()