module Main (main) where

import Control.Exception (evaluate)
import Control.Monad (forM_, replicateM_)
import Data.IORef
import Data.Vector.Storable qualified as VS
import Foreign

import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.Runners (NumThreads (..))

import Box3D.Base qualified as Base
import Box3D.Body qualified as Body
import Box3D.Callbacks qualified as CB
import Box3D.Collision qualified as Collision
import Box3D.DistanceJoint qualified as DistanceJoint
import Box3D.DynamicTree qualified as DynamicTree
import Box3D.Events qualified as Events
import Box3D.Id
import Box3D.Joint qualified as Joint
import Box3D.MathFunctions
import Box3D.MathTypes
import Box3D.Shape qualified as Shape
import Box3D.UserData qualified as UD
import Box3D.Types
import Box3D.World qualified as World

main :: IO ()
-- Box3D keeps a global registry of worlds and a world is single-threaded
-- state, so the suite must run sequentially rather than tasty's default
-- parallel execution.
main = defaultMain (localOption (NumThreads 1) tests)

tests :: TestTree
tests =
  testGroup
    "Box3D"
    [ testGroup "Base" baseTests
    , testGroup "MathTypes" mathTypesTests
    , testGroup "MathFunctions" mathFunctionsTests
    , testGroup "Id" idTests
    , testGroup "Types" typesTests
    , testGroup "Simulation" simulationTests
    , testGroup "Joints" jointTests
    , testGroup "Events" eventTests
    , testGroup "Queries" queryTests
    , testGroup "Callbacks" callbackTests
    ]

-- | Poke a value and read it back, exercising the 'Storable' instance.
roundTrip :: (Storable a) => a -> IO a
roundTrip x = alloca $ \p -> poke p x >> peek p

approx :: Float -> Float -> Assertion
approx expected actual =
  assertBool
    ("expected " <> show expected <> " but got " <> show actual)
    (abs (expected - actual) < 1e-5)

baseTests :: [TestTree]
baseTests =
  [ testCase "getVersion is 0.1.0" $ do
      v <- Base.getVersion
      Base.versionMajor v @?= 0
      Base.versionMinor v @?= 1
      Base.versionRevision v @?= 0
  , testCase "getByteCount is non-negative" $ do
      n <- Base.getByteCount
      assertBool "byte count >= 0" (n >= 0)
  , testCase "isDoublePrecision is False (single-precision build)" $ do
      dp <- Base.isDoublePrecision
      dp @?= False
  ]

mathTypesTests :: [TestTree]
mathTypesTests =
  [ testCase "Vec3 size/align match the C ABI" $ do
      sizeOf (Vec2 0 0) @?= 8
      sizeOf (Vec3 0 0 0) @?= 12
      sizeOf (Quat vec3Zero 0) @?= 16
      sizeOf (Transform vec3Zero quatIdentity) @?= 28
  , testCase "Vec3 round-trips" $
      roundTrip (Vec3 1 2 3) >>= (@?= Vec3 1 2 3)
  , testCase "Quat round-trips" $
      roundTrip (Quat (Vec3 1 2 3) 4) >>= (@?= Quat (Vec3 1 2 3) 4)
  , testCase "Transform round-trips" $ do
      let t = Transform (Vec3 1 2 3) (Quat (Vec3 4 5 6) 7)
      roundTrip t >>= (@?= t)
  , testCase "Matrix3 round-trips" $ do
      let m = Matrix3 (Vec3 1 2 3) (Vec3 4 5 6) (Vec3 7 8 9)
      roundTrip m >>= (@?= m)
  ]

