Box2D-0.1.0.0: test/Spec.hs

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE PatternSynonyms #-}

module Main (main) where

import Control.Concurrent (getNumCapabilities, yield)
import Control.Exception (ErrorCall (..), bracket, evaluate, try)
import Control.Monad (forM_, replicateM_, unless, when)
import Data.IORef
import Data.Vector.Storable qualified as VS
import Foreign
import Foreign.C.Types (CBool (..))
import GHC.Clock (getMonotonicTime)

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.Contact qualified as Contact
import Box2D.DistanceJoint qualified as DistanceJoint
import Box2D.DynamicTree qualified as DynamicTree
import Box2D.Events qualified as Events
import Box2D.Extra (withShapeProxy)
import Box2D.Id (BodyId (..), ChainId, ContactId (..), ShapeId (..), WorldId (..), nullBodyId, nullContactId, nullWorldId)
import Box2D.Joint qualified as Joint
import Box2D.MathFunctions
import Box2D.MathTypes
import Box2D.Mover qualified as Mover
import Box2D.Shape qualified as Shape
import Box2D.UserData qualified as UD
import Box2D.World qualified as World

import Box2D.Body (BodyDef (..), defaultBodyDef, pattern DynamicBody, pattern StaticBody)
import Box2D.Collision (CollisionPlane (..), Manifold (..), PlaneResult (..))
import Box2D.Contact (ContactData (..))
import Box2D.DebugDraw (DebugDraw (..), defaultDebugDraw)
import Box2D.Distance (SimplexCache (..))
import Box2D.DistanceJoint (DistanceJointDef (..), defaultDistanceJointDef)
import Box2D.FilterJoint (defaultFilterJointDef)
import Box2D.Geometry (Capsule (..), CastOutput (..), Circle (..), Hull (..), MassData (..), Polygon (..), RayCastInput (..), Segment (..), ShapeProxy (..))
import Box2D.Joint (JointDef (..), pattern DistanceJoint)
import Box2D.MotorJoint (defaultMotorJointDef)
import Box2D.PrismaticJoint (defaultPrismaticJointDef)
import Box2D.RevoluteJoint (defaultRevoluteJointDef)
import Box2D.Shape (QueryFilter (..), ShapeDef (..), defaultFilter, defaultQueryFilter, defaultShapeDef, defaultSurfaceMaterial, pattern CapsuleShape, pattern ChainSegmentShape, pattern CircleShape, pattern PolygonShape, pattern SegmentShape)
import Box2D.WeldJoint (defaultWeldJointDef)
import Box2D.WheelJoint (defaultWheelJointDef)
import Box2D.World (BodyMoveEvent (..), ContactBeginTouchEvent (..), ContactEndTouchEvent (..), ContactHitEvent (..), ExplosionDef (..), JointEvent (..), RayResult (..), SensorBeginTouchEvent (..), SensorEndTouchEvent (..), WorldDef (..), defaultExplosionDef, defaultWorldDef)

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 "Proxies, contacts and the mover" moverTests
    , 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
      v.major @?= 3
      v.minor @?= 2
      v.revision @?= 0
  , testCase "getByteCount is non-negative" $ do
      n <- Base.getByteCount
      assertBool "byte count >= 0" (n >= 0)
  , testCase "isDoublePrecision matches the size of Pos" $ do
      dp <- Base.isDoublePrecision
      sizeOf (undefined :: Pos) @?= if dp then 16 else 8
  ]

