moonlight-triangulation-0.1.0.0: test/algebra/Moonlight/Triangulation/AlgebraSpec.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | The laws of finite union, stated against the typed facade a caller has.
--
-- Algebraic laws are observed through 'canonicalize'. Structural 'Eq' remains
-- the exact physical-representation observation used by round trips and caches.
module Moonlight.Triangulation.AlgebraSpec (tests) where
import Control.Monad (forM_, unless, when)
import Data.Foldable (traverse_)
import Data.IORef (modifyIORef', newIORef, readIORef)
import Data.List (sort)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Word (Word64)
import qualified Data.Vector as V
import Moonlight.Triangulation
( BuildError
, ConstraintMode (..)
, DelaunayTriangulation
, HasPosition (..)
, JoinSemilattice (..)
, Point (Point)
, Triangulation
, buildTriangulation
, delaunay
, unitElementDefaults
, vertexData
, vertexPoint
, vertices
, SiteRelation (..)
, canonicalize
, difference
, intersection
, intersectionWith
, mapVertices
, numVertices
, siteRelation
, symmetricDifference
, union
, unions
, validateTriangulation
)
import Moonlight.Triangulation.AlgebraFixtures
( Mesh
, advance
, assertMesh
, assertMeshEquivalent
, cocircularRing
, collinearSites
, dedupeAscending
, edgeKeys
, latticeSites
, meshOf
, operands
, pairs
, pointMeshOf
, pointsOf
, randomSites
, scramble
, separatedOperands
, siteList
, siteSet
, triples
)
import Support (requireRight)
tests :: IO ()
tests = do
testJoinIdentity
testJoinCommutative
testJoinAssociative
testJoinIdempotent
testJoinGeneralPathIdempotent
testJoinSiteUnion
testJoinGluesAnnotations
testJoinIsUnionRebuild
testJoinResultValid
testSkewedJoinPreservesBaseHandles
testJoinBalancedFold
testJoinPartitionTrees
testConstructionOrderIndependent
testCanonicalPublication
testSiteRelationCoherence
testMeetLaws
testEmptySetIdentitiesPreserveVerbatim
testSkewedSetOperationsRemainValid
testDifferenceLaws
testSymmetricDifferenceLaws
testLatticeLaws
testSetOperationsPublishCanonical
testAnnotationPreservation
testOldEdgeAccounting
putStrLn "algebra: ok"
-- ── laws ─────────────────────────────────────────────────────────────────────
testJoinIdentity :: IO ()
testJoinIdentity = do
values <- operands
identity <- requireRight "union identity" (unions [])
forM_ values $ \(name, mesh) -> do
left <- requireRight ("left identity at " <> name) (union identity mesh)
right <- requireRight ("right identity at " <> name) (union mesh identity)
assertMesh ("left identity at " <> name) mesh left
assertMesh ("right identity at " <> name) mesh right
idempotent <- requireRight "identity is idempotent" (union identity identity)
assertMesh "identity is idempotent" identity idempotent
testJoinCommutative :: IO ()
testJoinCommutative = do
values <- operands
forM_ (pairs values) $ \((leftName, left), (rightName, right)) -> do
leftRight <- requireRight "commutative union left/right" (union left right)
rightLeft <- requireRight "commutative union right/left" (union right left)
assertMeshEquivalent
("commutativity at " <> leftName <> " ⋄ " <> rightName)
leftRight
rightLeft
testJoinAssociative :: IO ()
testJoinAssociative = do
values <- operands
forM_ (triples values) $ \((aName, a), (bName, b), (cName, c)) -> do
leftAssociated <- requireRight "left-associated union" (union a b >>= (`union` c))
rightAssociated <- requireRight "right-associated union" (union b c >>= union a)
assertMeshEquivalent
("associativity at " <> aName <> " ⋄ " <> bName <> " ⋄ " <> cName)
leftAssociated
rightAssociated
testJoinIdempotent :: IO ()
testJoinIdempotent = do
values <- operands
forM_ values $ \(name, mesh) -> do
result <- requireRight ("idempotence at " <> name) (union mesh mesh)
assertMesh ("idempotence at " <> name) mesh result
-- | Idempotence with the structural-equality shortcut deliberately disarmed.
--
-- @a \<\> a@ is answered by a shortcut that compares the operands and returns
-- one verbatim, so on its own it says nothing about the operator underneath.
-- Three meshes standing on the same sites, built in three different orders, are
-- pairwise distinct as values — the test asserts that before relying on it —
-- so every join below takes the general path, and joining a fourth
-- representation of the same site set onto the result must still change
-- nothing.
testJoinGeneralPathIdempotent :: IO ()
testJoinGeneralPathIdempotent = do
let base = randomSites 0xA11CE 40
first <- meshOf "order-1" base
second <- meshOf "order-2" (scramble 0x1111 base)
third <- meshOf "order-3" (scramble 0x2222 base)
fourth <- meshOf "order-4" (reverse base)
unless (first /= second && second /= third && third /= fourth) $
fail "general-path idempotence: the four builds are not distinct values, so the shortcut is not disarmed"
joined <- requireRight "general-path union" (union first second)
thirdResult <- requireRight "absorbing a third representation" (union joined third)
fourthResult <- requireRight "absorbing a fourth representation" (union joined fourth)
symmetric <- requireRight "the union of two representations is symmetric" (union second first)
assertMeshEquivalent "absorbing a third representation" joined thirdResult
assertMeshEquivalent "absorbing a fourth representation" joined fourthResult
assertMeshEquivalent "the union of two representations is symmetric" joined symmetric
-- | The sites of a join are exactly the union of the operands' sites: none
-- dropped, none invented, each stored once.
testJoinSiteUnion :: IO ()
testJoinSiteUnion = do
values <- operands
forM_ (pairs values) $ \((leftName, left), (rightName, right)) -> do
let label = leftName <> " ⋄ " <> rightName
expected = Set.union (siteSet left) (siteSet right)
joined <- requireRight ("site union at " <> label) (union left right)
let actual = siteSet joined
unless (expected == actual) $
fail
( "site union at "
<> label
<> ": dropped "
<> show (Set.toList (Set.difference expected actual))
<> ", invented "
<> show (Set.toList (Set.difference actual expected))
)
unless (Set.size actual == numVertices joined) $
fail ("site union at " <> label <> ": a site is stored more than once")
-- | The reference semantics: a join /is/ a rebuild of the union when both are
-- observed canonically.
--
-- The union is rebuilt three times, in three unrelated orders, and all three
-- must canonicalize to the canonical observation of the join. Comparing
-- against a single rebuild would only say the two agree; comparing against
-- three says that what they agree on is a function of the site set and not of
-- any build schedule, which is the actual claim.
--
-- Both shortcut cases are excluded, because a shortcut returns an operand
-- verbatim and an operand need not be canonically published. The count of
-- pairs that actually reached the general path is asserted, so this cannot
-- quietly become a test of nothing.
testJoinIsUnionRebuild :: IO ()
testJoinIsUnionRebuild = do
values <- operands
exercised <- newIORef (0 :: Int)
forM_ (pairs values) $ \((leftName, left), (rightName, right)) ->
when (numVertices left > 0 && numVertices right > 0 && left /= right) $ do
let label = leftName <> " ⋄ " <> rightName
unionSites = siteList left <> siteList right
joined <- requireRight ("union of " <> label) (union left right)
canonicalJoined <- requireRight ("canonical union of " <> label) (canonicalize joined)
forM_ [("ranked", dedupeAscending (sort unionSites)), ("reversed", pointsOf (reverse unionSites)), ("scrambled", pointsOf (scramble 0x7A57E unionSites))] $
\(order, sites) -> do
rebuilt <- meshOf ("rebuild of " <> label <> " in " <> order <> " order") sites
canonical <- requireRight ("canonical rebuild of " <> label <> " in " <> order <> " order") (canonicalize rebuilt)
assertMesh
("join equals canonical rebuild at " <> label <> " (" <> order <> ")")
canonical
canonicalJoined
modifyIORef' exercised (+ 1)
count <- readIORef exercised
unless (count >= 40) $
fail ("join-equals-rebuild exercised only " <> show count <> " general-path pairs")
-- | Canonical publication in its own right, since the union laws lean on it.
--
-- Renumbering must not move geometry, must be a fixed point, must leave a
-- valid triangulation, and — the load-bearing one — must send every build
-- order of a site set to the same value. The distinctness of the inputs is
-- asserted first, so a canonicalization that did nothing at all would fail
-- here rather than pass everything.
testCanonicalPublication :: IO ()
testCanonicalPublication = do
values <- operands
forM_ values $ \(name, mesh) -> do
canonical <- requireRight ("canonicalization at " <> name) (canonicalize mesh)
unless (siteSet canonical == siteSet mesh) $
fail ("canonicalization at " <> name <> " moved the site set")
unless (edgeKeys canonical == edgeKeys mesh) $
fail ("canonicalization at " <> name <> " changed the triangulation")
case validateTriangulation canonical of
[] -> pure ()
violations -> fail ("canonicalization at " <> name <> " is invalid: " <> show violations)
fixedPoint <- requireRight ("canonicalization fixed point at " <> name) (canonicalize canonical)
assertMesh ("canonicalization at " <> name <> " is a fixed point") canonical fixedPoint
forM_ [("scattered", randomSites 0xB0A710 48), ("cocircular", cocircularRing), ("lattice", latticeSites), ("collinear", collinearSites)] $
\(name, base) -> do
built <-
traverse
(\(order, sites) -> (,) order <$> meshOf (name <> "/" <> order) sites)
[ ("input", base)
, ("ranked", dedupeAscending (sort [(x, y) | Point x y <- base]))
, ("reversed", reverse base)
, ("scrambled", scramble 0x6666 base)
]
case built of
[] -> fail "canonical publication: nothing built"
(_, reference) : rest -> do
unless (any (\(_, mesh) -> mesh /= reference) rest) $
fail ("canonical publication at " <> name <> ": every order already agreed, so this asserts nothing")
canonicalReference <- requireRight ("canonical reference at " <> name) (canonicalize reference)
forM_ rest $ \(order, mesh) -> do
canonicalMesh <- requireRight ("canonical publication at " <> name <> " from " <> order <> " order") (canonicalize mesh)
assertMesh
("canonical publication at " <> name <> " from " <> order <> " order")
canonicalReference
canonicalMesh
testJoinResultValid :: IO ()
testJoinResultValid = do
values <- operands
forM_ (pairs values) $ \((leftName, left), (rightName, right)) -> do
joined <- requireRight ("valid union at " <> leftName <> " ⋄ " <> rightName) (union left right)
case validateTriangulation joined of
[] -> pure ()
violations ->
fail ("join at " <> leftName <> " ⋄ " <> rightName <> " is invalid: " <> show violations)
testSkewedJoinPreservesBaseHandles :: IO ()
testSkewedJoinPreservesBaseHandles = do
let baseSites = randomSites 0x5A71E 256
extensionSites =
fmap
(\(Point x y) -> Point (x + 4) y)
(randomSites 0xE71E 16)
base <- meshOf "persistent base" baseSites
extension <- meshOf "persistent extension" extensionSites
joined <- requireRight "persistent skewed union" (union base extension)
let baseObservations = fmap (\vertex -> (vertex, vertexPoint base vertex)) (vertices base)
forM_ baseObservations $ \(vertex, expectedPoint) ->
unless (vertexPoint joined vertex == expectedPoint) $
fail
( "persistent skewed union moved base handle "
<> show vertex
<> " from "
<> show expectedPoint
<> " to "
<> show (vertexPoint joined vertex)
)
canonicalJoined <- requireRight "canonical persistent skewed union" (canonicalize joined)
reference <- meshOf "persistent union reference" (baseSites <> extensionSites)
canonicalReference <- requireRight "canonical persistent union reference" (canonicalize reference)
assertMesh "persistent skewed union agrees with canonical reference" canonicalReference canonicalJoined
-- | The balanced tournament agrees with every typed fold, in both directions.
testJoinBalancedFold :: IO ()
testJoinBalancedFold = do
shards <- shardMeshes 6 (randomSites 0xBA5EBA11 48)
identity <- requireRight "empty union" (unions [])
case shards of
[] -> fail "balanced fold: no shards were built"
firstShard : _ -> do
expected <- requireRight "balanced unions" (unions shards)
foldRight <- requireRight "right-folded unions" (foldr (\shard result -> result >>= union shard) (Right identity) shards)
foldLeft <- requireRight "left-folded unions" (foldl (\result shard -> result >>= (`union` shard)) (Right identity) shards)
singleton <- requireRight "singleton unions" (unions [firstShard])
repeated <- requireRight "repeated unions" (unions [firstShard, firstShard])
assertMeshEquivalent "balanced unions agree with foldr" expected foldRight
assertMeshEquivalent "balanced unions agree with foldl" expected foldLeft
assertMesh "unions of one shard is that shard" firstShard singleton
assertMesh "unions respects the idempotence shortcut" firstShard repeated
-- | The document's partition test: one site set, many shardings, many
-- bracketings, one canonical observation.
testJoinPartitionTrees :: IO ()
testJoinPartitionTrees = do
let base = randomSites 0xD15EA5E 54
whole <- meshOf "whole" base
reference <- requireRight "canonical whole partition reference" (canonicalize whole)
forM_ ([2, 3, 5, 7] :: [Int]) $ \shardCount -> do
shards <- shardMeshes shardCount base
forM_ ([0 .. 7] :: [Int]) $ \shape -> do
let scrambled = scramble (fromIntegral shape * 7919 + 13) shards
result <-
requireRight
("partition tree " <> show shardCount <> "/" <> show shape)
(bracketRandomly (fromIntegral shape * 104729 + 7) scrambled)
assertMeshEquivalent
("partition tree " <> show shardCount <> "/" <> show shape)
reference
result
-- | Delaunay uniqueness, stated as a law about this construction: the same
-- sites in any order give the same triangulation, and differ only in how it is
-- numbered.
--
-- Both halves are asserted, and the second is the one that carries weight. If
-- the numbering did /not/ differ, canonical publication would be a no-op and
-- the quotient this test names would be trivial. Because it does differ, this
-- law licenses construction in whichever order is cheapest and an explicit
-- canonical observation only where physical agreement is required.
--
-- The cocircular ring and the lattice are here because they are where it could
-- fail: an exactly flat lifted quadrilateral has two legal diagonals, and the
-- rule that picks between them is keyed on coordinates rather than on vertex
-- identifiers precisely so that this law holds.
testConstructionOrderIndependent :: IO ()
testConstructionOrderIndependent = do
forM_ [("scattered", randomSites 0x0DDBA11 60), ("cocircular", cocircularRing), ("lattice", latticeSites)] $
\(name, base) -> do
let ranked = dedupeAscending (sort [(x, y) | Point x y <- base])
meshes <-
traverse
(\(order, sites) -> (,) order <$> meshOf (name <> "/" <> order) sites)
[ ("input", base)
, ("ranked", ranked)
, ("reversed", reverse base)
, ("scrambled-a", scramble 0x3333 base)
, ("scrambled-b", scramble 0x4444 base)
]
case meshes of
[] -> fail "order independence: nothing built"
(referenceOrder, reference) : rest -> do
forM_ rest $ \(order, mesh) ->
unless (edgeKeys reference == edgeKeys mesh) $
fail
( "order independence at "
<> name
<> ": "
<> referenceOrder
<> " and "
<> order
<> " reached different triangulations"
)
unless (any (\(_, mesh) -> mesh /= reference) rest) $
fail
( "order independence at "
<> name
<> ": every build order produced the identical value, so the"
<> " numbering quotient is trivial and this law asserts nothing"
)
-- | The Guibas–Stolfi old-edge theorem, asserted as a law of the operator.
--
-- Adding sites to a Delaunay triangulation cannot create an edge between two
-- sites that were already there. So every edge of a join whose endpoints both
-- stood in one operand must already have been an edge of that operand, and any
-- other edge is bichromatic — it joins a site exclusive to the left to a site
-- exclusive to the right.
--
-- This is strictly stronger than checking that the result is a valid Delaunay
-- triangulation, and it is stronger in exactly the direction a merge schedule
-- fails in. A seam that stitches the wrong pair of hull vertices, or that
-- retracts one edge too far before it stops deleting, produces a mesh that is
-- still Delaunay for /some/ site set and still passes validation; what it does
-- not do is leave the two interiors alone. The identity names that.
--
-- It holds for every schedule, including the rebuild the operator uses today,
-- because it is a property of the Delaunay triangulation of the union and not
-- of the route taken to it. That is why it can be asserted before a second
-- schedule exists: it is the gate one would have to pass, green on the path
-- that is already trusted.
--
-- Degeneracy does not weaken it. The tie-break on an exactly cocircular
-- quadrilateral is keyed on the four coordinates alone, so the same quad
-- resolves the same way whatever else stands nearby; a cocircular diagonal can
-- therefore be lost when a site lands inside its circle, which the theorem
-- permits, but cannot be exchanged for the other diagonal, which it forbids.
testOldEdgeAccounting :: IO ()
testOldEdgeAccounting = do
overlapping <- operands
separated <- separatedOperands
census <- newIORef (0 :: Int, 0 :: Int)
forM_ ([(l, r) | l <- overlapping, r <- overlapping] <> separated) $ \((leftName, left), (rightName, right)) -> do
let label = "old-edge " <> leftName <> " / " <> rightName
joined <- requireRight label (union left right)
let leftSites = siteSet left
rightSites = siteSet right
leftEdges = edgeKeys left
rightEdges = edgeKeys right
forM_ (Set.toList (edgeKeys joined)) $ \edge -> do
let (from, to) = edge
spans sites = Set.member from sites && Set.member to sites
monochromeLeft = spans leftSites
monochromeRight = spans rightSites
when (monochromeLeft && not (Set.member edge leftEdges)) $
fail (label <> ": join created " <> show edge <> ", an edge between two sites of the left operand")
when (monochromeRight && not (Set.member edge rightEdges)) $
fail (label <> ": join created " <> show edge <> ", an edge between two sites of the right operand")
modifyIORef' census $ \(retained, cross) ->
if monochromeLeft || monochromeRight
then (retained + 1, cross)
else (retained, cross + 1)
(retained, cross) <- readIORef census
when (retained < 1000 || cross < 100) $
fail
( "old-edge accounting: the census is too thin to have asserted anything — "
<> show retained
<> " retained and "
<> show cross
<> " cross edges"
)
-- ── finite-set descent laws ─────────────────────────────────────────────────
-- | The public support relation is the exact order observation of the same
-- site sets consumed by union, meet and relative complement. Its overlap
-- witness must therefore agree with every operation's cardinality rather than
-- merely with another classification routine.
testSiteRelationCoherence :: IO ()
testSiteRelationCoherence = do
values <- operands
traverse_ (uncurry checkRelation) (pairs values)
where
checkRelation (leftName, left) (rightName, right) = do
let label = "site relation at " <> leftName <> " / " <> rightName
leftSites = siteSet left
rightSites = siteSet right
overlap = Set.size (Set.intersection leftSites rightSites)
expected = referenceSiteRelation leftSites rightSites
coldActual = siteRelation left right
unless (coldActual == expected) $
fail (label <> ": expected " <> show expected <> ", got " <> show coldActual)
let repeatedActual = siteRelation left right
unless (repeatedActual == coldActual) $
fail (label <> ": repeated observation changed the relation")
met <- requireRight (label <> " intersection") (intersection left right)
removed <- requireRight (label <> " difference") (difference left right)
joined <- requireRight (label <> " union") (union left right)
unless (numVertices met == overlap) $
fail (label <> ": intersection cardinality disagrees with overlap")
unless (numVertices removed == Set.size leftSites - overlap) $
fail (label <> ": difference cardinality disagrees with overlap")
unless (numVertices joined == Set.size leftSites + Set.size rightSites - overlap) $
fail (label <> ": union cardinality disagrees with overlap")
referenceSiteRelation
:: Set.Set (Double, Double)
-> Set.Set (Double, Double)
-> SiteRelation
referenceSiteRelation left right
| left == right = EqualSites
| left `Set.isProperSubsetOf` right = LeftProperSubset
| right `Set.isProperSubsetOf` left = RightProperSubset
| Set.null overlap = DisjointSites
| otherwise = PartialOverlap (Set.size overlap)
where
overlap = Set.intersection left right
testMeetLaws :: IO ()
testMeetLaws = do
values <- setLawOperands
traverse_
( \(name, mesh) ->
assertSetEquation
("meet idempotence at " <> name)
(intersection mesh mesh)
(canonicalize mesh)
)
values
traverse_
( \((leftName, left), (rightName, right)) ->
assertSetEquation
("meet commutativity at " <> leftName <> " / " <> rightName)
(intersection left right)
(intersection right left)
)
(pairs values)
traverse_
( \((aName, a), (bName, b), (cName, c)) ->
assertSetEquation
("meet associativity at " <> aName <> " / " <> bName <> " / " <> cName)
(intersection a b >>= (`intersection` c))
(intersection b c >>= intersection a)
)
(triples values)
testEmptySetIdentitiesPreserveVerbatim :: IO ()
testEmptySetIdentitiesPreserveVerbatim = do
let sites = scramble 0xE771D3 (randomSites 0xE771D4 48)
mesh <- meshOf "verbatim empty identity source" sites
canonical <- requireRight "canonical verbatim empty identity source" (canonicalize mesh)
unless (mesh /= canonical) $
fail "verbatim empty identities: the source was already canonical, so this asserts nothing"
empty <- requireRight "verbatim empty identity" (unions [])
differenceRightIdentity <- requireRight "verbatim difference right identity" (difference mesh empty)
differenceLeftZero <- requireRight "verbatim difference left zero" (difference empty mesh)
symmetricRightIdentity <- requireRight "verbatim symmetric difference right identity" (symmetricDifference mesh empty)
symmetricLeftIdentity <- requireRight "verbatim symmetric difference left identity" (symmetricDifference empty mesh)
assertMesh "difference by empty preserves the left representative verbatim" mesh differenceRightIdentity
assertMesh "empty difference remains the empty representative" empty differenceLeftZero
assertMesh "symmetric difference by empty preserves the left representative verbatim" mesh symmetricRightIdentity
assertMesh "empty symmetric difference preserves the right representative verbatim" mesh symmetricLeftIdentity
testSkewedSetOperationsRemainValid :: IO ()
testSkewedSetOperationsRemainValid = do
let baseSites = randomSites 0xD1FFE7 1024
removedSites = take 4 (scramble 0xD1FFE8 baseSites)
retainedSites = filter (`notElem` removedSites) baseSites
disjointIncomingSites = fmap (\(Point x y) -> Point (x + 4) y) (randomSites 0xD1FFE9 4)
nearFullIntersectionSites = retainedSites <> disjointIncomingSites
overlappingRemovedSites = take 2 removedSites
overlappingIncomingSites = overlappingRemovedSites <> take 2 disjointIncomingSites
xorDisjointSites = baseSites <> disjointIncomingSites
xorOverlappingSites = filter (`notElem` overlappingRemovedSites) baseSites <> take 2 disjointIncomingSites
base <- meshOf "skewed set-operation base" baseSites
removed <- meshOf "skewed difference subset" removedSites
disjointIncoming <- meshOf "skewed difference disjoint" disjointIncomingSites
nearFullIntersection <- meshOf "skewed geometry-only intersection" nearFullIntersectionSites
overlappingIncoming <- meshOf "skewed xor overlapping" overlappingIncomingSites
differenceSubset <- requireRight "skewed difference subset" (difference base removed)
differenceDisjoint <- requireRight "skewed difference disjoint" (difference base disjointIncoming)
intersectionNearFull <- requireRight "skewed geometry-only intersection" (intersection base nearFullIntersection)
xorDisjoint <- requireRight "skewed xor disjoint" (symmetricDifference base disjointIncoming)
xorOverlapping <- requireRight "skewed xor overlapping" (symmetricDifference base overlappingIncoming)
assertRawSetResult "skewed difference subset" retainedSites differenceSubset
assertRawSetResult "skewed difference disjoint" baseSites differenceDisjoint
assertMesh "skewed difference disjoint preserves the base verbatim" base differenceDisjoint
assertRawSetResult "skewed geometry-only intersection" retainedSites intersectionNearFull
assertRawSetResult "skewed xor disjoint" xorDisjointSites xorDisjoint
assertRawSetResult "skewed xor overlapping" xorOverlappingSites xorOverlapping
assertRawSetResult :: String -> [Point] -> Mesh -> IO ()
assertRawSetResult label expectedSites result = do
case validateTriangulation result of
[] -> pure ()
violations -> fail (label <> " raw result is invalid: " <> show violations)
reference <- meshOf (label <> " fresh rebuild") (scramble 0xD1FFEA expectedSites)
assertMeshEquivalent (label <> " agrees canonically with a fresh rebuild") reference result
testDifferenceLaws :: IO ()
testDifferenceLaws = do
values <- setLawOperands
identity <- requireRight "difference identity" (unions [])
traverse_
( \(name, mesh) -> do
assertSetEquation
("difference cancellation at " <> name)
(difference mesh mesh)
(Right identity)
assertSetEquation
("difference right identity at " <> name)
(difference mesh identity)
(canonicalize mesh)
)
values
traverse_
( \((leftName, left), (rightName, right)) -> do
let label = "difference partition at " <> leftName <> " / " <> rightName
commonAndRemainder = do
common <- intersection left right
remainder <- difference left right
union common remainder
remainderMeetRight = difference left right >>= (`intersection` right)
assertSetEquation label commonAndRemainder (canonicalize left)
assertSetEquation (label <> " disjointness") remainderMeetRight (Right identity)
)
(pairs values)
testSymmetricDifferenceLaws :: IO ()
testSymmetricDifferenceLaws = do
values <- setLawOperands
identity <- requireRight "symmetric-difference identity" (unions [])
traverse_
( \(name, mesh) -> do
assertSetEquation
("symmetric-difference cancellation at " <> name)
(symmetricDifference mesh mesh)
(Right identity)
assertSetEquation
("symmetric-difference identity at " <> name)
(symmetricDifference mesh identity)
(canonicalize mesh)
)
values
traverse_
( \((leftName, left), (rightName, right)) -> do
let label = "symmetric difference at " <> leftName <> " / " <> rightName
decomposed = do
leftOnly <- difference left right
rightOnly <- difference right left
union leftOnly rightOnly
assertSetEquation
(label <> " commutativity")
(symmetricDifference left right)
(symmetricDifference right left)
assertSetEquation
(label <> " decomposition")
(symmetricDifference left right)
decomposed
)
(pairs values)
traverse_
( \((aName, a), (bName, b), (cName, c)) ->
assertSetEquation
("symmetric-difference associativity at " <> aName <> " / " <> bName <> " / " <> cName)
(symmetricDifference a b >>= (`symmetricDifference` c))
(symmetricDifference b c >>= symmetricDifference a)
)
(triples values)
testLatticeLaws :: IO ()
testLatticeLaws = do
values <- setLawOperands
traverse_
( \((leftName, left), (rightName, right)) -> do
let label = "absorption at " <> leftName <> " / " <> rightName
assertSetEquation
(label <> " meet-over-join")
(union left right >>= intersection left)
(canonicalize left)
assertSetEquation
(label <> " join-over-meet")
(intersection left right >>= union left)
(canonicalize left)
)
(pairs values)
traverse_
( \((aName, a), (bName, b), (cName, c)) -> do
let label = "distributivity at " <> aName <> " / " <> bName <> " / " <> cName
meetOverJoin = union b c >>= intersection a
joinedMeets = do
left <- intersection a b
right <- intersection a c
union left right
joinOverMeet = intersection b c >>= union a
metJoins = do
left <- union a b
right <- union a c
intersection left right
assertSetEquation (label <> " meet-over-join") meetOverJoin joinedMeets
assertSetEquation (label <> " join-over-meet") joinOverMeet metJoins
)
(triples values)
testSetOperationsPublishCanonical :: IO ()
testSetOperationsPublishCanonical = do
values <- setLawOperands
traverse_
( \((leftName, left), (rightName, right)) -> do
let label = "canonical set publication at " <> leftName <> " / " <> rightName
case siteRelation left right of
DisjointSites -> assertCanonicalFixedPoint (label <> " intersection") (intersection left right)
PartialOverlap _ -> assertCanonicalFixedPoint (label <> " intersection") (intersection left right)
EqualSites -> pure ()
LeftProperSubset -> pure ()
RightProperSubset -> pure ()
when (numVertices left > 0 && numVertices right > 0) $ do
assertCanonicalFixedPoint (label <> " difference") (difference left right)
assertCanonicalFixedPoint (label <> " symmetric difference") (symmetricDifference left right)
)
(pairs values)
-- | Payloads descend with their coordinates. Intersection combines only the
-- common sections, difference preserves the left section, and symmetric
-- difference preserves whichever unique section survives. The independently
-- built expected meshes ensure this is not a restatement of the implementation.
testAnnotationPreservation :: IO ()
testAnnotationPreservation = do
let shared = randomSites 0xA6607A7E 12
leftOnly = randomSites 0x1EF7 8
rightOnly = randomSites 0xA1167 10
leftPoints = leftOnly <> shared
rightPoints = shared <> rightOnly
left <- pointMeshOf "annotation-left" leftPoints
rightPointsMesh <- pointMeshOf "annotation-right" rightPoints
sharedReference <- canonicalPointMesh "annotation-shared" shared
leftOnlyReference <- canonicalPointMesh "annotation-left-only" leftOnly
exclusiveReference <- canonicalPointMesh "annotation-exclusive" (leftOnly <> rightOnly)
let right = mapVertices rightAnnotation rightPointsMesh
expectedCombined = mapVertices (\point -> (point, rightAnnotation point)) sharedReference
taggedLeft = mapVertices (\point -> ExclusiveAnnotation point LeftOperand) left
taggedRight = mapVertices (\point -> ExclusiveAnnotation point RightOperand) rightPointsMesh
taggedExclusive =
mapVertices
(\point -> ExclusiveAnnotation point (if point `elem` leftOnly then LeftOperand else RightOperand))
exclusiveReference
unless (siteRelation left right == PartialOverlap (length shared)) $
fail "siteRelation changed when the vertex annotation type changed"
combined <- requireRight "annotation intersectionWith" (intersectionWith (,) left right)
restricted <- requireRight "annotation restriction" (intersectionWith const left right)
removed <- requireRight "annotation difference" (difference left right)
exclusive <- requireRight "annotation symmetric difference" (symmetricDifference taggedLeft taggedRight)
assertAnnotatedMesh "intersectionWith combines left then right" expectedCombined combined
assertAnnotatedMesh "intersectionWith const restricts the left section" sharedReference restricted
assertAnnotatedMesh "difference preserves left annotations" leftOnlyReference removed
assertAnnotatedMesh "symmetric difference preserves the annotation of each exclusive owner" taggedExclusive exclusive
data ExclusiveOperand
= LeftOperand
| RightOperand
deriving stock (Eq)
data ExclusiveAnnotation = ExclusiveAnnotation !(Point) !ExclusiveOperand
deriving stock (Eq)
rightAnnotation :: Point -> (Double, Double)
rightAnnotation (Point x y) = (x + y, x - y)
canonicalPointMesh :: String -> [Point] -> IO (DelaunayTriangulation (Point))
canonicalPointMesh label points =
pointMeshOf label points
>>= requireRight ("canonicalize " <> label) . canonicalize
assertAnnotatedMesh :: Eq mesh => String -> mesh -> mesh -> IO ()
assertAnnotatedMesh label expected actual =
unless (expected == actual) (fail (label <> ": structural values differ"))
assertSetEquation
:: String
-> Either BuildError Mesh
-> Either BuildError Mesh
-> IO ()
assertSetEquation label leftExpression rightExpression = do
left <- requireRight (label <> " left") leftExpression
right <- requireRight (label <> " right") rightExpression
leftCanonical <- requireRight (label <> " canonical left") (canonicalize left)
rightCanonical <- requireRight (label <> " canonical right") (canonicalize right)
assertMesh label leftCanonical rightCanonical
assertCanonicalFixedPoint :: String -> Either BuildError Mesh -> IO ()
assertCanonicalFixedPoint label expression = do
result <- requireRight label expression
fixedPoint <- requireRight (label <> " fixed point") (canonicalize result)
assertMesh label result fixedPoint
-- | Six representatives retain empty, degenerate, nested, partially
-- overlapping and equal-support/different-publication cases without turning
-- every ternary law into the full nine-cubed join corpus already exercised
-- above.
setLawOperands :: IO [(String, Mesh)]
setLawOperands =
filter
(\(name, _) -> name `elem` ["void", "single", "lattice-lower", "lattice-upper", "scattered", "scattered-scrambled"])
<$> operands
-- ── construction ─────────────────────────────────────────────────────────────
-- | Deal the sites round-robin into @count@ shards, so every shard spans the
-- whole extent and the joins are genuinely overlapping rather than separable.
shardMeshes :: Int -> [Point] -> IO [Mesh]
shardMeshes count sites =
traverse
(\shard -> meshOf ("shard " <> show shard) [site | (index, site) <- indexed, index `mod` count == shard])
[0 .. count - 1]
where
indexed = zip [0 :: Int ..] sites
-- | Combine by repeatedly joining a pseudo-randomly chosen adjacent pair, so
-- that successive seeds give genuinely different bracketings.
bracketRandomly :: Word64 -> [Mesh] -> Either BuildError Mesh
bracketRandomly _ [] = unions []
bracketRandomly _ [single] = Right single
bracketRandomly seed values =
let !stepped = advance seed
!cut = fromIntegral (stepped `mod` fromIntegral (length values - 1))
in joinAdjacent cut values >>= bracketRandomly stepped
-- | Replace the pair at @index@ with its join, leaving everything else alone.
joinAdjacent :: Int -> [Mesh] -> Either BuildError [Mesh]
joinAdjacent index (left : right : rest)
| index <= 0 = (: rest) <$> union left right
| otherwise = (left :) <$> joinAdjacent (index - 1) (right : rest)
joinAdjacent _ rest = Right rest
-- | A site is a coordinate carrying a tag. The join acts on tags alone: two
-- annotations only ever meet at a shared coordinate, where the positions
-- already agree, so geometry is never authored by the payload.
data Site = Site !(Point) !Int
deriving stock (Eq, Show)
instance HasPosition Site where
position (Site point _) = point
instance JoinSemilattice Site where
joinAnnotations (Site point left) (Site _ right) = Site point (max left right)
type AnnotatedMesh = Triangulation 'Unconstrained Site () () ()
annotatedMesh :: String -> [Site] -> IO AnnotatedMesh
annotatedMesh label sites =
buildTriangulation <$> requireRight label (delaunay unitElementDefaults (V.fromList sites))
-- Keyed on the coordinate plane rather than on the payload's own point,
-- because geometry is authoritative and a payload that disagreed with it must
-- not be able to hide behind itself.
tagsOf :: AnnotatedMesh -> Map.Map (Double, Double) Int
tagsOf mesh =
Map.fromList
[ ((x, y), tag)
| vertex <- vertices mesh
, let Point x y = vertexPoint mesh vertex
, let Site _ tag = vertexData mesh vertex
]
-- The whole law in one equation: the union's annotation at every site is the
-- join of whatever the operands carried there.
assertGluing :: String -> [Site] -> [Site] -> IO ()
assertGluing label leftSites rightSites = do
left <- annotatedMesh (label <> " left") leftSites
right <- annotatedMesh (label <> " right") rightSites
glued <- requireRight (label <> " union") (union left right)
assertEqualTags
(label <> ": union glues shared annotations by join")
(Map.unionWith max (tagsOf left) (tagsOf right))
(tagsOf glued)
assertEqualTags :: String -> Map.Map (Double, Double) Int -> Map.Map (Double, Double) Int -> IO ()
assertEqualTags label expected actual =
unless (expected == actual) $
fail (label <> ": expected " <> show (Map.toList expected) <> ", got " <> show (Map.toList actual))
-- The plan is chosen by size: a small addition is inserted into the larger
-- operand, and only comparably sized operands are rebuilt canonically. Both
-- paths glue, and only running both shows it.
testJoinGluesAnnotations :: IO ()
testJoinGluesAnnotations = do
assertGluing
"insertion plan"
[Site (Point 0 0) 1, Site (Point 6 0) 1, Site (Point 0 6) 1, Site (Point 2 1) 7]
[Site (Point 0 0) 5, Site (Point 6 0) 2, Site (Point 0 6) 3, Site (Point 4 3) 9]
assertGluing "rebuild plan" (grid 0 1) (grid 6 2)
where
-- Two hundred-odd sites overlapping in half, so neither operand is small
-- enough to be inserted into the other and the canonical rebuild is taken.
grid offset tag =
[ Site (Point (fromIntegral column) (fromIntegral row)) (tag * (column + row))
| column <- [offset .. offset + 11 :: Int]
, row <- [0 .. 9 :: Int]
]