mathFunctionsTests :: [TestTree]
mathFunctionsTests =
  [ testCase "finite vector is valid" $
      isValidVec3 (Vec3 1 2 3) >>= (@?= True)
  , testCase "NaN vector is invalid" $
      isValidVec3 (Vec3 (0 / 0) 0 0) >>= (@?= False)
  , testCase "infinite vector is invalid" $
      isValidVec3 (Vec3 (1 / 0) 0 0) >>= (@?= False)
  , testCase "identity quaternion is valid" $
      isValidQuat quatIdentity >>= (@?= True)
  , testCase "identity transform is valid" $
      isValidTransform transformIdentity >>= (@?= True)
  , testCase "identity matrix is valid" $
      isValidMatrix3 matrix3Identity >>= (@?= True)
  , testCase "computeCosSin 0 = (1, 0)" $ do
      CosSin c s <- computeCosSin 0
      approx 1 c
      approx 0 s
  , testCase "computeCosSin pi/2 = (0, 1)" $ do
      CosSin c s <- computeCosSin (pi / 2)
      approx 0 c
      approx 1 s
  , testCase "rotation between identical axes is identity" $ do
      let ax = Vec3 1 0 0
      Quat _ s <- computeQuatBetweenUnitVectors ax ax
      approx 1 s
  , testCase "rotation from +X to +Y is 90 degrees about +Z" $ do
      let
        ax = Vec3 1 0 0
        ay = Vec3 0 1 0
      Quat (Vec3 vx vy vz) s <- computeQuatBetweenUnitVectors ax ay
      approx 0 vx
      approx 0 vy
      approx 0.70710677 vz
      approx 0.70710677 s
  ]

idTests :: [TestTree]
idTests =
  [ testCase "id sizes match the C ABI" $ do
      sizeOf nullWorldId @?= 4
      sizeOf nullBodyId @?= 8
      sizeOf nullContactId @?= 12
  , testCase "WorldId round-trips" $
      roundTrip (WorldId 0x50009) >>= (@?= WorldId 0x50009)
  , testCase "BodyId round-trips" $
      roundTrip (BodyId 0x1122334455667788) >>= (@?= BodyId 0x1122334455667788)
  , testCase "ContactId round-trips" $
      roundTrip (ContactId 1 2 4) >>= (@?= ContactId 1 2 4)
  ]

typesTests :: [TestTree]
typesTests =
  [ testCase "default world def has expected fields" $ do
      d <- defaultWorldDef
      worldDefGravity d @?= Vec3 0 (-10) 0
      worldDefContactHertz d @?= 30
      worldDefEnableSleep d @?= 1
      assertBool "internalValue cookie is set" (worldDefInternalValue d /= 0)
  , testCase "default world def round-trips" $ do
      d <- defaultWorldDef
      roundTrip d >>= (@?= d)
  , testCase "default body def has expected fields" $ do
      d <- defaultBodyDef
      bodyDefType d @?= StaticBody
      bodyDefRotation d @?= quatIdentity
      bodyDefGravityScale d @?= 1
      assertBool "internalValue cookie is set" (bodyDefInternalValue d /= 0)
  , testCase "default body def round-trips" $ do
      d <- defaultBodyDef
      roundTrip d >>= (@?= d)
  , testCase "default shape def has expected fields" $ do
      d <- defaultShapeDef
      shapeDefDensity d @?= 1000
      shapeDefUpdateBodyMass d @?= 1
      assertBool "internalValue cookie is set" (shapeDefInternalValue d /= 0)
  , testCase "default shape def round-trips" $ do
      d <- defaultShapeDef
      roundTrip d >>= (@?= d)
  , testCase "default filter round-trips" $ do
      f <- defaultFilter
      roundTrip f >>= (@?= f)
  , testCase "default surface material round-trips" $ do
      m <- defaultSurfaceMaterial
      roundTrip m >>= (@?= m)
  , testCase "Sphere round-trips" $ do
      let s = Sphere (Vec3 1 2 3) 0.5
      roundTrip s >>= (@?= s)
  , testCase "Capsule round-trips" $ do
      let c = Capsule (Vec3 0 0 0) (Vec3 0 1 0) 0.25
      roundTrip c >>= (@?= c)
  , testCase "shape types case as patterns (COMPLETE, no wildcard)" $
      withWorld (Vec3 0 0 0) $ \w -> do
        bd <- defaultBodyDef
        b <- Body.create w bd
        sd <- defaultShapeDef
        sh <- Shape.createSphere b sd (Sphere vec3Zero 0.5)
        ty <- Shape.getType sh
        let name = case ty of
              CapsuleShape -> "capsule"
              CompoundShape -> "compound"
              HeightShape -> "height field"
              HullShape -> "hull"
              MeshShape -> "mesh"
              SphereShape -> "sphere"
        name @?= ("sphere" :: String)
  , testCase "an explosion pushes a nearby body away" $
      withWorld (Vec3 0 0 0) $ \w -> do
        b <- dynamicSphere w (Vec3 1 0 0) 0.5
        ed <- defaultExplosionDef
        World.explode
          w
          ed
            { explosionDefPosition = Vec3 0 0 0
            , explosionDefRadius = 2
            , explosionDefImpulsePerArea = 5
            }
        Vec3 vx _ _ <- Body.getLinearVelocity b
        assertBool ("pushed away from the blast, vx = " <> show vx) (vx > 0)
  , testCase "user indices round-trip through body, shape and joint slots" $
      withWorld (Vec3 0 0 0) $ \w -> do
        bd <- defaultBodyDef
        b <- Body.create w bd
        sd <- defaultShapeDef
        sh <- Shape.createSphere b sd (Sphere vec3Zero 0.5)
        UD.setUserIndex b 42
        UD.getUserIndex b >>= (@?= 42)
        UD.setUserIndex sh maxBound
        UD.getUserIndex sh >>= (@?= maxBound)
        UD.setUserIndex b (-7)
        UD.getUserIndex b >>= (@?= (-7))
  ]