mathTypesTests :: [TestTree]
mathTypesTests =
  [ testCase "Pos and WorldTransform round-trip through Storable" $ do
      roundTrip (Pos 1.5 (-2.5)) >>= (@?= Pos 1.5 (-2.5))
      let xf = WorldTransform (Pos 3 4) (Rot 0 1)
      roundTrip xf >>= (@?= xf)
  , testCase "world position helpers cross the Pos/Vec2 boundary" $ do
      let xf = WorldTransform (Pos 10 20) (Rot 0 1)
      toVec2 (toPos (Vec2 1.5 2.5)) @?= Vec2 1.5 2.5
      subPos (Pos 5 7) (Pos 2 3) @?= Vec2 3 4
      offsetPos (Pos 1 2) (Vec2 3 4) @?= Pos 4 6
      transformWorldPoint xf (Vec2 1 0) @?= Pos 10 21
      invTransformWorldPoint xf (Pos 10 21) @?= Vec2 1 0
      toRelativeTransform xf (Pos 9 18) @?= Transform (Vec2 1 2) (Rot 0 1)
      makeWorldTransform (Transform (Vec2 1 2) (Rot 0 1)) @?= WorldTransform (Pos 1 2) (Rot 0 1)
  , 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" $
      isValidRot 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
      d.gravity @?= Vec2 0 (-10)
      d.contactHertz @?= 30
      d.enableSleep @?= 1
      assertBool "internalValue cookie is set" (d.internalValue /= 0)
  , testCase "default world def round-trips" $ do
      d <- defaultWorldDef
      roundTrip d >>= (@?= d)
  , testCase "default body def has expected fields" $ do
      d <- defaultBodyDef
      d.type_ @?= StaticBody
      d.rotation @?= rotIdentity
      d.gravityScale @?= 1
      assertBool "internalValue cookie is set" (d.internalValue /= 0)
  , testCase "default body def round-trips" $ do
      d <- defaultBodyDef
      roundTrip d >>= (@?= d)
  , testCase "default shape def has expected fields" $ do
      d <- defaultShapeDef
      d.density @?= 1
      d.updateBodyMass @?= 1
      assertBool "internalValue cookie is set" (d.internalValue /= 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" $
      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"
              _ -> "unknown"
        name @?= ("circle" :: String)
  , testCase "a warm SimplexCache round-trips its indices" $ do
      let cache = SimplexCache (VS.fromList [1, 2, 3]) (VS.fromList [4, 5, 6])
      roundTrip cache >>= (@?= cache)
  , testCase "a SimplexCache count follows its shorter index array" $
      roundTrip (SimplexCache (VS.fromList [1, 2]) (VS.fromList [3]))
        >>= (@?= SimplexCache (VS.fromList [1]) (VS.fromList [3]))
  , testCase "a SimplexCache with a garbage count stays inside its arrays" $
      alloca $ \(p :: Ptr SimplexCache) -> do
        fillBytes p 0xff (sizeOf (undefined :: SimplexCache))
        cache <- peek p
        VS.length cache.indexA @?= 3
        VS.length cache.indexB @?= 3
  , testCase "Counters reads a live world with full-length arrays" $
      withWorld (Vec2 0 (-10)) $ \w -> do
        _ <- dynamicCircle w (Pos 0 5) 0.5
        _ <- dynamicCircle w (Pos 3 5) 0.5
        World.step w (1 / 60) 4
        counters <- alloca $ \p -> World.getCounters w p >> peek p
        counters.bodyCount @?= 2
        VS.length counters.colorCounts @?= 24
        assertBool "byte count is positive" (counters.byteCount > 0)
  ]

-- | 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{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{type_ = DynamicBody, position = position}
  sd <- defaultShapeDef
  _ <- Shape.createCircle b sd (Circle vec2Zero radius)
  pure b

createOpenChain :: BodyId -> VS.Vector Vec2 -> IO ChainId
createOpenChain body points = do
  cd <- Chain.defaultChainDef
  VS.unsafeWith points $ \pts ->
    Chain.create
      body
      cd
        { Chain.points = pts
        , Chain.pointCount = fromIntegral (VS.length points)
        , Chain.ghost1 = extrapolate (VS.head points) (points VS.! 1)
        , Chain.ghost2 = extrapolate (VS.last points) (points VS.! (VS.length points - 2))
        }
  where
    extrapolate end inner = vec2Sub (vec2Scale 2 end) inner

posY :: Pos -> Float
posY p = y
  where
    Vec2 _ y = toVec2 p

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{type_ = DynamicBody, position = Pos 0 10}
        Body.isValid b >>= (@?= True)
        Body.getType b >>= (@?= DynamicBody)
        Body.getPosition b >>= (@?= Pos 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 (Pos 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)
        Vec2 _ vy <- 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 (Pos 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 (Pos 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{type_ = 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 (Pos 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{Body.position = Pos 0 10}
        bd <- defaultBodyDef
        hanging <- Body.create w bd{type_ = DynamicBody, position = Pos 0 8}
        sd <- defaultShapeDef
        _ <- Shape.createCircle hanging sd (Circle vec2Zero 0.25)
        djd <- defaultDistanceJointDef
        let
          base = djd.base
          def =
            djd
              { base =
                  base{bodyIdA = anchor, bodyIdB = hanging}
              , length = 2
              }
        j <- DistanceJoint.create w def
        Joint.isValid j >>= (@?= True)
        Joint.getType j >>= (@?= DistanceJoint)
        Joint.getBodyA j >>= (@?= anchor)
        Joint.getBodyB j >>= (@?= hanging)
        DistanceJoint.getRestLength 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 (Pos 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 (.bodyId) 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{isSensor = 1, enableSensorEvents = 1}
            (Circle vec2Zero 1)
        bd <- defaultBodyDef
        visitor <- Body.create w bd{type_ = DynamicBody, position = Pos 0 4}
        sd <- defaultShapeDef
        _ <-
          Shape.createCircle
            visitor
            sd{enableSensorEvents = 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 (.sensorShapeId) begins)
        assertBool
          "an end touch event names the sensor"
          (sensor `VS.elem` VS.map (.sensorShapeId) 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{enableContactEvents = 1, enableHitEvents = 1}
            (Segment (Vec2 (-10) 0) (Vec2 10 0))
        bd <- defaultBodyDef
        ball <- Body.create w bd{type_ = DynamicBody, position = Pos 0 3}
        sd <- defaultShapeDef
        bshape <-
          Shape.createCircle
            ball
            sd{enableContactEvents = 1, enableHitEvents = 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 (.shapeIdA) (.shapeIdB)) begins)
        assertBool
          "a hit event involves the ball"
          (VS.any (involves (.shapeIdA) (.shapeIdB)) hits)
        assertBool
          "the hit approach speed is positive"
          (VS.all ((> 0) . (.approachSpeed)) 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 (.shapeIdA) (.shapeIdB)) 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{Body.position = Pos 0 10}
        bd <- defaultBodyDef
        hanging <- Body.create w bd{type_ = DynamicBody, position = Pos 0 8}
        sd <- defaultShapeDef
        _ <- Shape.createCircle hanging sd (Circle vec2Zero 0.25)
        djd <- defaultDistanceJointDef
        let
          base = djd.base
          def =
            djd
              { base =
                  base{bodyIdA = anchor, bodyIdB = hanging}
              , length = 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 (.jointId) 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 (box.vertices) @?= 4
        VS.length (box.normals) @?= 4
        roundTrip box >>= (@?= box)
        bd <- defaultBodyDef
        b <- Body.create w bd{type_ = 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 (md.mass)
  , 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 (hull.points) @?= 3
        tri <- Collision.makePolygon hull 0
        VS.length (tri.vertices) @?= 3
        tri.radius @?= 0
  , testCase "a chain assembles from a point array" $
      withWorld (Vec2 0 (-10)) $ \w -> do
        gd <- defaultBodyDef
        ground <- Body.create w gd
        c <- createOpenChain ground (VS.fromList [Vec2 (-6) 2, Vec2 (-4) 0, Vec2 0 0, Vec2 4 0, Vec2 6 2])
        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 (Pos 1 0) 0.5
        ed <- defaultExplosionDef
        World.explode
          w
          ed
            { position = Pos 0 0
            , radius = 2
            , impulsePerLength = 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{Body.position = 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" (qf.maskBits /= 0)
  , testCase "castRayClosest reports the nearest shape, and misses cleanly" $
      withWorld (Vec2 0 0) $ \w -> do
        near <- staticCircle w (Pos 2 0) 0.5
        _far <- staticCircle w (Pos 4 0) 0.5
        qf <- defaultQueryFilter
        r <- World.castRayClosest w (Pos 0 0) (Vec2 10 0) qf
        r.hit @?= 1
        r.shapeId @?= near
        -- the near circle's surface is at x = 1.5, 15% along the ray
        approx 0.15 (r.fraction)
        miss <- World.castRayClosest w (Pos 0 0) (Vec2 (-10) 0) qf
        miss.hit @?= 0
  , testCase "body mass data matches the circle's area" $
      withWorld (Vec2 0 0) $ \w -> do
        b <- dynamicCircle w (Pos 0 0) 0.5
        md <- Body.getMassData b
        -- density 1 * pi r^2
        approx (pi * 0.25) (md.mass)
  , testCase "a local-frame ray cast hits a circle" $ do
      out <- Collision.castRayCircle (Circle vec2Zero 1) (RayCastInput (Vec2 (-3) 0) (Vec2 6 0) 1)
      out.hit @?= 1
      -- enters the unit circle at x = -1: a third of the way along (6, 0)
      approx (1 / 3) (out.fraction)
  ]

-- | 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{type_ = DynamicBody}
              sd <- defaultShapeDef
              _ <- Shape.createCircle b sd{enableCustomFiltering = 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 (Pos 2 0) 0.5
        _ <- staticCircle w (Pos 4 0) 0.5
        _ <- staticCircle w (Pos 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 (Pos 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 (Pos 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 $ \(_, Pos px _, Vec2 nx _, _) -> do
          assertBool ("hit point on a surface, x = " <> show px) (px > 1 && px < 4)
          approx (-1) nx
  , testCase "double mode keeps fractions of a metre far from the origin" $ do
      dp <- Base.isDoublePrecision
      when dp $ withWorld (Vec2 0 (-10)) $ \w -> do
        b <- dynamicCircle w (Pos 10000000.25 10) 0.5
        World.step w (1 / 60) 4
        Pos x _ <- Body.getPosition b
        x @?= 10000000.25
        WorldTransform (Pos tx _) _ <- Body.getTransform b
        tx @?= 10000000.25
  , testCase "a pre-solve manifold edit disables contacts" $
      withWorld (Vec2 0 (-10)) $ \w -> do
        gd <- defaultBodyDef
        ground <- Body.create w gd
        gsd <- defaultShapeDef
        _ <-
          Shape.createSegment
            ground
            gsd{enablePreSolveEvents = 1}
            (Segment (Vec2 (-10) 0) (Vec2 10 0))
        bd <- defaultBodyDef
        ball <- Body.create w bd{type_ = DynamicBody, position = Pos 0 2}
        sd <- defaultShapeDef
        _ <-
          Shape.createCircle
            ball
            sd{enablePreSolveEvents = 1}
            (Circle vec2Zero 0.5)
        fired <- newIORef (0 :: Int)
        let dropPoints _ _ pManifold = do
              modifyIORef' fired (+ 1)
              m <- peek pManifold
              poke pManifold (Manifold m.normal m.rollingImpulse VS.empty)
        CB.withPreSolveFcns (Just dropPoints) Nothing $ \solveFcn continuousFcn ctx -> do
          World.setPreSolveCallback w solveFcn continuousFcn ctx
          replicateM_ 240 (World.step w (1 / 60) 4)
          World.setPreSolveCallback w nullFunPtr 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 (Pos 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 (Pos 0 0) 1
        qf <- defaultQueryFilter
        planes <- newIORef []
        CB.withPlaneResultFcn
          (\sid pr -> modifyIORef' planes ((sid, pr) :) >> pure True)
          (\fcn ctx -> World.collideMover w (Pos 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) . (.hit) . snd) ps)
  , testCase "dynamic-tree query and ray-cast closures visit proxies" $
      bracket (DynamicTree.create 16) DynamicTree.destroy $ \tree -> do
        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.overlapAABB 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
                input.maxFraction @?= 1
                modifyIORef' hits (+ 1)
                pure 1
            )
            (\fcn ctx -> DynamicTree.castRay tree (RayCastInput (Vec2 (-1) 0.5) (Vec2 6 0) 1) maxBound fcn ctx)
        readIORef hits >>= (@?= 2)
  , 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)
        canOverlap <- (>= 2) <$> getNumCapabilities
        deadline <- (+ 5) <$> getMonotonicTime
        -- 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, ()))
              when canOverlap (awaitOverlap deadline maxSeen)
              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
                { gravity = Vec2 0 (-10)
                , enableSleep = 0
                , workerCount = fromIntegral ts.workerCount
                , enqueueTask = ts.enqueue
                , finishTask = ts.finish
                }
          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 = Pos (col - 8) (1.5 + row * 1.1)
            b <- Body.create w bd{type_ = DynamicBody, position = pos}
            _ <- Shape.createCircle b sd{enableCustomFiltering = 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)
        when canOverlap $
          assertBool
            ("callback was invoked concurrently, peak overlap = " <> show peak)
            (peak >= 2)
  , testCase "the debug-draw table dispatches to Haskell closures" $
      withWorld (Vec2 0 0) $ \w -> do
        _ <- dynamicCircle w (Pos 1 2) 0.5
        bd <- defaultBodyDef
        boxBody <- Body.create w bd{type_ = DynamicBody, position = Pos 5 2}
        sd <- defaultShapeDef
        boxShape <- Collision.makeBox 0.5 0.5
        _ <- Shape.createPolygon boxBody sd boxShape
        World.step w (1 / 60) 4
        circles <- newIORef []
        polys <- newIORef []
        boxes <- newIORef (0 :: Int)
        base <- defaultDebugDraw
        let draw =
              CB.noDraw
                { CB.solidCircle = Just $ \(WorldTransform p _) _ r c -> modifyIORef' circles ((p, r, c) :)
                , CB.solidPolygon = Just $ \_ vs _ c -> modifyIORef' polys ((VS.length vs, c) :)
                , CB.bounds = Just $ \_ _ -> modifyIORef' boxes (+ 1)
                }
        CB.withDraw draw base{drawBounds = 1} (CB.draw w)
        readIORef circles >>= \cs -> case cs of
          [(p, r, _)] -> do
            let Vec2 px py = toVec2 p
            r @?= 0.5
            approx 1 px
            approx 2 py
          _ -> assertFailure ("expected one circle, got " <> show (length cs))
        readIORef polys >>= \ps -> case ps of
          [(n, _)] -> n @?= 4
          _ -> assertFailure ("expected one polygon, got " <> show (length ps))
        readIORef boxes >>= \n ->
          assertBool ("shape bounds were drawn, n = " <> show n) (n >= 2)
  , testCase "an exception in a draw callback surfaces at draw, not at the callback" $
      withWorld (Vec2 0 0) $ \w -> do
        _ <- dynamicCircle w (Pos 1 2) 0.5
        World.step w (1 / 60) 4
        later <- newIORef (0 :: Int)
        -- a per-frame message, so a stale trap is not mistaken for a fresh one
        frame <- newIORef (1 :: Int)
        base <- defaultDebugDraw
        let draw =
              CB.noDraw
                { CB.solidCircle = Just $ \_ _ _ _ -> readIORef frame >>= \i -> error ("boom" <> show i)
                , -- the engine keeps walking, but every later slot is skipped
                  CB.bounds = Just $ \_ _ -> modifyIORef' later (+ 1)
                }
        CB.withDraw draw base{drawBounds = 1} $ \target -> do
          CB.draw w target `catchErrorCall` \msg -> msg @?= "boom1"
          readIORef later >>= (@?= 0)
          -- the trap is cleared, so the next frame starts clean
          writeIORef frame 2
          CB.draw w target `catchErrorCall` \msg -> msg @?= "boom2"
        World.isValid w >>= (@?= True)
  , testCase "an unset slot never enters Haskell, so its exception cannot fire" $
      withWorld (Vec2 0 0) $ \w -> do
        _ <- dynamicCircle w (Pos 1 2) 0.5
        World.step w (1 / 60) 4
        seen <- newIORef (0 :: Int)
        base <- defaultDebugDraw
        -- bounds is left unset: the trampoline sees NULL and returns
        let draw = CB.noDraw{CB.solidCircle = Just $ \_ _ _ _ -> modifyIORef' seen (+ 1)}
        CB.withDraw draw base{drawBounds = 1} (CB.draw w)
        readIORef seen >>= (@?= 1)
  , testCase "withRecorder collects a frame for rendering after draw returns" $
      withWorld (Vec2 0 0) $ \w -> do
        b <- dynamicCircle w (Pos 1 2) 0.5
        World.step w (1 / 60) 4
        base <- defaultDebugDraw
        ((), cmds) <- CB.withRecorder base{drawBounds = 1} (CB.draw w)
        let circles = [(xf, r) | CB.DrawSolidCircle xf _ r _ <- cmds]
        case circles of
          [(WorldTransform p _, r)] -> do
            r @?= 0.5
            let Vec2 px py = toVec2 p
            approx 1 px
            approx 2 py
          _ -> assertFailure ("expected one circle, got " <> show (length circles))
        assertBool "bounds were recorded too" (any isBounds cmds)
        -- the world is safe to mutate now that draw has returned
        Body.destroy b
        World.isValid w >>= (@?= True)
  , testCase "toWorld moves local geometry into the transform's frame" $ do
      let
        xf = WorldTransform (Pos 10 20) (Rot 0 1) -- a quarter turn
        Vec2 x y = toVec2 (CB.toWorld xf (Vec2 1 0))
      approx 10 x
      approx 21 y
  ]

isBounds :: CB.Cmd -> Bool
isBounds (CB.DrawBounds _ _) = True
isBounds _ = False

catchErrorCall :: IO () -> (String -> IO ()) -> IO ()
catchErrorCall act onError = do
  thrown <- try act
  case thrown of
    Left (ErrorCall msg) -> onError msg
    Right () -> assertFailure "expected an ErrorCall"

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

awaitOverlap :: Double -> IORef Int -> IO ()
awaitOverlap deadline maxSeen = do
  peak <- readIORef maxSeen
  now <- getMonotonicTime
  unless (peak >= 2 || now >= deadline) (yield >> awaitOverlap deadline maxSeen)

moverTests :: [TestTree]
moverTests =
  [ testCase "makeProxy fills a peekable ShapeProxy and withShapeProxy pokes one back" $ do
      let points = VS.fromList [Vec2 0 0, Vec2 1 0, Vec2 0 1]
      proxy <- VS.unsafeWith points $ \pts -> Collision.makeProxy pts (VS.length points) 0.25
      proxy.points @?= points
      proxy.radius @?= 0.25
      roundTrip proxy >>= (@?= proxy)
      withShapeProxy points 0.25 $ \p -> peek p >>= (@?= proxy)
  , testCase "a begun contact exposes its manifold through Contact.getData" $
      withWorld (Vec2 0 (-10)) $ \w -> do
        gd <- defaultBodyDef
        ground <- Body.create w gd
        gsd <- defaultShapeDef
        _ <- Shape.createCircle ground gsd{enableContactEvents = 1} (Circle vec2Zero 5)
        bd <- defaultBodyDef
        ball <- Body.create w bd{type_ = DynamicBody, position = Pos 0 5.6}
        sd <- defaultShapeDef
        bshape <- Shape.createCircle ball sd{enableContactEvents = 1} (Circle vec2Zero 0.5)
        let loop 0 = assertFailure "no contact begin event within 120 steps"
            loop n = do
              World.step w (1 / 60) 4
              evs <- Events.contactBeginTouchEvents w
              if VS.null evs then loop (n - 1 :: Int) else pure (VS.head evs)
        ev <- loop 120
        let cid = ev.contactId
        Contact.isValid cid >>= (@?= True)
        cd <- Contact.getData cid
        assertBool
          "the contact involves the ball shape"
          (cd.shapeIdA == bshape || cd.shapeIdB == bshape)
        let m = cd.manifold
        assertBool "the manifold has a contact point" (not (VS.null (m.points)))
        let Vec2 _ ny = m.normal
        assertBool ("the contact normal is vertical, " <> show (m.normal)) (abs ny > 0.9)
  , testCase "solvePlanes pushes a mover out and clipVector kills the inward velocity" $ do
      let plane = CollisionPlane (Plane (Vec2 0 1) 0) (1 / 0) 0 1
      (delta, planes', iters) <- Mover.solvePlanes (Vec2 0 (-1)) (VS.singleton plane)
      let Vec2 _ dy = delta
      assertBool ("the mover ends up at the plane, delta = " <> show delta) (abs dy < 0.01)
      assertBool ("the solver reports iterations, " <> show iters) (iters >= 1)
      assertBool "the plane accumulated push" ((VS.head planes').push > 0)
      clipped <- Mover.clipVector (Vec2 3 (-5)) planes'
      clipped @?= Vec2 3 0
  , testCase "chain contact and hit events toggle across all segments" $
      withWorld (Vec2 0 (-10)) $ \w -> do
        gd <- defaultBodyDef
        ground <- Body.create w gd
        c <- createOpenChain ground (VS.fromList [Vec2 (-6) 2, Vec2 (-4) 0, Vec2 4 0, Vec2 6 2])
        n <- Chain.getSegmentCount c
        segments <- allocaArray n $ \buf -> do
          got <- Chain.getSegments c buf n
          peekArray got buf
        assertBool "the chain has segments" (not (null segments))
        mapM_ (\s -> Shape.areContactEventsEnabled s >>= (@?= False)) segments
        Chain.enableContactEvents c True
        Chain.enableHitEvents c True
        mapM_ (\s -> Shape.areContactEventsEnabled s >>= (@?= True)) segments
        mapM_ (\s -> Shape.areHitEventsEnabled s >>= (@?= True)) segments
  , testCase "the default length scale is one unit per meter" $
      getLengthUnitsPerMeter >>= (@?= 1)
  , testCase "the pure vector helpers follow the engine conventions" $ do
      vec2Add (Vec2 1 2) (Vec2 3 4) @?= Vec2 4 6
      vec2MulSub (Vec2 1 1) 2 (Vec2 0 1) @?= Vec2 1 (-1)
      vec2Cross (Vec2 1 0) (Vec2 0 1) @?= 1
      vec2Normalize (Vec2 3 4) @?= Vec2 0.6 0.8
      vec2Normalize vec2Zero @?= vec2Zero
      rotateVector rotIdentity (Vec2 5 6) @?= Vec2 5 6
      invRotateVector (rotMul rotIdentity (Rot 0 1)) (rotateVector (Rot 0 1) (Vec2 5 6)) @?= Vec2 5 6
      planeSeparation (Plane (Vec2 0 1) 2) (Vec2 0 5) @?= 3
  ]