Box3D-0.1.0.0: test/Spec.hs
{-# LANGUAGE PatternSynonyms #-}
module Main (main) where
import Control.Concurrent (getNumCapabilities, yield)
import Control.Exception (ErrorCall (..), evaluate, finally, throwIO, try)
import Control.Monad (forM_, replicateM_, unless, when)
import Data.IORef
import Data.Vector.Storable qualified as VS
import Foreign
import GHC.Clock (getMonotonicTime)
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.Runners (NumThreads (..))
import Box3D.Authoring qualified as Authoring
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.Compound qualified as Compound
import Box3D.Contact qualified as Contact
import Box3D.DistanceJoint qualified as DistanceJoint
import Box3D.DynamicTree qualified as DynamicTree
import Box3D.Events qualified as Events
import Box3D.Extra (withShapeProxy)
import Box3D.HeightField qualified as HeightField
import Box3D.Id
import Box3D.Joint qualified as Joint
import Box3D.MathFunctions
import Box3D.MathTypes
import Box3D.Mesh qualified as Mesh
import Box3D.Mover qualified as Mover
import Box3D.Shape qualified as Shape
import Box3D.UserData qualified as UD
import Box3D.World qualified as World
import Box3D.Body (BodyDef (..), defaultBodyDef, pattern DynamicBody, pattern StaticBody)
import Box3D.Collision (CollisionPlane (..), Manifold (..))
import Box3D.DebugDraw (DebugDraw (..), defaultDebugDraw)
import Box3D.DebugShape qualified as DebugShape
import Box3D.DistanceJoint (DistanceJointDef (..), defaultDistanceJointDef)
import Box3D.DynamicTree (dynamicTreeByteCount)
import Box3D.FilterJoint (defaultFilterJointDef)
import Box3D.Geometry (Capsule (..), MassData (..), Sphere (..))
import Box3D.Joint (JointDef (..), pattern DistanceJoint)
import Box3D.MotorJoint (defaultMotorJointDef)
import Box3D.ParallelJoint (defaultParallelJointDef)
import Box3D.PrismaticJoint (defaultPrismaticJointDef)
import Box3D.Query (CastOutput (..), QueryFilter (..), RayCastInput (..), RayResult (..), SimplexCache (..), defaultQueryFilter)
import Box3D.RevoluteJoint (defaultRevoluteJointDef)
import Box3D.Shape (ShapeDef (..), defaultFilter, defaultShapeDef, defaultSurfaceMaterial, pattern CapsuleShape, pattern CompoundShape, pattern HeightShape, pattern HullShape, pattern MeshShape, pattern SphereShape)
import Box3D.SphericalJoint (defaultSphericalJointDef)
import Box3D.WeldJoint (defaultWeldJointDef)
import Box3D.WheelJoint (defaultWheelJointDef)
import Box3D.World (BodyMoveEvent (..), ContactBeginTouchEvent (..), ContactData (..), ContactEndTouchEvent (..), ContactHitEvent (..), ExplosionDef (..), JointEvent (..), SensorBeginTouchEvent (..), SensorEndTouchEvent (..), WorldDef (..), defaultExplosionDef, defaultWorldDef)
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 "Proxies, contacts and the mover" moverTests
, testGroup "Geometry from data" geometryTests
, testGroup "Callbacks" callbackTests
, testGroup "Debug shapes" debugShapeTests
]
-- | 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.2.0" $ do
v <- Base.getVersion
v.major @?= 0
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 24 else 12
]
mathTypesTests :: [TestTree]
mathTypesTests =
[ testCase "Pos and WorldTransform round-trip through Storable" $ do
roundTrip (Pos 1.5 (-2.5) 3.5) >>= (@?= Pos 1.5 (-2.5) 3.5)
let xf = WorldTransform (Pos 3 4 5) quatIdentity
roundTrip xf >>= (@?= xf)
, testCase "world position helpers cross the Pos/Vec3 boundary" $ do
let xf = WorldTransform (Pos 10 20 30) quatIdentity
toVec3 (toPos (Vec3 1.5 2.5 3.5)) @?= Vec3 1.5 2.5 3.5
subPos (Pos 5 7 9) (Pos 2 3 4) @?= Vec3 3 4 5
offsetPos (Pos 1 2 3) (Vec3 3 4 5) @?= Pos 4 6 8
transformWorldPoint xf (Vec3 1 0 0) @?= Pos 11 20 30
invTransformWorldPoint xf (Pos 11 20 30) @?= Vec3 1 0 0
toRelativeTransform xf (Pos 9 18 27) @?= Transform (Vec3 1 2 3) quatIdentity
makeWorldTransform (Transform (Vec3 1 2 3) quatIdentity) @?= WorldTransform (Pos 1 2 3) quatIdentity
, 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
d.gravity @?= Vec3 0 (-10) 0
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 @?= quatIdentity
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 @?= 1000
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 "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" $
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"
_ -> "unknown"
name @?= ("sphere" :: String)
, testCase "a warm SimplexCache round-trips its indices" $ do
let cache = SimplexCache 0.5 (VS.fromList [1, 2, 3, 4]) (VS.fromList [5, 6, 7, 8])
roundTrip cache >>= (@?= cache)
, testCase "a SimplexCache count follows its shorter index array" $
roundTrip (SimplexCache 0.5 (VS.fromList [1, 2]) (VS.fromList [3]))
>>= (@?= SimplexCache 0.5 (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 @?= 4
VS.length cache.indexB @?= 4
, testCase "Counters reads a live world with full-length arrays" $
withWorld (Vec3 0 (-10) 0) $ \w -> do
_ <- dynamicSphere w (Pos 0 5 0) 0.5
_ <- dynamicSphere w (Pos 3 5 0) 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
VS.length counters.manifoldCounts @?= World.contactManifoldCountBuckets
, testCase "an explosion pushes a nearby body away" $
withWorld (Vec3 0 0 0) $ \w -> do
b <- dynamicSphere w (Pos 1 0 0) 0.5
ed <- defaultExplosionDef
World.explode
w
ed
{ position = Pos 0 0 0
, radius = 2
, impulsePerArea = 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{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{type_ = DynamicBody, position = position}
sd <- defaultShapeDef
_ <- Shape.createSphere b sd (Sphere vec3Zero radius)
pure b
posY :: Pos -> Float
posY p = y
where
Vec3 _ y _ = toVec3 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 (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{type_ = DynamicBody, position = Pos 0 10 0}
Body.isValid b >>= (@?= True)
Body.getType b >>= (@?= DynamicBody)
Body.getPosition b >>= (@?= Pos 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 (Pos 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)
Vec3 _ vy _ <- 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 (Pos 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{Body.position = Pos 0 10 0}
bd <- defaultBodyDef
hanging <- Body.create w bd{type_ = DynamicBody, position = Pos 0 8 0}
sd <- defaultShapeDef
_ <- Shape.createSphere hanging sd (Sphere vec3Zero 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.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 (Pos 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 (.bodyId) 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{isSensor = 1, enableSensorEvents = 1}
(Sphere vec3Zero 1)
bd <- defaultBodyDef
visitor <- Body.create w bd{type_ = DynamicBody, position = Pos 0 4 0}
sd <- defaultShapeDef
_ <-
Shape.createSphere
visitor
sd{Shape.enableSensorEvents = 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 (.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 (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{enableContactEvents = 1, enableHitEvents = 1}
(Sphere vec3Zero 5)
bd <- defaultBodyDef
ball <- Body.create w bd{type_ = DynamicBody, position = Pos 0 8 0}
sd <- defaultShapeDef
bshape <-
Shape.createSphere
ball
sd{enableContactEvents = 1, enableHitEvents = 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 (.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 (Vec3 0 (-10) 0) $ \w -> do
gd <- defaultBodyDef
anchor <- Body.create w gd{Body.position = Pos 0 10 0}
bd <- defaultBodyDef
hanging <- Body.create w bd{type_ = DynamicBody, position = Pos 0 8 0}
sd <- defaultShapeDef
_ <- Shape.createSphere hanging sd (Sphere vec3Zero 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'
-- | 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{Body.position = 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" (qf.maskBits /= 0)
, testCase "castRayClosest reports the nearest shape, and misses cleanly" $
withWorld (Vec3 0 0 0) $ \w -> do
near <- staticSphere w (Pos 2 0 0) 0.5
_far <- staticSphere w (Pos 4 0 0) 0.5
qf <- defaultQueryFilter
r <- World.castRayClosest w (Pos 0 0 0) (Vec3 10 0 0) qf
r.hit @?= 1
r.shapeId @?= near
-- the near sphere's surface is at x = 1.5, 15% along the ray
approx 0.15 (r.fraction)
miss <- World.castRayClosest w (Pos 0 0 0) (Vec3 (-10) 0 0) qf
miss.hit @?= 0
, testCase "body mass data matches the sphere's volume" $
withWorld (Vec3 0 0 0) $ \w -> do
b <- dynamicSphere w (Pos 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 = md.mass
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)
out.hit @?= 1
-- enters the unit sphere at x = -1: a third of the way along (6, 0, 0)
approx (1 / 3) (out.fraction)
]
-- | 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)
{- | 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 (Pos 2 0 0) 0.5
_ <- staticSphere w (Pos 4 0 0) 0.5
_ <- staticSphere w (Pos 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 (Pos 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 $ \(_, Pos 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{enablePreSolveEvents = 1}
(Sphere vec3Zero 5)
bd <- defaultBodyDef
ball <- Body.create w bd{type_ = DynamicBody, position = Pos 0 8 0}
sd <- defaultShapeDef
_ <-
Shape.createSphere
ball
sd{enablePreSolveEvents = 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 (Pos 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 (Pos 0 0 0) 1
qf <- defaultQueryFilter
planes <- newIORef []
CB.withPlaneResultFcn
(\sid ps -> modifyIORef' planes ((sid, ps) :) >> pure True)
(\fcn ctx -> World.collideMover w (Pos 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
input.maxFraction @?= 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)
canOverlap <- (>= 2) <$> getNumCapabilities
deadline <- (+ 5) <$> getMonotonicTime
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 = Vec3 0 (-10) 0
, enableSleep = 0
, workerCount = fromIntegral ts.workerCount
, enqueueTask = ts.enqueue
, finishTask = ts.finish
}
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 = Pos (col - 4) (1.5 + lay * 1.1) (row - 4)
b <- Body.create w bd{type_ = DynamicBody, position = pos}
_ <- Shape.createSphere b sd{enableCustomFiltering = 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)
when canOverlap $
assertBool
("callback was invoked concurrently, peak overlap = " <> show peak)
(peak >= 2)
, testCase "the debug-draw table dispatches to Haskell closures" $
withWorld (Vec3 0 (-10) 0) $ \w -> do
_ <- dynamicSphere w (Pos 1 2 3) 0.5
_ <- dynamicSphere w (Pos 5 2 3) 0.5
World.step w (1 / 60) 4
boundsSeen <- newIORef []
xforms <- newIORef (0 :: Int)
base <- defaultDebugDraw
let draw =
CB.noDraw
{ CB.bounds = Just $ \aabb c -> modifyIORef' boundsSeen ((aabb, c) :)
, CB.transform = Just $ \_ -> modifyIORef' xforms (+ 1)
}
CB.withDraw draw base{drawBounds = 1, drawMass = 1} (CB.draw w maxBound)
bs <- readIORef boundsSeen
length bs @?= 2
-- one fat AABB straddles each sphere (the engine picks the draw order)
let centreX (AABB (Vec3 lx _ _) (Vec3 hx _ _)) = (lx + hx) / 2
forM_ [1, 5] $ \x ->
assertBool
("a box is centred on x = " <> show x <> ", got " <> show (map (centreX . fst) bs))
(any ((< 0.5) . abs . subtract x . centreX . fst) bs)
readIORef xforms >>= \n ->
assertBool ("body transforms were drawn, n = " <> show n) (n == 2)
, testCase "an exception in a draw callback surfaces at draw, not at the callback" $
withWorld (Vec3 0 (-10) 0) $ \w -> do
_ <- dynamicSphere w (Pos 1 2 3) 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.bounds = Just $ \_ _ -> readIORef frame >>= \i -> error ("boom" <> show i)
, -- the engine keeps walking, but every later slot is skipped
CB.transform = Just $ \_ -> modifyIORef' later (+ 1)
}
CB.withDraw draw base{drawBounds = 1, drawMass = 1} $ \target -> do
CB.draw w maxBound target `catchErrorCall` \msg -> msg @?= "boom1"
readIORef later >>= (@?= 0)
-- the trap is cleared, so the next frame starts clean
writeIORef frame 2
CB.draw w maxBound target `catchErrorCall` \msg -> msg @?= "boom2"
World.isValid w >>= (@?= True)
, testCase "an unset slot never enters Haskell, so its exception cannot fire" $
withWorld (Vec3 0 (-10) 0) $ \w -> do
_ <- dynamicSphere w (Pos 1 2 3) 0.5
World.step w (1 / 60) 4
seen <- newIORef (0 :: Int)
base <- defaultDebugDraw
-- transform is left unset: the trampoline sees NULL and returns
let draw = CB.noDraw{CB.bounds = Just $ \_ _ -> modifyIORef' seen (+ 1)}
CB.withDraw draw base{drawBounds = 1, drawMass = 1} (CB.draw w maxBound)
readIORef seen >>= (@?= 1)
, testCase "withRecorder collects a frame for rendering after draw returns" $
withWorld (Vec3 0 (-10) 0) $ \w -> do
b <- dynamicSphere w (Pos 1 2 3) 0.5
World.step w (1 / 60) 4
base <- defaultDebugDraw
((), cmds) <- CB.withRecorder base{drawBounds = 1, drawMass = 1} (CB.draw w maxBound)
assertBool "bounds were recorded" (any isBounds cmds)
assertBool "a body transform was recorded" (any isTransform 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
-- a quarter turn about +Z sends +X to +Y
q <- computeQuatBetweenUnitVectors (Vec3 1 0 0) (Vec3 0 1 0)
let Vec3 x y z = toVec3 (CB.toWorld (WorldTransform (Pos 10 20 30) q) (Vec3 1 0 0))
approx 10 x
approx 21 y
approx 30 z
]
isBounds :: CB.Cmd -> Bool
isBounds (CB.DrawBounds _ _) = True
isBounds _ = False
debugShapeTests :: [TestTree]
debugShapeTests =
[ testCase "withDebugShapes rounds a handle through draw and shape teardown" $ do
made <- newIORef []
freed <- newIORef (0 :: Int)
drawn <- newIORef []
let
mk ds = do
radius <- case ds.geometry of
DebugShape.Sphere p -> Just <$> peek p
_ -> pure Nothing
n <- atomicModifyIORef' made (\ks -> ((ds, radius) : ks, length ks + 1))
pure (intPtrToPtr (fromIntegral n))
free_ p = modifyIORef' freed (+ 1) >> evaluate (p `seq` ())
CB.withDebugShapes mk (Just free_) $ \cbs -> do
wd <- defaultWorldDef
w <-
World.create
wd
{ gravity = Vec3 0 (-10) 0
, createDebugShape = cbs.create
, destroyDebugShape = cbs.destroy
}
s <- staticSphere w (Pos 0 0 0) 1
World.step w (1 / 60) 4
base <- defaultDebugDraw
let draw = CB.noDraw{CB.shape = Just $ \u _ _ -> modifyIORef' drawn (u :)}
CB.withDraw draw base{drawShapes = 1} (CB.draw w maxBound)
readIORef made >>= \ds -> case ds of
[(d, peeked)] -> do
d.shapeId @?= s
case peeked of
Just (Sphere _ r) -> r @?= 1
Nothing -> assertFailure ("expected a sphere arm, got " <> show d.geometry)
_ -> assertFailure ("expected one debug shape, got " <> show (length ds))
readIORef drawn >>= \us -> map ptrToIntPtr us @?= [1]
-- destroying the shape runs the destructor back through a safe call
Shape.destroy s True
readIORef freed >>= (@?= 1)
World.destroy w
, testCase "a throwing constructor costs only its own shape and surfaces on demand" $ do
calls <- newIORef (0 :: Int)
let mk _ = do
n <- atomicModifyIORef' calls (\c -> (c + 1, c))
if n == 0 then throwIO (ErrorCall "boom") else pure (intPtrToPtr (fromIntegral n))
CB.withDebugShapes mk Nothing $ \cbs -> withDebugSpheres cbs $ \w -> do
drawDebugSpheres w
readIORef calls >>= (@?= 2)
CB.rethrowDebugShapes cbs `catchErrorCall` (@?= "boom")
drawDebugSpheres w
readIORef calls >>= (@?= 3)
drawDebugSpheres w
readIORef calls >>= (@?= 3)
World.destroy w
, testCase "a throwing destructor still runs for every handle" $ do
freed <- newIORef (0 :: Int)
let free_ _ = modifyIORef' freed (+ 1) >> throwIO (ErrorCall "boom")
CB.withDebugShapes (\_ -> pure (intPtrToPtr 1)) (Just free_) $ \cbs -> withDebugSpheres cbs $ \w -> do
drawDebugSpheres w
World.destroy w
CB.rethrowDebugShapes cbs `catchErrorCall` (@?= "boom")
readIORef freed >>= (@?= 2)
, testCase "debug-shape failures nobody polled surface when the scope ends" $ do
let
failing _ = throwIO (ErrorCall "create")
destroyFailing _ = throwIO (ErrorCall "destroy")
scope mk free_ = CB.withDebugShapes mk free_ $ \cbs -> withDebugSpheres cbs $ \w -> do
drawDebugSpheres w
World.destroy w
scope failing Nothing `catchErrorCall` (@?= "create")
scope (\_ -> pure (intPtrToPtr 1)) (Just destroyFailing) `catchErrorCall` (@?= "destroy")
, testCase "a world with only a constructor survives teardown (no-op destructor)" $
CB.withDebugShapes (\_ -> pure (intPtrToPtr 1)) Nothing $ \cbs -> do
wd <- defaultWorldDef
w <-
World.create
wd
{ gravity = Vec3 0 (-10) 0
, createDebugShape = cbs.create
, destroyDebugShape = cbs.destroy
}
_ <- staticSphere w (Pos 0 0 0) 1
World.step w (1 / 60) 4
base <- defaultDebugDraw
CB.withDraw CB.noDraw{CB.shape = Just $ \_ _ _ -> pure ()} base{drawShapes = 1} (CB.draw w maxBound)
-- shape.c calls destroyDebugShape unguarded, so this is the fault case
World.destroy w
World.isValid w >>= (@?= False)
]
withDebugSpheres :: CB.DebugShapes -> (WorldId -> IO ()) -> IO ()
withDebugSpheres cbs act = do
wd <- defaultWorldDef
w <-
World.create
wd
{ gravity = Vec3 0 (-10) 0
, createDebugShape = cbs.create
, destroyDebugShape = cbs.destroy
}
_ <- staticSphere w (Pos 0 0 0) 1
_ <- staticSphere w (Pos 3 0 0) 1
World.step w (1 / 60) 4
act w `finally` (World.isValid w >>= \alive -> when alive (World.destroy w))
drawDebugSpheres :: WorldId -> IO ()
drawDebugSpheres w = do
base <- defaultDebugDraw
CB.withDraw CB.noDraw{CB.shape = Just $ \_ _ _ -> pure ()} base{drawShapes = 1} (CB.draw w maxBound)
isTransform :: CB.Cmd -> Bool
isTransform (CB.DrawTransform _) = True
isTransform _ = 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"
moverTests :: [TestTree]
moverTests =
[ testCase "testPoint reports containment against a static sphere" $
withWorld (Vec3 0 0 0) $ \w -> do
s <- staticSphere w (Pos 0 0 0) 1
Shape.testPoint s (Pos 0 0.5 0) >>= (@?= True)
Shape.testPoint s (Pos 0.9 0 0) >>= (@?= True)
Shape.testPoint s (Pos 0 3 0) >>= (@?= False)
, testCase "double mode keeps fractions of a metre far from the origin" $ do
dp <- Base.isDoublePrecision
when dp $ withWorld (Vec3 0 (-10) 0) $ \w -> do
b <- dynamicSphere w (Pos 10000000.25 10 0) 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 "double mode tests points accurately far from the origin" $ do
dp <- Base.isDoublePrecision
when dp $ withWorld (Vec3 0 0 0) $ \w -> do
s <- staticSphere w (Pos 10000000.25 0 0) 1
Shape.testPoint s (Pos 10000000.75 0 0) >>= (@?= True)
Shape.testPoint s (Pos 10000001.45 0 0) >>= (@?= False)
, testCase "withShapeProxy drives a low-level overlap test" $ do
let far = VS.fromList [Vec3 5 5 5]
hit <-
withShapeProxy (VS.singleton (Vec3 0 0.5 0)) 0.1 $
Collision.overlapSphere (Sphere vec3Zero 1) transformIdentity
hit @?= True
miss <-
withShapeProxy far 0.1 $
Collision.overlapSphere (Sphere vec3Zero 1) transformIdentity
miss @?= False
, testCase "a begun contact exposes its manifolds through Contact.getData" $
withWorld (Vec3 0 (-10) 0) $ \w -> do
gd <- defaultBodyDef
ground <- Body.create w gd
gsd <- defaultShapeDef
_ <- Shape.createSphere ground gsd{enableContactEvents = 1} (Sphere vec3Zero 5)
bd <- defaultBodyDef
ball <- Body.create w bd{type_ = DynamicBody, position = Pos 0 5.6 0}
sd <- defaultShapeDef
bshape <- Shape.createSphere ball sd{enableContactEvents = 1} (Sphere vec3Zero 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)
assertBool "the contact carries a manifold" (cd.manifoldCount >= 1)
m <- peekElemOff (cd.manifolds) 0
assertBool "the manifold has a contact point" (not (VS.null (m.points)))
let Vec3 _ 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 (Vec3 0 1 0) 0) (1 / 0) 0 1
(delta, planes', iters) <- Mover.solvePlanes (Vec3 0 (-1) 0) (VS.singleton plane)
let Vec3 _ 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 (Vec3 3 (-5) 2) planes'
clipped @?= Vec3 3 0 2
, testCase "the default length scale is one unit per meter" $
getLengthUnitsPerMeter >>= (@?= 1)
, testCase "the stall threshold round-trips" $ do
initial <- getStallThreshold
setStallThreshold 0.25
getStallThreshold >>= (@?= 0.25)
setStallThreshold initial
getStallThreshold >>= (@?= initial)
, testCase "the pure vector helpers follow the engine conventions" $ do
vec3Add (Vec3 1 2 3) (Vec3 4 5 6) @?= Vec3 5 7 9
vec3MulSub (Vec3 1 1 1) 2 (Vec3 0 1 0) @?= Vec3 1 (-1) 1
vec3Cross vec3AxisX vec3AxisY @?= vec3AxisZ
vec3Normalize (Vec3 0 3 4) @?= Vec3 0 0.6 0.8
vec3Normalize vec3Zero @?= vec3Zero
quatMul quatIdentity quatIdentity @?= quatIdentity
quatNormalize (Quat vec3Zero 2) @?= quatIdentity
rotateVector quatIdentity (Vec3 5 6 7) @?= Vec3 5 6 7
-- a quarter turn about z maps x to y (loosely: float cross products)
let
qz = quatNormalize (Quat (Vec3 0 0 (sin (pi / 4))) (cos (pi / 4)))
Vec3 rx ry rz = rotateVector qz vec3AxisX
approx 0 rx
approx 1 ry
approx 0 rz
let Vec3 ix iy iz = invRotateVector qz (rotateVector qz (Vec3 1 2 3))
approx 1 ix
approx 2 iy
approx 3 iz
planeSeparation (Plane (Vec3 0 1 0) 2) (Vec3 0 5 0) @?= 3
]
geometryTests :: [TestTree]
geometryTests =
[ testCase "createMeshFromData builds a mesh a shape can use" $
withWorld (Vec3 0 0 0) $ \w -> do
let
vertices = VS.fromList [Vec3 0 0 0, Vec3 1 0 0, Vec3 0 0 1, Vec3 1 0 1]
indices = VS.fromList [0, 1, 2, 2, 1, 3]
(mesh, degenerate) <- Authoring.createMeshFromData vertices indices Nothing Authoring.defaultMeshOptions
assertBool "mesh was created" (mesh /= nullPtr)
degenerate @?= VS.empty
bd <- defaultBodyDef
b <- Body.create w bd
sd <- defaultShapeDef
sh <- Shape.createMesh b sd mesh (Vec3 1 1 1)
Shape.isValid sh >>= (@?= True)
Body.destroy b
Mesh.destroy mesh
, testCase "degenerate triangles are reported by index" $ do
-- triangle 1 has distinct indices but collinear (zero-area) vertices;
-- repeated-index triangles are dropped without being reported
let
vertices = VS.fromList [Vec3 0 0 0, Vec3 1 0 0, Vec3 0 0 1, Vec3 0.5 0 0]
indices = VS.fromList [0, 1, 2, 0, 3, 1]
(mesh, degenerate) <- Authoring.createMeshFromData vertices indices Nothing Authoring.defaultMeshOptions
assertBool "mesh was created" (mesh /= nullPtr)
degenerate @?= VS.fromList [1]
Mesh.destroy mesh
, testCase "createHeightFieldFromData builds a height field" $ do
let heights = VS.fromList [0, 0.5, 0.25, 1]
hf <-
Authoring.createHeightFieldFromData
heights
Nothing
(Vec3 1 1 1)
2
2
Authoring.defaultHeightFieldOptions
assertBool "height field was created" (hf /= nullPtr)
fieldData <- peek hf
assertBool "byte count is positive" (fieldData.byteCount > 0)
VS.length fieldData.padding @?= 7
HeightField.destroy hf
, testCase "createCompoundFromData builds a compound from sphere and capsule children" $ do
material <- defaultSurfaceMaterial
let
spheres = VS.fromList [Authoring.CompoundSphereDef (Sphere (Vec3 0 1 0) 0.5) material]
capsules = VS.fromList [Authoring.CompoundCapsuleDef (Capsule (Vec3 0 0 0) (Vec3 0 1 0) 0.25) material]
compound <- Authoring.createCompoundFromData capsules VS.empty VS.empty spheres
assertBool "compound was created" (compound /= nullPtr)
Compound.destroy compound
]