-- | Build a world with the given gravity and default settings.
withWorld :: Vec3 -> (WorldId -> IO a) -> IO a
withWorld gravity act = do
  wd <- defaultWorldDef
  w <- World.create wd{worldDefGravity = gravity}
  r <- act w
  World.destroy w
  pure r

-- | A dynamic body carrying a unit sphere at the given position.
dynamicSphere :: WorldId -> Pos -> Float -> IO BodyId
dynamicSphere w position radius = do
  bd <- defaultBodyDef
  b <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = position}
  sd <- defaultShapeDef
  _ <- Shape.createSphere b sd (Sphere vec3Zero radius)
  pure b

posY :: Vec3 -> Float
posY (Vec3 _ y _) = y

simulationTests :: [TestTree]
simulationTests =
  [ testCase "world is valid until destroyed" $ do
      wd <- defaultWorldDef
      w <- World.create wd
      World.isValid w >>= (@?= True)
      World.destroy w
      World.isValid w >>= (@?= False)
  , testCase "gravity can be read and set" $
      withWorld (Vec3 0 (-10) 0) $ \w -> do
        World.getGravity w >>= (@?= Vec3 0 (-10) 0)
        World.setGravity w (Vec3 0 0 (-20))
        World.getGravity w >>= (@?= Vec3 0 0 (-20))
  , testCase "a body and its shape wire up correctly" $
      withWorld (Vec3 0 (-10) 0) $ \w -> do
        bd <- defaultBodyDef
        b <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = Vec3 0 10 0}
        Body.isValid b >>= (@?= True)
        Body.getType b >>= (@?= DynamicBody)
        Body.getPosition b >>= (@?= Vec3 0 10 0)
        sd <- defaultShapeDef
        s <- Shape.createSphere b sd (Sphere vec3Zero 0.5)
        Shape.isValid s >>= (@?= True)
        Shape.getType s >>= (@?= SphereShape)
        Shape.getBody s >>= (@?= b)
  , testCase "a dynamic body falls under gravity" $
      withWorld (Vec3 0 (-10) 0) $ \w -> do
        b <- dynamicSphere w (Vec3 0 10 0) 0.5
        replicateM_ 60 (World.step w (1 / 60) 4)
        y <- posY <$> Body.getPosition b
        -- one second of free fall from rest under g = -10 lands near y = 5
        assertBool ("body fell, y = " <> show y) (y > 4 && y < 6)
        vy <- posY <$> Body.getLinearVelocity b
        assertBool ("velocity is downward, vy = " <> show vy) (vy < -8)
  , testCase "a dynamic body rests on a static ground" $
      withWorld (Vec3 0 (-10) 0) $ \w -> do
        -- static ground: a large sphere centred at the origin (top at y = 5)
        gd <- defaultBodyDef
        ground <- Body.create w gd
        gsd <- defaultShapeDef
        _ <- Shape.createSphere ground gsd (Sphere vec3Zero 5)
        ball <- dynamicSphere w (Vec3 0 8 0) 0.5
        replicateM_ 240 (World.step w (1 / 60) 4)
        y <- posY <$> Body.getPosition ball
        -- the ball comes to rest on top of the ground: y ~= 5 + 0.5
        assertBool ("ball rests on the ground, y = " <> show y) (y > 5 && y < 6.5)
  ]

