{-# LANGUAGE ForeignFunctionInterface #-}

-- | Producing 'FunPtr' callbacks from Haskell closures, and a ready-made
-- multithreaded task system.
--
-- The generated bindings take callbacks as raw @'FunPtr' Tag@ (see
-- "Box3D.Tags"); this module is the hand-written counterpart that turns an
-- ordinary Haskell function into such a 'FunPtr' via @foreign import "wrapper"@,
-- and frees it again. Every @mk*@ returns a 'FunPtr' the caller must
-- 'freeHaskellFunPtr' (use the @with*@ brackets to get that for free).
--
-- == Threads
--
-- Box3D invokes these callbacks from its solver, which runs on background
-- worker threads when @worldDefWorkerCount@ > 1 — either its own scheduler, or
-- the 'TaskSystem' installed here. A Haskell closure wrapped as a 'FunPtr' is
-- therefore entered concurrently from several non-Haskell OS threads, so the
-- program must be built with the threaded runtime (@-threaded@) and the
-- closure must be thread-safe. Because the solver's task work re-enters Haskell
-- through these callbacks, the task dispatch is a @safe@ call.
module Box3D.Callbacks
  ( -- * Leaf callbacks
    CustomFilter
  , mkCustomFilterFcn
  , withCustomFilterFcn
  , Friction
  , mkFrictionCallback
  , withFrictionCallback
  , Restitution
  , mkRestitutionCallback
  , withRestitutionCallback

    -- * Query and cast visitors
  , OverlapResult
  , withOverlapResultFcn
  , CastResult
  , withCastResultFcn
  , PreSolve
  , withPreSolveFcn
  , PlaneResultVisitor
  , withPlaneResultFcn
  , MoverFilter
  , withMoverFilterFcn
  , CompoundQuery
  , withCompoundQueryFcn
  , MeshQuery
  , withMeshQueryFcn

    -- * Dynamic-tree visitors
  , TreeQuery
  , withTreeQueryFcn
  , TreeQueryClosest
  , withTreeQueryClosestFcn
  , TreeRayCast
  , withTreeRayCastFcn
  , TreeBoxCast
  , withTreeBoxCastFcn

    -- * A multithreaded task system
  , TaskSystem (..)
  , withThreadPoolTaskSystem
  ) where

import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Exception (bracket, finally)
import Data.Vector.Storable (Vector)
import Foreign
import Foreign.C.Types (CBool (..), CChar, CInt (..))

import Box3D.Id (ShapeId (..))
import Box3D.Internal (copyVector)
import Box3D.MathTypes (Pos, Vec3)
import Box3D.Tags
  ( BoxCastInput
  , CastResultFcn
  , CompoundData
  , CompoundQueryFcn
  , CustomFilterFcn
  , FrictionCallback
  , MeshQueryFcn
  , MoverFilterFcn
  , OverlapResultFcn
  , PlaneResultFcn
  , PreSolveFcn
  , RestitutionCallback
  , TreeBoxCastCallbackFcn
  , TreeQueryCallbackFcn
  , TreeQueryClosestCallbackFcn
  , TreeRayCastCallbackFcn
  )
import Box3D.Types (EnqueueTaskCallback, FinishTaskCallback, PlaneResult, RayCastInput)

-- Leaf callbacks ----------------------------------------------------------

-- | Decide whether two shapes should collide (see
-- 'Box3D.World.setCustomFilterCallback'). The 'Ptr' is the user context.
type CustomFilter = ShapeId -> ShapeId -> Ptr () -> IO Bool

type CustomFilterC = ShapeId -> ShapeId -> Ptr () -> IO CBool

foreign import ccall "wrapper"
  wrapCustomFilter :: CustomFilterC -> IO (FunPtr CustomFilterC)

-- | Wrap a Haskell predicate as a custom-filter callback. Free it with
-- 'freeHaskellFunPtr' when the world no longer references it.
mkCustomFilterFcn :: CustomFilter -> IO (FunPtr CustomFilterFcn)
mkCustomFilterFcn :: CustomFilter -> IO (FunPtr CustomFilterFcn)
mkCustomFilterFcn CustomFilter
f =
  FunPtr CustomFilterC -> FunPtr CustomFilterFcn
forall a b. FunPtr a -> FunPtr b
castFunPtr (FunPtr CustomFilterC -> FunPtr CustomFilterFcn)
-> IO (FunPtr CustomFilterC) -> IO (FunPtr CustomFilterFcn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CustomFilterC -> IO (FunPtr CustomFilterC)
wrapCustomFilter (\ShapeId
a ShapeId
b Ptr ()
ctx -> Bool -> CBool
forall a. Num a => Bool -> a
fromBool (Bool -> CBool) -> IO Bool -> IO CBool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CustomFilter
f ShapeId
a ShapeId
b Ptr ()
ctx)

-- | Run an action with a custom-filter callback that is freed on exit.
withCustomFilterFcn :: CustomFilter -> (FunPtr CustomFilterFcn -> IO a) -> IO a
withCustomFilterFcn :: forall a. CustomFilter -> (FunPtr CustomFilterFcn -> IO a) -> IO a
withCustomFilterFcn CustomFilter
f = IO (FunPtr CustomFilterFcn)
-> (FunPtr CustomFilterFcn -> IO ())
-> (FunPtr CustomFilterFcn -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (CustomFilter -> IO (FunPtr CustomFilterFcn)
mkCustomFilterFcn CustomFilter
f) FunPtr CustomFilterFcn -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr

-- | Combine the friction of two materials (see
-- 'Box3D.World.setFrictionCallback'): @frictionA userMatA frictionB userMatB@.
type Friction = Float -> Word64 -> Float -> Word64 -> IO Float

foreign import ccall "wrapper"
  wrapFriction :: Friction -> IO (FunPtr Friction)

-- | Wrap a Haskell function as a friction-mixing callback.
mkFrictionCallback :: Friction -> IO (FunPtr FrictionCallback)
mkFrictionCallback :: Friction -> IO (FunPtr FrictionCallback)
mkFrictionCallback Friction
f = FunPtr Friction -> FunPtr FrictionCallback
forall a b. FunPtr a -> FunPtr b
castFunPtr (FunPtr Friction -> FunPtr FrictionCallback)
-> IO (FunPtr Friction) -> IO (FunPtr FrictionCallback)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Friction -> IO (FunPtr Friction)
wrapFriction Friction
f

-- | Run an action with a friction callback that is freed on exit.
withFrictionCallback :: Friction -> (FunPtr FrictionCallback -> IO a) -> IO a
withFrictionCallback :: forall a. Friction -> (FunPtr FrictionCallback -> IO a) -> IO a
withFrictionCallback Friction
f = IO (FunPtr FrictionCallback)
-> (FunPtr FrictionCallback -> IO ())
-> (FunPtr FrictionCallback -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Friction -> IO (FunPtr FrictionCallback)
mkFrictionCallback Friction
f) FunPtr FrictionCallback -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr

-- | Combine the restitution of two materials (see
-- 'Box3D.World.setRestitutionCallback'); same shape as 'Friction'.
type Restitution = Float -> Word64 -> Float -> Word64 -> IO Float

foreign import ccall "wrapper"
  wrapRestitution :: Restitution -> IO (FunPtr Restitution)

-- | Wrap a Haskell function as a restitution-mixing callback.
mkRestitutionCallback :: Restitution -> IO (FunPtr RestitutionCallback)
mkRestitutionCallback :: Friction -> IO (FunPtr RestitutionCallback)
mkRestitutionCallback Friction
f = FunPtr Friction -> FunPtr RestitutionCallback
forall a b. FunPtr a -> FunPtr b
castFunPtr (FunPtr Friction -> FunPtr RestitutionCallback)
-> IO (FunPtr Friction) -> IO (FunPtr RestitutionCallback)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Friction -> IO (FunPtr Friction)
wrapRestitution Friction
f

-- | Run an action with a restitution callback that is freed on exit.
withRestitutionCallback :: Restitution -> (FunPtr RestitutionCallback -> IO a) -> IO a
withRestitutionCallback :: forall a. Friction -> (FunPtr RestitutionCallback -> IO a) -> IO a
withRestitutionCallback Friction
f = IO (FunPtr RestitutionCallback)
-> (FunPtr RestitutionCallback -> IO ())
-> (FunPtr RestitutionCallback -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Friction -> IO (FunPtr RestitutionCallback)
mkRestitutionCallback Friction
f) FunPtr RestitutionCallback -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr

-- Query and cast visitors --------------------------------------------------
--
-- The cast and pre-solve callbacks receive b3Pos/b3Vec3 arguments *by value*,
-- which a GHC "wrapper" cannot accept. Each of those routes through a fixed C
-- trampoline (see box3d_shim.h) that takes the structs by value and forwards
-- pointers to the Haskell closure, carried in an hs_b3Closure context.

-- | Overlap query visitor: called for each shape found; return 'True' to
-- continue the query.
type OverlapResult = ShapeId -> IO Bool

type OverlapResultC = ShapeId -> Ptr () -> IO CBool

foreign import ccall "wrapper"
  wrapOverlapResult :: OverlapResultC -> IO (FunPtr OverlapResultC)

-- | Run an action with an overlap visitor and the context to pass alongside
-- it (e.g. to 'Box3D.World.overlapAABB'); both are released on exit.
withOverlapResultFcn :: OverlapResult -> (FunPtr OverlapResultFcn -> Ptr () -> IO a) -> IO a
withOverlapResultFcn :: forall a.
OverlapResult
-> (FunPtr OverlapResultFcn -> Ptr () -> IO a) -> IO a
withOverlapResultFcn OverlapResult
f FunPtr OverlapResultFcn -> Ptr () -> IO a
act =
  IO (FunPtr OverlapResultC)
-> (FunPtr OverlapResultC -> IO ())
-> (FunPtr OverlapResultC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (OverlapResultC -> IO (FunPtr OverlapResultC)
wrapOverlapResult (\ShapeId
s Ptr ()
_ -> Bool -> CBool
forall a. Num a => Bool -> a
fromBool (Bool -> CBool) -> IO Bool -> IO CBool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OverlapResult
f ShapeId
s)) FunPtr OverlapResultC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr OverlapResultC -> IO a) -> IO a)
-> (FunPtr OverlapResultC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr OverlapResultC
p ->
    FunPtr OverlapResultFcn -> Ptr () -> IO a
act (FunPtr OverlapResultC -> FunPtr OverlapResultFcn
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr OverlapResultC
p) Ptr ()
forall a. Ptr a
nullPtr

-- | Cast visitor: called for each shape a world ray\/shape cast finds, with
-- the hit point, normal, fraction, user material id and triangle\/child
-- indices. The returned fraction controls the query: 0 terminates, the given
-- fraction clips the ray, 1 continues.
type CastResult = ShapeId -> Pos -> Vec3 -> Float -> Word64 -> CInt -> CInt -> IO Float

type CastResultC = ShapeId -> Ptr Pos -> Ptr Vec3 -> Float -> Word64 -> CInt -> CInt -> Ptr () -> IO Float

foreign import ccall "wrapper"
  wrapCastResult :: CastResultC -> IO (FunPtr CastResultC)

foreign import ccall unsafe "&hs_b3CastResultTrampoline"
  p_castResultTrampoline :: FunPtr CastResultFcn

-- | Run an action with a cast visitor and the context to pass alongside it
-- (e.g. to 'Box3D.World.castRay'); both are released on exit.
withCastResultFcn :: CastResult -> (FunPtr CastResultFcn -> Ptr () -> IO a) -> IO a
withCastResultFcn :: forall a.
CastResult -> (FunPtr CastResultFcn -> Ptr () -> IO a) -> IO a
withCastResultFcn CastResult
f FunPtr CastResultFcn -> Ptr () -> IO a
act =
  IO (FunPtr CastResultC)
-> (FunPtr CastResultC -> IO ())
-> (FunPtr CastResultC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (CastResultC -> IO (FunPtr CastResultC)
wrapCastResult CastResultC
forall {p}.
ShapeId
-> Ptr Pos
-> Ptr Pos
-> Float
-> Word64
-> CInt
-> CInt
-> p
-> IO Float
go) FunPtr CastResultC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr CastResultC -> IO a) -> IO a)
-> (FunPtr CastResultC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr CastResultC
hsFn ->
    FunPtr (ZonkAny 6) -> (Ptr () -> IO a) -> IO a
forall a b. FunPtr a -> (Ptr () -> IO b) -> IO b
withClosure (FunPtr CastResultC -> FunPtr (ZonkAny 6)
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr CastResultC
hsFn) ((Ptr () -> IO a) -> IO a) -> (Ptr () -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ FunPtr CastResultFcn -> Ptr () -> IO a
act FunPtr CastResultFcn
p_castResultTrampoline
  where
    go :: ShapeId
-> Ptr Pos
-> Ptr Pos
-> Float
-> Word64
-> CInt
-> CInt
-> p
-> IO Float
go ShapeId
sid Ptr Pos
pPoint Ptr Pos
pNormal Float
frac Word64
matId CInt
triangleIx CInt
childIx p
_ctx = do
      point <- Ptr Pos -> IO Pos
forall a. Storable a => Ptr a -> IO a
peek Ptr Pos
pPoint
      normal <- peek pNormal
      f sid point normal frac matId triangleIx childIx

-- | Contact gate, called after narrow phase but before the solver: return
-- 'False' to disable the contact. Fired from solver worker threads when the
-- world is multithreaded, so it must be thread-safe. Requires
-- @shapeDefEnablePreSolveEvents@ on the shapes.
type PreSolve = ShapeId -> ShapeId -> Pos -> Vec3 -> IO Bool

type PreSolveC = ShapeId -> ShapeId -> Ptr Pos -> Ptr Vec3 -> Ptr () -> IO CBool

foreign import ccall "wrapper"
  wrapPreSolve :: PreSolveC -> IO (FunPtr PreSolveC)

foreign import ccall unsafe "&hs_b3PreSolveTrampoline"
  p_preSolveTrampoline :: FunPtr PreSolveFcn

-- | Run an action with a pre-solve gate and the context to pass alongside it
-- (to 'Box3D.World.setPreSolveCallback'). Unhook the callback from the world
-- before the action returns: both are released on exit.
withPreSolveFcn :: PreSolve -> (FunPtr PreSolveFcn -> Ptr () -> IO a) -> IO a
withPreSolveFcn :: forall a.
PreSolve -> (FunPtr PreSolveFcn -> Ptr () -> IO a) -> IO a
withPreSolveFcn PreSolve
f FunPtr PreSolveFcn -> Ptr () -> IO a
act =
  IO (FunPtr PreSolveC)
-> (FunPtr PreSolveC -> IO ())
-> (FunPtr PreSolveC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (PreSolveC -> IO (FunPtr PreSolveC)
wrapPreSolve PreSolveC
forall {b} {p}.
Num b =>
ShapeId -> ShapeId -> Ptr Pos -> Ptr Pos -> p -> IO b
go) FunPtr PreSolveC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr PreSolveC -> IO a) -> IO a)
-> (FunPtr PreSolveC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr PreSolveC
hsFn ->
    FunPtr (ZonkAny 5) -> (Ptr () -> IO a) -> IO a
forall a b. FunPtr a -> (Ptr () -> IO b) -> IO b
withClosure (FunPtr PreSolveC -> FunPtr (ZonkAny 5)
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr PreSolveC
hsFn) ((Ptr () -> IO a) -> IO a) -> (Ptr () -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ FunPtr PreSolveFcn -> Ptr () -> IO a
act FunPtr PreSolveFcn
p_preSolveTrampoline
  where
    go :: ShapeId -> ShapeId -> Ptr Pos -> Ptr Pos -> p -> IO b
go ShapeId
a ShapeId
b Ptr Pos
pPoint Ptr Pos
pNormal p
_ctx = do
      point <- Ptr Pos -> IO Pos
forall a. Storable a => Ptr a -> IO a
peek Ptr Pos
pPoint
      normal <- peek pNormal
      fromBool <$> f a b point normal

-- | Mover collision visitor: the batch of collision planes gathered against
-- one shape (see 'Box3D.World.collideMover'); return 'True' to keep gathering.
type PlaneResultVisitor = ShapeId -> Vector PlaneResult -> IO Bool

type PlaneResultC = ShapeId -> Ptr PlaneResult -> CInt -> Ptr () -> IO CBool

foreign import ccall "wrapper"
  wrapPlaneResult :: PlaneResultC -> IO (FunPtr PlaneResultC)

-- | Run an action with a mover-plane visitor and the context to pass
-- alongside it (to 'Box3D.World.collideMover'); both are released on exit.
withPlaneResultFcn :: PlaneResultVisitor -> (FunPtr PlaneResultFcn -> Ptr () -> IO a) -> IO a
withPlaneResultFcn :: forall a.
PlaneResultVisitor
-> (FunPtr PlaneResultFcn -> Ptr () -> IO a) -> IO a
withPlaneResultFcn PlaneResultVisitor
f FunPtr PlaneResultFcn -> Ptr () -> IO a
act =
  IO (FunPtr PlaneResultC)
-> (FunPtr PlaneResultC -> IO ())
-> (FunPtr PlaneResultC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (PlaneResultC -> IO (FunPtr PlaneResultC)
wrapPlaneResult PlaneResultC
forall {a} {b} {p}.
(Integral a, Num b) =>
ShapeId -> Ptr PlaneResult -> a -> p -> IO b
go) FunPtr PlaneResultC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr PlaneResultC -> IO a) -> IO a)
-> (FunPtr PlaneResultC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr PlaneResultC
p ->
    FunPtr PlaneResultFcn -> Ptr () -> IO a
act (FunPtr PlaneResultC -> FunPtr PlaneResultFcn
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr PlaneResultC
p) Ptr ()
forall a. Ptr a
nullPtr
  where
    go :: ShapeId -> Ptr PlaneResult -> a -> p -> IO b
go ShapeId
sid Ptr PlaneResult
pPlanes a
n p
_ctx = do
      planes <- Int -> Ptr PlaneResult -> IO (Vector PlaneResult)
forall a. Storable a => Int -> Ptr a -> IO (Vector a)
copyVector (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n) Ptr PlaneResult
pPlanes
      fromBool <$> f sid planes

-- | Mover shape filter: return 'True' to consider the shape for mover
-- collision.
type MoverFilter = ShapeId -> IO Bool

type MoverFilterC = ShapeId -> Ptr () -> IO CBool

foreign import ccall "wrapper"
  wrapMoverFilter :: MoverFilterC -> IO (FunPtr MoverFilterC)

-- | Run an action with a mover filter and the context to pass alongside it;
-- both are released on exit.
withMoverFilterFcn :: MoverFilter -> (FunPtr MoverFilterFcn -> Ptr () -> IO a) -> IO a
withMoverFilterFcn :: forall a.
OverlapResult -> (FunPtr MoverFilterFcn -> Ptr () -> IO a) -> IO a
withMoverFilterFcn OverlapResult
f FunPtr MoverFilterFcn -> Ptr () -> IO a
act =
  IO (FunPtr OverlapResultC)
-> (FunPtr OverlapResultC -> IO ())
-> (FunPtr OverlapResultC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (OverlapResultC -> IO (FunPtr OverlapResultC)
wrapMoverFilter (\ShapeId
s Ptr ()
_ -> Bool -> CBool
forall a. Num a => Bool -> a
fromBool (Bool -> CBool) -> IO Bool -> IO CBool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OverlapResult
f ShapeId
s)) FunPtr OverlapResultC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr OverlapResultC -> IO a) -> IO a)
-> (FunPtr OverlapResultC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr OverlapResultC
p ->
    FunPtr MoverFilterFcn -> Ptr () -> IO a
act (FunPtr OverlapResultC -> FunPtr MoverFilterFcn
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr OverlapResultC
p) Ptr ()
forall a. Ptr a
nullPtr

-- | Compound query visitor: @compoundData childIndex@; return 'True' to
-- continue. The compound data stays a raw 'Ptr' (no 'Storable' yet).
type CompoundQuery = Ptr CompoundData -> CInt -> IO Bool

type CompoundQueryC = Ptr CompoundData -> CInt -> Ptr () -> IO CBool

foreign import ccall "wrapper"
  wrapCompoundQuery :: CompoundQueryC -> IO (FunPtr CompoundQueryC)

-- | Run an action with a compound-query visitor and the context to pass
-- alongside it; both are released on exit.
withCompoundQueryFcn :: CompoundQuery -> (FunPtr CompoundQueryFcn -> Ptr () -> IO a) -> IO a
withCompoundQueryFcn :: forall a.
CompoundQuery
-> (FunPtr CompoundQueryFcn -> Ptr () -> IO a) -> IO a
withCompoundQueryFcn CompoundQuery
f FunPtr CompoundQueryFcn -> Ptr () -> IO a
act =
  IO (FunPtr CompoundQueryC)
-> (FunPtr CompoundQueryC -> IO ())
-> (FunPtr CompoundQueryC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (CompoundQueryC -> IO (FunPtr CompoundQueryC)
wrapCompoundQuery (\Ptr CompoundData
c CInt
i Ptr ()
_ -> Bool -> CBool
forall a. Num a => Bool -> a
fromBool (Bool -> CBool) -> IO Bool -> IO CBool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompoundQuery
f Ptr CompoundData
c CInt
i)) FunPtr CompoundQueryC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr CompoundQueryC -> IO a) -> IO a)
-> (FunPtr CompoundQueryC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr CompoundQueryC
p ->
    FunPtr CompoundQueryFcn -> Ptr () -> IO a
act (FunPtr CompoundQueryC -> FunPtr CompoundQueryFcn
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr CompoundQueryC
p) Ptr ()
forall a. Ptr a
nullPtr

-- | Mesh query visitor: one triangle (three vertices and its index) per call;
-- return 'True' to continue. The vertices arrive by value in C, so this
-- routes through @hs_b3MeshQueryTrampoline@.
type MeshQuery = Vec3 -> Vec3 -> Vec3 -> CInt -> IO Bool

type MeshQueryC = Ptr Vec3 -> Ptr Vec3 -> Ptr Vec3 -> CInt -> Ptr () -> IO CBool

foreign import ccall "wrapper"
  wrapMeshQuery :: MeshQueryC -> IO (FunPtr MeshQueryC)

foreign import ccall unsafe "&hs_b3MeshQueryTrampoline"
  p_meshQueryTrampoline :: FunPtr MeshQueryFcn

-- | Run an action with a mesh-query visitor and the context to pass alongside
-- it; both are released on exit.
withMeshQueryFcn :: MeshQuery -> (FunPtr MeshQueryFcn -> Ptr () -> IO a) -> IO a
withMeshQueryFcn :: forall a.
MeshQuery -> (FunPtr MeshQueryFcn -> Ptr () -> IO a) -> IO a
withMeshQueryFcn MeshQuery
f FunPtr MeshQueryFcn -> Ptr () -> IO a
act =
  IO (FunPtr MeshQueryC)
-> (FunPtr MeshQueryC -> IO ())
-> (FunPtr MeshQueryC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (MeshQueryC -> IO (FunPtr MeshQueryC)
wrapMeshQuery MeshQueryC
forall {b} {p}.
Num b =>
Ptr Pos -> Ptr Pos -> Ptr Pos -> CInt -> p -> IO b
go) FunPtr MeshQueryC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr MeshQueryC -> IO a) -> IO a)
-> (FunPtr MeshQueryC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr MeshQueryC
hsFn ->
    FunPtr (ZonkAny 4) -> (Ptr () -> IO a) -> IO a
forall a b. FunPtr a -> (Ptr () -> IO b) -> IO b
withClosure (FunPtr MeshQueryC -> FunPtr (ZonkAny 4)
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr MeshQueryC
hsFn) ((Ptr () -> IO a) -> IO a) -> (Ptr () -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ FunPtr MeshQueryFcn -> Ptr () -> IO a
act FunPtr MeshQueryFcn
p_meshQueryTrampoline
  where
    go :: Ptr Pos -> Ptr Pos -> Ptr Pos -> CInt -> p -> IO b
go Ptr Pos
pa Ptr Pos
pb Ptr Pos
pc CInt
ix p
_ctx = do
      a <- Ptr Pos -> IO Pos
forall a. Storable a => Ptr a -> IO a
peek Ptr Pos
pa
      b <- peek pb
      c <- peek pc
      fromBool <$> f a b c ix

-- Dynamic-tree visitors -----------------------------------------------------

-- | Tree query visitor: @proxyId userData@; return 'True' to continue the
-- query.
type TreeQuery = CInt -> Word64 -> IO Bool

type TreeQueryC = CInt -> Word64 -> Ptr () -> IO CBool

foreign import ccall "wrapper"
  wrapTreeQuery :: TreeQueryC -> IO (FunPtr TreeQueryC)

-- | Run an action with a tree-query visitor and the context to pass alongside
-- it (to 'Box3D.DynamicTree.query'); both are released on exit.
withTreeQueryFcn :: TreeQuery -> (FunPtr TreeQueryCallbackFcn -> Ptr () -> IO a) -> IO a
withTreeQueryFcn :: forall a.
TreeQuery
-> (FunPtr TreeQueryCallbackFcn -> Ptr () -> IO a) -> IO a
withTreeQueryFcn TreeQuery
f FunPtr TreeQueryCallbackFcn -> Ptr () -> IO a
act =
  IO (FunPtr TreeQueryC)
-> (FunPtr TreeQueryC -> IO ())
-> (FunPtr TreeQueryC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (TreeQueryC -> IO (FunPtr TreeQueryC)
wrapTreeQuery (\CInt
i Word64
u Ptr ()
_ -> Bool -> CBool
forall a. Num a => Bool -> a
fromBool (Bool -> CBool) -> IO Bool -> IO CBool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeQuery
f CInt
i Word64
u)) FunPtr TreeQueryC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr TreeQueryC -> IO a) -> IO a)
-> (FunPtr TreeQueryC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr TreeQueryC
p ->
    FunPtr TreeQueryCallbackFcn -> Ptr () -> IO a
act (FunPtr TreeQueryC -> FunPtr TreeQueryCallbackFcn
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr TreeQueryC
p) Ptr ()
forall a. Ptr a
nullPtr

-- | Closest-point tree query visitor: @distanceSqrMin proxyId userData@; the
-- returned value narrows the search radius (squared).
type TreeQueryClosest = Float -> CInt -> Word64 -> IO Float

type TreeQueryClosestC = Float -> CInt -> Word64 -> Ptr () -> IO Float

foreign import ccall "wrapper"
  wrapTreeQueryClosest :: TreeQueryClosestC -> IO (FunPtr TreeQueryClosestC)

-- | Run an action with a closest-query visitor and the context to pass
-- alongside it (to 'Box3D.DynamicTree.queryClosest'); both are released on
-- exit.
withTreeQueryClosestFcn :: TreeQueryClosest -> (FunPtr TreeQueryClosestCallbackFcn -> Ptr () -> IO a) -> IO a
withTreeQueryClosestFcn :: forall a.
TreeQueryClosest
-> (FunPtr TreeQueryClosestCallbackFcn -> Ptr () -> IO a) -> IO a
withTreeQueryClosestFcn TreeQueryClosest
f FunPtr TreeQueryClosestCallbackFcn -> Ptr () -> IO a
act =
  IO (FunPtr TreeQueryClosestC)
-> (FunPtr TreeQueryClosestC -> IO ())
-> (FunPtr TreeQueryClosestC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (TreeQueryClosestC -> IO (FunPtr TreeQueryClosestC)
wrapTreeQueryClosest (\Float
d CInt
i Word64
u Ptr ()
_ -> TreeQueryClosest
f Float
d CInt
i Word64
u)) FunPtr TreeQueryClosestC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr TreeQueryClosestC -> IO a) -> IO a)
-> (FunPtr TreeQueryClosestC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr TreeQueryClosestC
p ->
    FunPtr TreeQueryClosestCallbackFcn -> Ptr () -> IO a
act (FunPtr TreeQueryClosestC -> FunPtr TreeQueryClosestCallbackFcn
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr TreeQueryClosestC
p) Ptr ()
forall a. Ptr a
nullPtr

-- | Tree ray-cast visitor: the (possibly clipped) input, @proxyId@ and
-- @userData@. The returned fraction controls the query: 0 terminates, the
-- given fraction clips the ray, 1 continues.
type TreeRayCast = RayCastInput -> CInt -> Word64 -> IO Float

type TreeRayCastC = Ptr RayCastInput -> CInt -> Word64 -> Ptr () -> IO Float

foreign import ccall "wrapper"
  wrapTreeRayCast :: TreeRayCastC -> IO (FunPtr TreeRayCastC)

-- | Run an action with a tree ray-cast visitor and the context to pass
-- alongside it (to 'Box3D.DynamicTree.rayCast'); both are released on exit.
withTreeRayCastFcn :: TreeRayCast -> (FunPtr TreeRayCastCallbackFcn -> Ptr () -> IO a) -> IO a
withTreeRayCastFcn :: forall a.
TreeRayCast
-> (FunPtr TreeRayCastCallbackFcn -> Ptr () -> IO a) -> IO a
withTreeRayCastFcn TreeRayCast
f FunPtr TreeRayCastCallbackFcn -> Ptr () -> IO a
act =
  IO (FunPtr TreeRayCastC)
-> (FunPtr TreeRayCastC -> IO ())
-> (FunPtr TreeRayCastC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (TreeRayCastC -> IO (FunPtr TreeRayCastC)
wrapTreeRayCast TreeRayCastC
forall {p}. Ptr RayCastInput -> CInt -> Word64 -> p -> IO Float
go) FunPtr TreeRayCastC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr TreeRayCastC -> IO a) -> IO a)
-> (FunPtr TreeRayCastC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr TreeRayCastC
p ->
    FunPtr TreeRayCastCallbackFcn -> Ptr () -> IO a
act (FunPtr TreeRayCastC -> FunPtr TreeRayCastCallbackFcn
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr TreeRayCastC
p) Ptr ()
forall a. Ptr a
nullPtr
  where
    go :: Ptr RayCastInput -> CInt -> Word64 -> p -> IO Float
go Ptr RayCastInput
pInput CInt
i Word64
u p
_ctx = do
      input <- Ptr RayCastInput -> IO RayCastInput
forall a. Storable a => Ptr a -> IO a
peek Ptr RayCastInput
pInput
      f input i u

-- | Tree box-cast visitor. The input stays a raw 'Ptr' ('BoxCastInput' has no
-- 'Storable' yet: it embeds a 'Box3D.Tags.ShapeProxy' point cloud).
type TreeBoxCast = Ptr BoxCastInput -> CInt -> Word64 -> IO Float

type TreeBoxCastC = Ptr BoxCastInput -> CInt -> Word64 -> Ptr () -> IO Float

foreign import ccall "wrapper"
  wrapTreeBoxCast :: TreeBoxCastC -> IO (FunPtr TreeBoxCastC)

-- | Run an action with a tree box-cast visitor and the context to pass
-- alongside it (to 'Box3D.DynamicTree.boxCast'); both are released on exit.
withTreeBoxCastFcn :: TreeBoxCast -> (FunPtr TreeBoxCastCallbackFcn -> Ptr () -> IO a) -> IO a
withTreeBoxCastFcn :: forall a.
TreeBoxCast
-> (FunPtr TreeBoxCastCallbackFcn -> Ptr () -> IO a) -> IO a
withTreeBoxCastFcn TreeBoxCast
f FunPtr TreeBoxCastCallbackFcn -> Ptr () -> IO a
act =
  IO (FunPtr TreeBoxCastC)
-> (FunPtr TreeBoxCastC -> IO ())
-> (FunPtr TreeBoxCastC -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (TreeBoxCastC -> IO (FunPtr TreeBoxCastC)
wrapTreeBoxCast (\Ptr BoxCastInput
p CInt
i Word64
u Ptr ()
_ -> TreeBoxCast
f Ptr BoxCastInput
p CInt
i Word64
u)) FunPtr TreeBoxCastC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr TreeBoxCastC -> IO a) -> IO a)
-> (FunPtr TreeBoxCastC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr TreeBoxCastC
p ->
    FunPtr TreeBoxCastCallbackFcn -> Ptr () -> IO a
act (FunPtr TreeBoxCastC -> FunPtr TreeBoxCastCallbackFcn
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr TreeBoxCastC
p) Ptr ()
forall a. Ptr a
nullPtr

-- | Allocate the two-pointer @hs_b3Closure@ a trampoline dereferences: the
-- Haskell-wrapped function and the user context it should receive.
withClosure :: FunPtr a -> (Ptr () -> IO b) -> IO b
withClosure :: forall a b. FunPtr a -> (Ptr () -> IO b) -> IO b
withClosure FunPtr a
fn Ptr () -> IO b
act =
  Int -> (Ptr (ZonkAny 3) -> IO b) -> IO b
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sz) ((Ptr (ZonkAny 3) -> IO b) -> IO b)
-> (Ptr (ZonkAny 3) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Ptr (ZonkAny 3)
p -> do
    Ptr (ZonkAny 3) -> Int -> Ptr (ZonkAny 0) -> IO ()
forall b. Ptr b -> Int -> Ptr (ZonkAny 0) -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr (ZonkAny 3)
p Int
0 (FunPtr a -> Ptr (ZonkAny 0)
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr a
fn)
    Ptr (ZonkAny 3) -> Int -> Ptr (ZonkAny 1) -> IO ()
forall b. Ptr b -> Int -> Ptr (ZonkAny 1) -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr (ZonkAny 3)
p Int
sz Ptr (ZonkAny 1)
forall a. Ptr a
nullPtr
    Ptr () -> IO b
act (Ptr (ZonkAny 3) -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr (ZonkAny 3)
p)
  where
    sz :: Int
sz = Ptr (ZonkAny 2) -> Int
forall a. Storable a => a -> Int
sizeOf Ptr (ZonkAny 2)
forall a. Ptr a
nullPtr

-- A multithreaded task system --------------------------------------------

-- | The two callbacks (ready to poke into @worldDefEnqueueTask@ /
-- @worldDefFinishTask@) plus the worker count to set on @worldDefWorkerCount@.
data TaskSystem = TaskSystem
  { TaskSystem -> FunPtr EnqueueTaskCallback
taskEnqueue     :: FunPtr EnqueueTaskCallback
  , TaskSystem -> FunPtr FinishTaskCallback
taskFinish      :: FunPtr FinishTaskCallback
  , TaskSystem -> Int
taskWorkerCount :: Int
  }

-- Box3D's enqueue takes a trailing @const char* taskName@ we ignore.
-- The engine's per-task work function: @void b2TaskCallback(void* taskContext)@.
type TaskC = Ptr () -> IO ()

-- Calling it re-enters Haskell (the solver work invokes our other callbacks),
-- so it must be a `safe` call.
foreign import ccall safe "dynamic"
  callTask :: FunPtr TaskC -> TaskC

type EnqueueC = FunPtr TaskC -> Ptr () -> Ptr () -> Ptr CChar -> IO (Ptr ())
type FinishC = Ptr () -> Ptr () -> IO ()

foreign import ccall "wrapper" wrapEnqueue :: EnqueueC -> IO (FunPtr EnqueueC)
foreign import ccall "wrapper" wrapFinish :: FinishC -> IO (FunPtr FinishC)

-- | Install a Haskell thread-pool task system for the duration of an action,
-- so the Box3D solver runs across the threaded runtime's capabilities. Set
-- @worldDefWorkerCount@, @worldDefEnqueueTask@ and @worldDefFinishTask@ from the
-- 'TaskSystem' before creating the world.
--
-- Each enqueued task is run on a fresh 'forkIO' thread; @finishTask@ joins it.
-- The task's handle travels through the engine as a 'StablePtr' to its join
-- 'MVar'. Requires @-threaded@.
withThreadPoolTaskSystem :: Int -> (TaskSystem -> IO a) -> IO a
withThreadPoolTaskSystem :: forall a. Int -> (TaskSystem -> IO a) -> IO a
withThreadPoolTaskSystem Int
workers TaskSystem -> IO a
act =
  IO (FunPtr EnqueueC)
-> (FunPtr EnqueueC -> IO ()) -> (FunPtr EnqueueC -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (EnqueueC -> IO (FunPtr EnqueueC)
wrapEnqueue EnqueueC
enqueue) FunPtr EnqueueC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr EnqueueC -> IO a) -> IO a)
-> (FunPtr EnqueueC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr EnqueueC
enq ->
    IO (FunPtr FinishC)
-> (FunPtr FinishC -> IO ()) -> (FunPtr FinishC -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FinishC -> IO (FunPtr FinishC)
wrapFinish FinishC
finish) FunPtr FinishC -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr ((FunPtr FinishC -> IO a) -> IO a)
-> (FunPtr FinishC -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FunPtr FinishC
fin ->
      TaskSystem -> IO a
act
        TaskSystem
          { taskEnqueue :: FunPtr EnqueueTaskCallback
taskEnqueue = FunPtr EnqueueC -> FunPtr EnqueueTaskCallback
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr EnqueueC
enq
          , taskFinish :: FunPtr FinishTaskCallback
taskFinish = FunPtr FinishC -> FunPtr FinishTaskCallback
forall a b. FunPtr a -> FunPtr b
castFunPtr FunPtr FinishC
fin
          , taskWorkerCount :: Int
taskWorkerCount = Int
workers
          }
  where
    enqueue :: EnqueueC
    enqueue :: EnqueueC
enqueue FunPtr TaskC
task Ptr ()
taskCtx Ptr ()
_userCtx Ptr CChar
_taskName = do
      done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
      _ <- forkIO (callTask task taskCtx `finally` putMVar done ())
      castStablePtrToPtr <$> newStablePtr done

    finish :: FinishC
    finish :: FinishC
finish Ptr ()
userTask Ptr ()
_userCtx = do
      let sp :: StablePtr (MVar ())
sp = Ptr () -> StablePtr (MVar ())
forall a. Ptr () -> StablePtr a
castPtrToStablePtr Ptr ()
userTask :: StablePtr (MVar ())
      done <- StablePtr (MVar ()) -> IO (MVar ())
forall a. StablePtr a -> IO a
deRefStablePtr StablePtr (MVar ())
sp
      takeMVar done
      freeStablePtr sp