{-# LANGUAGE ForeignFunctionInterface #-}

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 Foreign.C.Types (CBool (..))

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

import Box2D.Base qualified as Base
import Box2D.Body qualified as Body
import Box2D.Callbacks qualified as CB
import Box2D.Chain qualified as Chain
import Box2D.Collision qualified as Collision
import Box2D.DistanceJoint qualified as DistanceJoint
import Box2D.DynamicTree qualified as DynamicTree
import Box2D.Events qualified as Events
import Box2D.Id
import Box2D.Joint qualified as Joint
import Box2D.MathFunctions
import Box2D.MathTypes
import Box2D.Shape qualified as Shape
import Box2D.UserData qualified as UD
import Box2D.Tags (CustomFilterFcn)
import Box2D.Types
import Box2D.World qualified as World

main :: IO ()
-- Box2D 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
    "Box2D"
    [ testGroup "Base" baseTests
    , testGroup "MathTypes" mathTypesTests
    , testGroup "MathFunctions" mathFunctionsTests
    , testGroup "Id" idTests
    , testGroup "Types" typesTests
    , testGroup "Simulation" simulationTests
    , testGroup "Generated breadth" generatedTests
    , testGroup "Joints" jointTests
    , testGroup "Events" eventTests
    , testGroup "Queries" queryTests
    , testGroup "Polygons and chains" polygonTests
    , 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 3.2.0" $ do
      v <- Base.getVersion
      Base.versionMajor v @?= 3
      Base.versionMinor v @?= 2
      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 "type sizes match the C ABI" $ do
      sizeOf (Vec2 0 0) @?= 8
      sizeOf (Rot 1 0) @?= 8
      sizeOf (Transform vec2Zero rotIdentity) @?= 16
      sizeOf (Mat22 vec2Zero vec2Zero) @?= 16
      sizeOf (AABB vec2Zero vec2Zero) @?= 16
      sizeOf (Plane vec2Zero 0) @?= 12
  , testCase "Vec2 round-trips" $
      roundTrip (Vec2 1 2) >>= (@?= Vec2 1 2)
  , testCase "Transform round-trips" $ do
      let t = Transform (Vec2 1 2) (Rot 0.6 0.8)
      roundTrip t >>= (@?= t)
  , testCase "AABB round-trips" $ do
      let a = AABB (Vec2 (-1) (-2)) (Vec2 3 4)
      roundTrip a >>= (@?= a)
  ]

mathFunctionsTests :: [TestTree]
mathFunctionsTests =
  [ testCase "finite vector is valid" $
      isValidVec2 (Vec2 1 2) >>= (@?= True)
  , testCase "NaN vector is invalid" $
      isValidVec2 (Vec2 (0 / 0) 0) >>= (@?= False)
  , testCase "infinite vector is invalid" $
      isValidVec2 (Vec2 (1 / 0) 0) >>= (@?= False)
  , testCase "identity rotation is valid" $
      isValidRotation rotIdentity >>= (@?= True)
  , testCase "identity transform is valid" $
      isValidTransform transformIdentity >>= (@?= True)
  , testCase "computeCosSin 0 = (1, 0)" $ do
      CosSin c s <- computeCosSin 0
      approx 1 c
      approx 0 s
  , testCase "makeRot 0 is the identity" $ do
      Rot c s <- makeRot 0
      approx 1 c
      approx 0 s
  , testCase "rotGetAngle recovers the angle" $ do
      approx 1.2 (rotGetAngle (Rot (cos 1.2) (sin 1.2)))
      approx 0 . rotGetAngle =<< makeRot 0
      -- makeRot uses an approximate cos/sin, so its round-trip is loose
      r <- makeRot 1.2
      let a = rotGetAngle r
      assertBool ("~1.2 through makeRot, got " <> show a) (abs (a - 1.2) < 5e-3)
  , testCase "makeRot pi/2 is a quarter turn" $ do
      Rot c s <- makeRot (pi / 2)
      approx 0 c
      approx 1 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 @?= Vec2 0 (-10)
      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 @?= rotIdentity
      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 @?= 1
      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 "Circle round-trips" $ do
      let c = Circle (Vec2 1 2) 0.5
      roundTrip c >>= (@?= c)
  , testCase "Capsule round-trips" $ do
      let c = Capsule (Vec2 0 0) (Vec2 0 1) 0.25
      roundTrip c >>= (@?= c)
  , testCase "Segment round-trips" $ do
      let s = Segment (Vec2 (-1) 0) (Vec2 1 0)
      roundTrip s >>= (@?= s)
  , testCase "shape types case as patterns (COMPLETE, no wildcard)" $
      withWorld (Vec2 0 0) $ \w -> do
        bd <- defaultBodyDef
        b <- Body.create w bd
        sd <- defaultShapeDef
        sh <- Shape.createCircle b sd (Circle vec2Zero 0.5)
        ty <- Shape.getType sh
        let name = case ty of
              CircleShape -> "circle"
              CapsuleShape -> "capsule"
              SegmentShape -> "segment"
              PolygonShape -> "polygon"
              ChainSegmentShape -> "chain segment"
        name @?= ("circle" :: String)
  ]

-- | Build a world with the given gravity and default settings.
withWorld :: Vec2 -> (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 circle at the given position.
dynamicCircle :: WorldId -> Pos -> Float -> IO BodyId
dynamicCircle w position radius = do
  bd <- defaultBodyDef
  b <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = position}
  sd <- defaultShapeDef
  _ <- Shape.createCircle b sd (Circle vec2Zero radius)
  pure b

posY :: Vec2 -> Float
posY (Vec2 _ 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 (Vec2 0 (-10)) $ \w -> do
        World.getGravity w >>= (@?= Vec2 0 (-10))
        World.setGravity w (Vec2 0 (-20))
        World.getGravity w >>= (@?= Vec2 0 (-20))
  , testCase "a body and its shape wire up correctly" $
      withWorld (Vec2 0 (-10)) $ \w -> do
        bd <- defaultBodyDef
        b <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = Vec2 0 10}
        Body.isValid b >>= (@?= True)
        Body.getType b >>= (@?= DynamicBody)
        Body.getPosition b >>= (@?= Vec2 0 10)
        sd <- defaultShapeDef
        s <- Shape.createCircle b sd (Circle vec2Zero 0.5)
        Shape.isValid s >>= (@?= True)
        Shape.getType s >>= (@?= CircleShape)
        Shape.getBody s >>= (@?= b)
  , testCase "a dynamic body falls under gravity" $
      withWorld (Vec2 0 (-10)) $ \w -> do
        b <- dynamicCircle w (Vec2 0 10) 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 segment" $
      withWorld (Vec2 0 (-10)) $ \w -> do
        gd <- defaultBodyDef
        ground <- Body.create w gd
        gsd <- defaultShapeDef
        _ <- Shape.createSegment ground gsd (Segment (Vec2 (-20) 0) (Vec2 20 0))
        ball <- dynamicCircle w (Vec2 0 5) 0.5
        replicateM_ 240 (World.step w (1 / 60) 4)
        y <- posY <$> Body.getPosition ball
        -- the ball comes to rest on top of the segment: y ~= 0.5
        assertBool ("ball rests on the ground, y = " <> show y) (y > 0.3 && y < 0.7)
  ]