-- | Exercise the Tier B path unlocked by the hand-written joint-def Storables:
-- build a @DistanceJointDef@ value (setting fields on the embedded base),
-- create the joint, and confirm it constrains the bodies.
jointTests :: [TestTree]
jointTests =
  [ testCase "a rigid distance joint hangs a body below a static anchor" $
      withWorld (Vec3 0 (-10) 0) $ \w -> do
        gd <- defaultBodyDef
        anchor <- Body.create w gd{bodyDefPosition = Vec3 0 10 0}
        bd <- defaultBodyDef
        hanging <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = Vec3 0 8 0}
        sd <- defaultShapeDef
        _ <- Shape.createSphere hanging sd (Sphere vec3Zero 0.25)
        djd <- defaultDistanceJointDef
        let base = distanceJointDefBase djd
            def =
              djd
                { distanceJointDefBase =
                    base{jointDefBodyIdA = anchor, jointDefBodyIdB = hanging}
                , distanceJointDefLength = 2
                }
        j <- DistanceJoint.create w def
        Joint.isValid j >>= (@?= True)
        Joint.getType j >>= (@?= DistanceJoint)
        Joint.getBodyA j >>= (@?= anchor)
        Joint.getBodyB j >>= (@?= hanging)
        DistanceJoint.getLength j >>= approx 2
        replicateM_ 120 (World.step w (1 / 60) 4)
        -- rigid length 2 below the anchor at (0, 10, 0): settles near y = 8
        y <- posY <$> Body.getPosition hanging
        assertBool ("body hangs ~2 below anchor, y = " <> show y) (y > 7.5 && y < 8.5)
  , testCase "default joint defs round-trip through their Storable" $ do
      let rt mk = mk >>= \x -> roundTrip x >>= (@?= x)
      rt defaultDistanceJointDef
      rt defaultMotorJointDef
      rt defaultParallelJointDef
      rt defaultPrismaticJointDef
      rt defaultRevoluteJointDef
      rt defaultSphericalJointDef
      rt defaultWeldJointDef
      rt defaultWheelJointDef
      rt defaultFilterJointDef
  ]

-- | Exercise the hand-written event-buffer marshalling (roadmap phase 5).
eventTests :: [TestTree]
eventTests =
  [ testCase "a moved body appears in the body move events" $
      withWorld (Vec3 0 (-10) 0) $ \w -> do
        b <- dynamicSphere w (Vec3 0 10 0) 0.5
        replicateM_ 4 (World.step w (1 / 60) 4)
        evs <- Events.bodyMoveEvents w
        assertBool "at least one move event" (not (VS.null evs))
        assertBool
          "the falling body is among the moved bodies"
          (b `VS.elem` VS.map bodyMoveEventBodyId evs)
  , testCase "a body falling through a sensor produces begin and end events" $
      withWorld (Vec3 0 (-10) 0) $ \w -> do
        gd <- defaultBodyDef
        sensorBody <- Body.create w gd
        gsd <- defaultShapeDef
        sensor <-
          Shape.createSphere
            sensorBody
            gsd{shapeDefIsSensor = 1, shapeDefEnableSensorEvents = 1}
            (Sphere vec3Zero 1)
        bd <- defaultBodyDef
        visitor <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = Vec3 0 4 0}
        sd <- defaultShapeDef
        _ <-
          Shape.createSphere
            visitor
            sd{shapeDefEnableSensorEvents = 1}
            (Sphere vec3Zero 0.25)
        (begins, ends) <- collectEvents 240 w $ \acc -> do
          bs <- Events.sensorBeginTouchEvents w
          es <- Events.sensorEndTouchEvents w
          let (b0, e0) = acc
          pure (b0 <> bs, e0 <> es)
        assertBool
          "a begin touch event names the sensor"
          (sensor `VS.elem` VS.map sensorBeginTouchEventSensorShapeId begins)
        assertBool
          "an end touch event names the sensor"
          (sensor `VS.elem` VS.map sensorEndTouchEventSensorShapeId ends)
  , testCase "a landing body produces contact begin, hit, and (once destroyed) end events" $
      withWorld (Vec3 0 (-10) 0) $ \w -> do
        -- static ground: a large sphere centred at the origin (top at y = 5)
        gd <- defaultBodyDef
        ground <- Body.create w gd
        gsd <- defaultShapeDef
        _ <-
          Shape.createSphere
            ground
            gsd{shapeDefEnableContactEvents = 1, shapeDefEnableHitEvents = 1}
            (Sphere vec3Zero 5)
        bd <- defaultBodyDef
        ball <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = Vec3 0 8 0}
        sd <- defaultShapeDef
        bshape <-
          Shape.createSphere
            ball
            sd{shapeDefEnableContactEvents = 1, shapeDefEnableHitEvents = 1}
            (Sphere vec3Zero 0.5)
        (begins, hits) <- collectEvents 120 w $ \acc -> do
          bs <- Events.contactBeginTouchEvents w
          hs <- Events.contactHitEvents w
          let (b0, h0) = acc
          pure (b0 <> bs, h0 <> hs)
        let involves a b e = a e == bshape || b e == bshape
        assertBool
          "a contact begin event involves the ball"
          (VS.any (involves contactBeginTouchEventShapeIdA contactBeginTouchEventShapeIdB) begins)
        assertBool
          "a hit event involves the ball"
          (VS.any (involves contactHitEventShapeIdA contactHitEventShapeIdB) hits)
        assertBool
          "the hit approach speed is positive"
          (VS.all ((> 0) . contactHitEventApproachSpeed) hits && not (VS.null hits))
        -- destroying the touching body ends the contact on the next step
        Body.destroy ball
        World.step w (1 / 60) 4
        ends <- Events.contactEndTouchEvents w
        assertBool
          "a contact end event involves the (destroyed) ball shape"
          (VS.any (involves contactEndTouchEventShapeIdA contactEndTouchEventShapeIdB) ends)
  , testCase "a loaded joint with a low force threshold produces joint events" $
      withWorld (Vec3 0 (-10) 0) $ \w -> do
        gd <- defaultBodyDef
        anchor <- Body.create w gd{bodyDefPosition = Vec3 0 10 0}
        bd <- defaultBodyDef
        hanging <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = Vec3 0 8 0}
        sd <- defaultShapeDef
        _ <- Shape.createSphere hanging sd (Sphere vec3Zero 0.25)
        djd <- defaultDistanceJointDef
        let base = distanceJointDefBase djd
            def =
              djd
                { distanceJointDefBase =
                    base{jointDefBodyIdA = anchor, jointDefBodyIdB = hanging}
                , distanceJointDefLength = 2
                }
        j <- DistanceJoint.create w def
        -- the hanging body loads the joint with ~mg newtons; any tiny
        -- threshold guarantees an event
        Joint.setForceThreshold j 0.01
        (evs, _) <- collectEvents 60 w $ \acc -> do
          es <- Events.jointEvents w
          let (e0, u) = acc
          pure (e0 <> es, u :: ())
        assertBool
          "a joint event names the loaded joint"
          (j `VS.elem` VS.map jointEventJointId evs)
  ]

-- | Step the world @n@ times, folding the per-step event buffers into an
-- accumulator (events only survive until the next step, so they must be
-- collected inside the loop).
collectEvents :: (Monoid acc) => Int -> WorldId -> (acc -> IO acc) -> IO acc
collectEvents n w gather = go n mempty
  where
    go 0 acc = pure acc
    go k acc = do
      World.step w (1 / 60) 4
      acc' <- gather acc
      go (k - 1) acc'

-- | A static body carrying a sphere at the given position.
staticSphere :: WorldId -> Pos -> Float -> IO ShapeId
staticSphere w position radius = do
  bd <- defaultBodyDef
  b <- Body.create w bd{bodyDefPosition = position}
  sd <- defaultShapeDef
  Shape.createSphere b sd (Sphere vec3Zero radius)