{- | Exercise a spread of functions that only exist thanks to the generator:
Tier A scalar/bool accessors, a coerced enum, and the @b2AABB@-returning
shim (b2World_GetBounds), none of which the hand-written layer bound.
-}
generatedTests :: [TestTree]
generatedTests =
  [ testCase "body mass, density and awake flag are readable" $
      withWorld (Vec2 0 (-10)) $ \w -> do
        b <- dynamicCircle w (Vec2 0 10) 0.5
        m <- Body.getMass b
        assertBool ("mass is positive, m = " <> show m) (m > 0)
        Body.getGravityScale b >>= approx 1
        Body.setAwake b True
        Body.isAwake b >>= (@?= True)
  , testCase "shape density defaults to 1" $
      withWorld (Vec2 0 (-10)) $ \w -> do
        bd <- defaultBodyDef
        b <- Body.create w bd{bodyDefType = DynamicBody}
        sd <- defaultShapeDef
        shp <- Shape.createCircle b sd (Circle vec2Zero 0.5)
        Shape.getDensity shp >>= approx 1
        Shape.getType shp >>= (@?= CircleShape)
  , testCase "world reports awake bodies and finite bounds" $
      withWorld (Vec2 0 (-10)) $ \w -> do
        _ <- dynamicCircle w (Vec2 0 10) 0.5
        World.step w (1 / 60) 4
        n <- World.getAwakeBodyCount w
        assertBool ("at least one awake body, n = " <> show n) (n >= 1)
        World.isSleepingEnabled w >>= (@?= True)
        bounds <- World.getBounds w
        isValidAABB bounds >>= (@?= True)
  ]