-- | Exercise the query/cast structs upgraded to value APIs: 'RayResult',
-- 'QueryFilter', 'MassData', 'RayCastInput' and 'CastOutput' cross the FFI
-- by value instead of as phantom pointers.
queryTests :: [TestTree]
queryTests =
  [ testCase "the default query filter round-trips and accepts everything" $ do
      qf <- defaultQueryFilter
      roundTrip qf >>= (@?= qf)
      assertBool "mask accepts everything" (queryFilterMaskBits qf /= 0)
  , testCase "castRayClosest reports the nearest shape, and misses cleanly" $
      withWorld (Vec3 0 0 0) $ \w -> do
        near <- staticSphere w (Vec3 2 0 0) 0.5
        _far <- staticSphere w (Vec3 4 0 0) 0.5
        qf <- defaultQueryFilter
        r <- World.castRayClosest w (Vec3 0 0 0) (Vec3 10 0 0) qf
        rayResultHit r @?= 1
        rayResultShapeId r @?= near
        -- the near sphere's surface is at x = 1.5, 15% along the ray
        approx 0.15 (rayResultFraction r)
        miss <- World.castRayClosest w (Vec3 0 0 0) (Vec3 (-10) 0 0) qf
        rayResultHit miss @?= 0
  , testCase "body mass data matches the sphere's volume" $
      withWorld (Vec3 0 0 0) $ \w -> do
        b <- dynamicSphere w (Vec3 0 0 0) 0.5
        md <- Body.getMassData b
        -- default density 1000 * (4/3) pi r^3; compare with a relative
        -- tolerance because the absolute value is large for Float
        let
          expected = 1000 * 4 / 3 * pi * 0.125
          m = massDataMass md
        assertBool
          ("mass ~ sphere volume * density, m = " <> show m)
          (abs (m - expected) / expected < 1e-5)
  , testCase "a local-frame ray cast hits a sphere" $ do
      out <- Collision.rayCastSphere (Sphere vec3Zero 1) (RayCastInput (Vec3 (-3) 0 0) (Vec3 6 0 0) 1)
      castOutputHit out @?= 1
      -- enters the unit sphere at x = -1: a third of the way along (6, 0, 0)
      approx (1 / 3) (castOutputFraction out)
  ]

-- | A tiny busy-wait that GHC will not optimise away, to widen a race window.
spin :: Int -> IO ()
spin = go
  where
    go 0 = pure ()
    go k = evaluate k >> go (k - 1)

-- | Stress the closure→'FunPtr' callback path under the multithreaded task
-- system: a custom-filter closure fires from the parallel solver, invoked
-- concurrently from several worker threads.
callbackTests :: [TestTree]
callbackTests =
  [ testCase "overlap and cast-ray closures visit shapes (cast via the C trampoline)" $
      withWorld (Vec3 0 0 0) $ \w -> do
        _ <- staticSphere w (Vec3 2 0 0) 0.5
        _ <- staticSphere w (Vec3 4 0 0) 0.5
        _ <- staticSphere w (Vec3 40 0 0) 0.5
        qf <- defaultQueryFilter
        -- overlap: a plain scalar-args closure, no trampoline needed
        seen <- newIORef (0 :: Int)
        _ <- CB.withOverlapResultFcn (\_ -> modifyIORef' seen (+ 1) >> pure True) $ \fcn ctx ->
          World.overlapAABB w (AABB (Vec3 0 (-1) (-1)) (Vec3 5 1 1)) qf fcn ctx
        readIORef seen >>= (@?= 2)
        -- cast ray: the by-value point/normal cross through the trampoline
        hitsRef <- newIORef []
        _ <- CB.withCastResultFcn
          (\sid point normal frac _matId _triIx _childIx ->
             modifyIORef' hitsRef ((sid, point, normal, frac) :) >> pure 1)
          (\fcn ctx -> World.castRay w (Vec3 0 0 0) (Vec3 10 0 0) qf fcn ctx)
        hits <- readIORef hitsRef
        length hits @?= 2
        let fracs = map (\(_, _, _, f) -> f) hits
        -- surfaces at x = 1.5 and x = 3.5 along a length-10 ray
        approx 0.15 (minimum fracs)
        approx 0.35 (maximum fracs)
        forM_ hits $ \(_, Vec3 px _ _, Vec3 nx _ _, _) -> do
          assertBool ("hit point on a surface, x = " <> show px) (px > 1 && px < 4)
          approx (-1) nx
  , testCase "a pre-solve gate disables contacts (via the C trampoline)" $
      withWorld (Vec3 0 (-10) 0) $ \w -> do
        gd <- defaultBodyDef
        ground <- Body.create w gd
        gsd <- defaultShapeDef
        _ <-
          Shape.createSphere
            ground
            gsd{shapeDefEnablePreSolveEvents = 1}
            (Sphere vec3Zero 5)
        bd <- defaultBodyDef
        ball <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = Vec3 0 8 0}
        sd <- defaultShapeDef
        _ <-
          Shape.createSphere
            ball
            sd{shapeDefEnablePreSolveEvents = 1}
            (Sphere vec3Zero 0.5)
        fired <- newIORef (0 :: Int)
        CB.withPreSolveFcn
          (\_ _ _ _ -> modifyIORef' fired (+ 1) >> pure False)
          $ \fcn ctx -> do
            World.setPreSolveCallback w fcn ctx
            replicateM_ 240 (World.step w (1 / 60) 4)
            World.setPreSolveCallback w nullFunPtr nullPtr
        readIORef fired >>= \n ->
          assertBool ("the gate fired, n = " <> show n) (n > 0)
        -- every contact was vetoed, so the ball fell through the ground
        y <- posY <$> Body.getPosition ball
        assertBool ("ball fell through, y = " <> show y) (y < -5)
  , testCase "friction and restitution mixing closures fire on contact" $
      withWorld (Vec3 0 (-10) 0) $ \w -> do
        fCount <- newIORef (0 :: Int)
        rCount <- newIORef (0 :: Int)
        CB.withFrictionCallback (\fa _ fb _ -> modifyIORef' fCount (+ 1) >> pure (max fa fb)) $ \ffcn ->
          CB.withRestitutionCallback (\ra _ rb _ -> modifyIORef' rCount (+ 1) >> pure (max ra rb)) $ \rfcn -> do
            World.setFrictionCallback w ffcn
            World.setRestitutionCallback w rfcn
            gd <- defaultBodyDef
            ground <- Body.create w gd
            gsd <- defaultShapeDef
            _ <- Shape.createSphere ground gsd (Sphere vec3Zero 5)
            _ <- dynamicSphere w (Vec3 0 6 0) 0.5
            replicateM_ 60 (World.step w (1 / 60) 4)
            -- NULL resets the world to the default mixers before the wrappers die
            World.setFrictionCallback w nullFunPtr
            World.setRestitutionCallback w nullFunPtr
        readIORef fCount >>= \n ->
          assertBool ("friction mixer fired, n = " <> show n) (n > 0)
        readIORef rCount >>= \n ->
          assertBool ("restitution mixer fired, n = " <> show n) (n > 0)
  , testCase "a mover capsule gathers collision planes through the closure" $
      withWorld (Vec3 0 0 0) $ \w -> do
        _ <- staticSphere w (Vec3 0 0 0) 1
        qf <- defaultQueryFilter
        planes <- newIORef []
        CB.withPlaneResultFcn
          (\sid ps -> modifyIORef' planes ((sid, ps) :) >> pure True)
          (\fcn ctx -> World.collideMover w (Vec3 0 0 0) (Capsule (Vec3 1.2 0 0) (Vec3 1.2 0.5 0) 0.4) qf fcn ctx)
        batches <- readIORef planes
        assertBool "at least one plane batch gathered" (not (null batches))
        assertBool "the batches carry planes" (any (not . VS.null . snd) batches)
  , testCase "dynamic-tree query, closest-query and ray-cast closures visit proxies" $
      allocaBytes dynamicTreeByteCount $ \tree -> do
        DynamicTree.create 16 tree
        p0 <- DynamicTree.createProxy tree (AABB (Vec3 0 0 0) (Vec3 1 1 1)) 1 42
        _ <- DynamicTree.createProxy tree (AABB (Vec3 3 0 0) (Vec3 4 1 1)) 1 43
        -- query: only the first box intersects the probe AABB
        seen <- newIORef []
        _ <- CB.withTreeQueryFcn (\pid ud -> modifyIORef' seen ((pid, ud) :) >> pure True) $ \fcn ctx ->
          DynamicTree.query tree (AABB (Vec3 (-0.5) 0.25 0.25) (Vec3 0.5 0.75 0.75)) maxBound False fcn ctx
        readIORef seen >>= (@?= [(fromIntegral p0, 42)])
        -- closest query from between the boxes visits at least one proxy
        closestSeen <- newIORef (0 :: Int)
        _ <- alloca $ \pOut -> do
          poke pOut 1e9
          CB.withTreeQueryClosestFcn
            (\dmin _pid _ud -> modifyIORef' closestSeen (+ 1) >> pure dmin)
            (\fcn ctx -> DynamicTree.queryClosest tree (Vec3 2 0.5 0.5) maxBound False fcn ctx pOut)
        readIORef closestSeen >>= \n ->
          assertBool ("closest query visited proxies, n = " <> show n) (n >= 1)
        -- a ray along y = z = 0.5 pierces both boxes
        hits <- newIORef (0 :: Int)
        _ <- CB.withTreeRayCastFcn
          (\input _pid _ud -> do
             rayCastInputMaxFraction input @?= 1
             modifyIORef' hits (+ 1)
             pure 1)
          (\fcn ctx ->
             DynamicTree.rayCast tree (RayCastInput (Vec3 (-1) 0.5 0.5) (Vec3 6 0 0) 1) maxBound False fcn ctx)
        readIORef hits >>= (@?= 2)
        DynamicTree.destroy tree
  , testCase "custom-filter closures survive concurrent hot-path invocation" $
      CB.withThreadPoolTaskSystem 4 $ \ts -> do
        total <- newIORef (0 :: Int)
        inFlight <- newIORef (0 :: Int)
        maxSeen <- newIORef (0 :: Int)
        let onFilter _ _ _ = do
              n <- atomicModifyIORef' inFlight (\x -> (x + 1, x + 1))
              atomicModifyIORef' maxSeen (\m -> (max m n, ()))
              spin 4000
              atomicModifyIORef' total (\x -> (x + 1, ()))
              atomicModifyIORef' inFlight (\x -> (x - 1, ()))
              pure True
        CB.withCustomFilterFcn onFilter $ \fcn -> do
          wd <- defaultWorldDef
          w <-
            World.create
              wd
                { worldDefGravity = Vec3 0 (-10) 0
                , worldDefEnableSleep = 0
                , worldDefWorkerCount = fromIntegral (CB.taskWorkerCount ts)
                , worldDefEnqueueTask = CB.taskEnqueue ts
                , worldDefFinishTask = CB.taskFinish ts
                }
          World.setCustomFilterCallback w fcn nullPtr
          bd <- defaultBodyDef
          sd <- defaultShapeDef
          forM_ [0 .. 255 :: Int] $ \i -> do
            let
              col = fromIntegral (i `mod` 8)
              row = fromIntegral ((i `div` 8) `mod` 8)
              lay = fromIntegral (i `div` 64)
              pos = Vec3 (col - 4) (1.5 + lay * 1.1) (row - 4)
            b <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = pos}
            _ <- Shape.createSphere b sd{shapeDefEnableCustomFiltering = 1} (Sphere vec3Zero 0.5)
            pure ()
          replicateM_ 300 (World.step w (1 / 60) 4)
          World.setCustomFilterCallback w nullFunPtr nullPtr
          World.isValid w >>= (@?= True)
          World.destroy w
        calls <- readIORef total
        peak <- readIORef maxSeen
        assertBool ("callback fired under load, calls = " <> show calls) (calls > 100)
        assertBool
          ("callback was invoked concurrently, peak overlap = " <> show peak)
          (peak >= 2)
  ]