-- | 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 (Vec2 0 (-10)) $ \w -> do
        gd <- defaultBodyDef
        anchor <- Body.create w gd{bodyDefPosition = Vec2 0 10}
        bd <- defaultBodyDef
        hanging <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = Vec2 0 8}
        sd <- defaultShapeDef
        _ <- Shape.createCircle hanging sd (Circle vec2Zero 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): the body 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 defaultPrismaticJointDef
      rt defaultRevoluteJointDef
      rt defaultWeldJointDef
      rt defaultWheelJointDef
      rt defaultFilterJointDef
  ]

-- | Exercise the hand-written event-buffer marshalling (roadmap phase 5): the
-- generated @World.getBodyEvents@ returns the raw buffer, "Box2D.Events" copies
-- the elements into a list.
eventTests :: [TestTree]
eventTests =
  [ testCase "a moved body appears in the body move events" $
      withWorld (Vec2 0 (-10)) $ \w -> do
        b <- dynamicCircle w (Vec2 0 10) 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 (Vec2 0 (-10)) $ \w -> do
        gd <- defaultBodyDef
        sensorBody <- Body.create w gd
        gsd <- defaultShapeDef
        sensor <-
          Shape.createCircle
            sensorBody
            gsd{shapeDefIsSensor = 1, shapeDefEnableSensorEvents = 1}
            (Circle vec2Zero 1)
        bd <- defaultBodyDef
        visitor <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = Vec2 0 4}
        sd <- defaultShapeDef
        _ <-
          Shape.createCircle
            visitor
            sd{shapeDefEnableSensorEvents = 1}
            (Circle vec2Zero 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 (Vec2 0 (-10)) $ \w -> do
        gd <- defaultBodyDef
        ground <- Body.create w gd
        gsd <- defaultShapeDef
        _ <-
          Shape.createSegment
            ground
            gsd{shapeDefEnableContactEvents = 1, shapeDefEnableHitEvents = 1}
            (Segment (Vec2 (-10) 0) (Vec2 10 0))
        bd <- defaultBodyDef
        ball <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = Vec2 0 3}
        sd <- defaultShapeDef
        bshape <-
          Shape.createCircle
            ball
            sd{shapeDefEnableContactEvents = 1, shapeDefEnableHitEvents = 1}
            (Circle vec2Zero 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 (Vec2 0 (-10)) $ \w -> do
        gd <- defaultBodyDef
        anchor <- Body.create w gd{bodyDefPosition = Vec2 0 10}
        bd <- defaultBodyDef
        hanging <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = Vec2 0 8}
        sd <- defaultShapeDef
        _ <- Shape.createCircle hanging sd (Circle vec2Zero 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'

-- | Exercise the Polygon/Hull/ChainDef/ExplosionDef value APIs requested by
-- downstream (apecs-box2d): boxes, arbitrary hulls, chain terrain, explosions
-- and integer user data.
polygonTests :: [TestTree]
polygonTests =
  [ testCase "makeBox round-trips and gives a unit box the right mass" $
      withWorld (Vec2 0 0) $ \w -> do
        box <- Collision.makeBox 0.5 0.5
        VS.length (polygonVertices box) @?= 4
        VS.length (polygonNormals box) @?= 4
        roundTrip box >>= (@?= box)
        bd <- defaultBodyDef
        b <- Body.create w bd{bodyDefType = DynamicBody}
        sd <- defaultShapeDef
        sh <- Shape.createPolygon b sd box
        Shape.getType sh >>= (@?= PolygonShape)
        -- a 1x1 box at density 1
        md <- Body.getMassData b
        approx 1 (massDataMass md)
  , testCase "computeHull and makePolygon build a triangle" $
      VS.unsafeWith (VS.fromList [Vec2 0 0, Vec2 1 0, Vec2 0 1]) $ \pts -> do
        hull <- Collision.computeHull pts 3
        VS.length (hullPoints hull) @?= 3
        tri <- Collision.makePolygon hull 0
        VS.length (polygonVertices tri) @?= 3
        polygonRadius tri @?= 0
  , testCase "a chain assembles from a point array" $
      withWorld (Vec2 0 (-10)) $ \w -> do
        gd <- defaultBodyDef
        ground <- Body.create w gd
        cd <- defaultChainDef
        let points = VS.fromList [Vec2 (-6) 2, Vec2 (-4) 0, Vec2 0 0, Vec2 4 0, Vec2 6 2]
        c <- VS.unsafeWith points $ \pts ->
          Chain.create ground cd{chainDefPoints = pts, chainDefCount = fromIntegral (VS.length points)}
        Chain.isValid c >>= (@?= True)
        n <- Chain.getSegmentCount c
        assertBool ("chain has segments, n = " <> show n) (n > 0)
        Chain.destroy c
  , testCase "an explosion pushes a nearby body away" $
      withWorld (Vec2 0 0) $ \w -> do
        b <- dynamicCircle w (Vec2 1 0) 0.5
        ed <- defaultExplosionDef
        World.explode
          w
          ed
            { explosionDefPosition = Vec2 0 0
            , explosionDefRadius = 2
            , explosionDefImpulsePerLength = 5
            }
        Vec2 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 (Vec2 0 0) $ \w -> do
        bd <- defaultBodyDef
        b <- Body.create w bd
        sd <- defaultShapeDef
        sh <- Shape.createCircle b sd (Circle vec2Zero 0.5)
        UD.setUserIndex b 42
        UD.getUserIndex b >>= (@?= 42)
        UD.setUserIndex sh maxBound
        UD.getUserIndex sh >>= (@?= maxBound)
        -- negative ids survive the pointer pun
        UD.setUserIndex b (-7)
        UD.getUserIndex b >>= (@?= (-7))
  ]

-- | A static body carrying a circle at the given position.
staticCircle :: WorldId -> Pos -> Float -> IO ShapeId
staticCircle w position radius = do
  bd <- defaultBodyDef
  b <- Body.create w bd{bodyDefPosition = position}
  sd <- defaultShapeDef
  Shape.createCircle b sd (Circle vec2Zero 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 (Vec2 0 0) $ \w -> do
        near <- staticCircle w (Vec2 2 0) 0.5
        _far <- staticCircle w (Vec2 4 0) 0.5
        qf <- defaultQueryFilter
        r <- World.castRayClosest w (Vec2 0 0) (Vec2 10 0) qf
        rayResultHit r @?= 1
        rayResultShapeId r @?= near
        -- the near circle's surface is at x = 1.5, 15% along the ray
        approx 0.15 (rayResultFraction r)
        miss <- World.castRayClosest w (Vec2 0 0) (Vec2 (-10) 0) qf
        rayResultHit miss @?= 0
  , testCase "body mass data matches the circle's area" $
      withWorld (Vec2 0 0) $ \w -> do
        b <- dynamicCircle w (Vec2 0 0) 0.5
        md <- Body.getMassData b
        -- density 1 * pi r^2
        approx (pi * 0.25) (massDataMass md)
  , testCase "a local-frame ray cast hits a circle" $ do
      out <- Collision.rayCastCircle (Circle vec2Zero 1) (RayCastInput (Vec2 (-3) 0) (Vec2 6 0) 1)
      castOutputHit out @?= 1
      -- enters the unit circle at x = -1: a third of the way along (6, 0)
      approx (1 / 3) (castOutputFraction out)
  ]

-- | The C custom-filter callback: @bool (b2ShapeId, b2ShapeId, void*)@.
type CustomFilterCb = ShapeId -> ShapeId -> Ptr () -> IO CBool

foreign import ccall "wrapper"
  mkCustomFilterCb :: CustomFilterCb -> IO (FunPtr CustomFilterCb)

-- | Exercise the raw-'FunPtr' callback passthrough: wrap a Haskell closure and
-- confirm the engine invokes it during the (safe) 'Box2D.World.step'.
callbackTests :: [TestTree]
callbackTests =
  [ testCase "a custom-filter callback fires during the step" $
      withWorld (Vec2 0 0) $ \w -> do
        fired <- newIORef False
        cb <- mkCustomFilterCb $ \_ _ _ -> writeIORef fired True >> pure 1
        World.setCustomFilterCallback w (castFunPtr cb) nullPtr
        let overlappingCircle = do
              bd <- defaultBodyDef
              b <- Body.create w bd{bodyDefType = DynamicBody}
              sd <- defaultShapeDef
              _ <- Shape.createCircle b sd{shapeDefEnableCustomFiltering = 1} (Circle vec2Zero 0.5)
              pure b
        _ <- overlappingCircle
        _ <- overlappingCircle
        replicateM_ 8 (World.step w (1 / 60) 4)
        -- unhook before freeing the wrapper so the world never dangles it
        World.setCustomFilterCallback w nullFunPtr nullPtr
        freeHaskellFunPtr cb
        readIORef fired >>= (@?= True)
  , testCase "overlap and cast-ray closures visit shapes (cast via the C trampoline)" $
      withWorld (Vec2 0 0) $ \w -> do
        _ <- staticCircle w (Vec2 2 0) 0.5
        _ <- staticCircle w (Vec2 4 0) 0.5
        _ <- staticCircle w (Vec2 40 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 (Vec2 0 0) (AABB (Vec2 0 (-1)) (Vec2 5 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 -> modifyIORef' hitsRef ((sid, point, normal, frac) :) >> pure 1)
          (\fcn ctx -> World.castRay w (Vec2 0 0) (Vec2 10 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 $ \(_, Vec2 px _, Vec2 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 (Vec2 0 (-10)) $ \w -> do
        gd <- defaultBodyDef
        ground <- Body.create w gd
        gsd <- defaultShapeDef
        _ <-
          Shape.createSegment
            ground
            gsd{shapeDefEnablePreSolveEvents = 1}
            (Segment (Vec2 (-10) 0) (Vec2 10 0))
        bd <- defaultBodyDef
        ball <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = Vec2 0 2}
        sd <- defaultShapeDef
        _ <-
          Shape.createCircle
            ball
            sd{shapeDefEnablePreSolveEvents = 1}
            (Circle vec2Zero 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 < 0)
  , testCase "friction and restitution mixing closures fire on contact" $
      withWorld (Vec2 0 (-10)) $ \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.createSegment ground gsd (Segment (Vec2 (-10) 0) (Vec2 10 0))
            _ <- dynamicCircle w (Vec2 0 1) 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 (Vec2 0 0) $ \w -> do
        _ <- staticCircle w (Vec2 0 0) 1
        qf <- defaultQueryFilter
        planes <- newIORef []
        CB.withPlaneResultFcn
          (\sid pr -> modifyIORef' planes ((sid, pr) :) >> pure True)
          (\fcn ctx -> World.collideMover w (Vec2 0 0) (Capsule (Vec2 1.2 0) (Vec2 1.2 0.5) 0.4) qf fcn ctx)
        ps <- readIORef planes
        assertBool "at least one plane gathered" (not (null ps))
        assertBool "a plane registered a hit" (any ((== 1) . planeResultHit . snd) ps)
  , testCase "dynamic-tree query and ray-cast closures visit proxies" $
      allocaBytes dynamicTreeByteCount $ \tree -> do
        DynamicTree.create 16 tree
        p0 <- DynamicTree.createProxy tree (AABB (Vec2 0 0) (Vec2 1 1)) 1 42
        _ <- DynamicTree.createProxy tree (AABB (Vec2 3 0) (Vec2 4 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 (Vec2 (-0.5) 0.25) (Vec2 0.5 0.75)) maxBound fcn ctx
        readIORef seen >>= (@?= [(fromIntegral p0, 42)])
        -- a ray along y = 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 (Vec2 (-1) 0.5) (Vec2 6 0) 1) maxBound 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)
        -- track how many callback invocations overlap, and widen the window a
        -- little so genuine parallelism actually shows up
        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 = Vec2 0 (-10)
                , worldDefEnableSleep = 0
                , worldDefWorkerCount = fromIntegral (CB.taskWorkerCount ts)
                , worldDefEnqueueTask = CB.taskEnqueue ts
                , worldDefFinishTask = CB.taskFinish ts
                }
          World.setCustomFilterCallback w fcn nullPtr
          -- a static ground plus a 16x16 grid of custom-filtered circles: lots
          -- of broad-phase pairs churning through the parallel solver
          gd <- defaultBodyDef
          ground <- Body.create w gd
          gsd <- defaultShapeDef
          _ <- Shape.createSegment ground gsd (Segment (Vec2 (-40) 0) (Vec2 40 0))
          bd <- defaultBodyDef
          sd <- defaultShapeDef
          forM_ [0 .. 255 :: Int] $ \i -> do
            let
              col = fromIntegral (i `mod` 16)
              row = fromIntegral (i `div` 16)
              pos = Vec2 (col - 8) (1.5 + row * 1.1)
            b <- Body.create w bd{bodyDefType = DynamicBody, bodyDefPosition = pos}
            _ <- Shape.createCircle b sd{shapeDefEnableCustomFiltering = 1} (Circle vec2Zero 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)
  ]

-- | 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)