packages feed

moonlight-triangulation (empty) → 0.1.0.0

raw patch · 124 files changed

+27923/−0 lines, 124 filesdep +asyncdep +basedep +binarybinary-added

Dependencies added: async, base, binary, bytestring, containers, deepseq, moonlight-triangulation, primitive, transformers, vector, vector-algorithms

Files

+ CHANGELOG.md view
@@ -0,0 +1,12 @@+# Changelog++`moonlight-triangulation` follows the+[Haskell Package Versioning Policy](https://pvp.haskell.org).++The serialization format carries its own version tag, independent of the package+version; any change to it is recorded here explicitly.++## 0.1.0.0++* Initial release with an honest binary64 geometry surface, dense DCEL+  projections, coverage-guided boundary targets, and PVP-bounded dependencies.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 Fable, Blue Rose++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,397 @@+# moonlight-triangulation++> Part of **Moonlight**, the sheaf-theoretic computation layer beneath+> [Melusine](https://bluerose.blue) and Pale Meridian.++`moonlight-triangulation` carries Delaunay and constrained Delaunay+triangulations as a lawful finite-set algebra under canonical observation: a+mesh represents its site set, a join returns a valid Delaunay representative,+and the result is a triangulation again — so the operations close, compose, and+fold. Operations return typed obstructions where the finite arena cannot+represent a result.++Delaunay triangulation, constrained Delaunay (CDT), the Voronoi dual,+natural-neighbour interpolation, Ruppert refinement, walk point location,+convex hull, exact Shewchuk predicates, incremental insertion and removal,+versioned binary serialization.++## Operations++| Operation | Role | What it returns |+| --- | --- | --- |+| `union` | join | A valid Delaunay representative of both site sets; overlapping annotations glue through `JoinSemilattice`. |+| `unions` | balanced fold | The same join over a list, associated for the tournament rather than the left. |+| `siteRelation` | support order | Exact equality, proper-subset, disjointness or partial-overlap classification. |+| `intersection` | geometry-only meet | The sites both meshes hold. |+| `intersectionWith` | annotated meet | Shared sites with a left-then-right annotation combiner. |+| `difference` | relative complement | The left's sites and annotations, less the right's support. |+| `symmetricDifference` | exclusive or | The sites and annotations carried by exactly one mesh. |+| `canonicalize` | physical normal form | Construction-independent dense numbering, derived explicitly when required. |+| `refine` | quality | Steiner insertion, composed *after* any of the above — never a second kind of mesh. |+| `constrainedDelaunay` | boundary | Sites plus segments, after which interiority is computable. |++### Choose the operation++| What you need | Use | Do not substitute |+| --- | --- | --- |+| Combine two unconstrained meshes | `union` | Do not concatenate vertices and rebuild manually; `union` owns overlap annotations and the measured schedule. |+| Combine many unconstrained meshes | `unions` | Do not left-fold `union`; `unions` owns balanced association. |+| Classify coordinate support without constructing a mesh | `siteRelation` | Do not compare vertex counts or resident `Eq`; neither answers support order. |+| Keep coordinates present in both geometry-only meshes | `intersection` | Use `intersectionWith` instead when annotations must survive or be recomputed. |+| Keep shared coordinates and choose their annotation | `intersectionWith combine` | For a left annotation-preserving mask, use `intersectionWith const left mask`. |+| Remove a coordinate mask from a mesh | `difference source mask` | Do not remove by stale `VertexId`; removal compacts arenas while coordinates remain stable. |+| Keep coordinates present in exactly one mesh | `symmetricDifference` | Do not spell it as two differences plus `union`; the direct operation owns the persistent toggle schedule. |+| Build the first constrained mesh | `constrainedDelaunay` | Do not build unconstrained and treat a rendered outline as topology. |+| Canonically combine arbitrary constrained meshes | `unionConstrainedWith` or geometry-only `unionConstrained` | Do not use unconstrained `union`; constrained union owns complete conflict witnesses and constraint recovery. |+| Join two strictly x-separated constrained meshes | `joinSeparatedConstrainedWith` | Use the general constrained union when separation is not proved. |+| Append one constrained section to an authoritative constrained base | `extendConstrainedWith` | Do not use symmetric constrained union when base identity and already-solved constraints must remain resident. |+| Insert one site persistently | `BulkLoad.insert` or `BulkLoad.insertAt` | Do not open a manual transaction; the singleton entry owns the dense/copy-on-write crossover. |+| Insert a vector of sites | `BulkLoad.insertMany` | Do not fold singleton insertion; one batch thaws and publishes once. |+| Compose insertions and removals | one `Session.withSession` | Do not publish every intermediate mesh. Use coordinate-keyed removal after the first compaction. |+| Refine the whole mesh | `refine` | Do not manufacture a domain witness merely to reach the local API. |+| Refine a proved face section without changing protected faces | `refineWithinDomain` | Supply its exact permitted faces and interface edges; a guessed boundary is a typed refusal, not a hint. |+| Require construction-independent numbering | `canonicalize` at the observation boundary | Do not canonicalize every intermediate value; it is intentionally global work. |++`union a a` is `a`; commutativity and associativity hold after explicit+`canonicalize`; and a join adds no sites: the result carries+`|A| + |B| − |A ∩ B|` of them. Structural `Eq` remains exact resident equality+for caches and serialization rather than secretly rebuilding the mesh.++### Persistent publication schedules++The algebraic result is independent of the execution schedule. These are the+currently measured publication choices; `canonicalize` remains the explicit+global observation when construction-independent numbering is required.++| Operation context | Publication schedule |+| --- | --- |+| `siteRelation left right` | Index the smaller support in one transient exact open-addressed section, scan the other operand, then discard the index; no support maps or published cache state. |+| `difference mesh empty`, `symmetricDifference mesh empty`, `symmetricDifference empty mesh` | Return the surviving representative verbatim. |+| `difference left right` with `size right <= (size left - size right) / 128` | Remove the right support through one local copy-on-write session; return `left` verbatim when the supports are disjoint. Larger masks rebuild. |+| Geometry-only `intersection left right` | Return an existing operand for equality or subset, return the empty mesh for disjoint supports, and locally remove the smaller complement when it is at most `overlap / 128`. Other partial overlaps rebuild. |+| `intersectionWith` | Rebuild, because the annotation combiner may rewrite every surviving payload even when topology changes locally. |+| `symmetricDifference left right` with `small <= (large - small) / 128` | Toggle the smaller operand through one local session. Comparable operands and small-output, large-input cases rebuild. |+| Comparable `symmetricDifference left right` | Partition through one transient exact index and a matched bitset, then rebuild only the exclusive output section. |+| `BulkLoad.insert` / `BulkLoad.insertAt` | Dense publication below 10,000 resident sites; copy-on-write publication at 10,000 and above. A sequence still belongs in one `Session`. |+| `extendConstrainedWith` | Copy-on-write only for a base of at least 200,000 sites, at most 128 incoming sites, exactly one incoming segment, and a pre-thaw corridor with no resident intersection. Every unmeasured or resident-corridor case stays dense. |+| `refineWithinDomain` | Dense publication. The local transaction candidate preserved semantics but did not improve wall time, so it was removed. |++On the retained one-million-site / five-thousand-site witnesses, raw+`difference` fell from 4.997 s to 0.169 s. Near-full `intersection` now takes+0.116 s from a cold persistent-index context and 0.100 s after that cache has+already been forced, down from 3.475 s before indexed descent. A+five-thousand-site `symmetricDifference` result fell from 4.022 s / 2.19 GB+allocated to 0.121 s / 244 MB. Exact `siteRelation` now takes 0.083 s cold and+0.115 s after forcing the persistent cache, down from 3.417 s before indexed+descent. Singleton insertion remains 5.326 ms from 48.037 ms. These are raw+publication measurements; paying for `canonicalize` afterward is deliberately+reported separately rather than smuggled into the local-operation claim.++```haskell+union :: JoinSemilattice annotation+      => Triangulation 'Unconstrained annotation () () ()+      -> Triangulation 'Unconstrained annotation () () ()+      -> Either BuildError (Triangulation 'Unconstrained annotation () () ())++unions :: JoinSemilattice annotation+       => [Triangulation 'Unconstrained annotation () () ()]+       -> Either BuildError (Triangulation 'Unconstrained annotation () () ())++siteRelation+      :: Triangulation leftMode leftAnnotation leftDirected leftUndirected leftFace+      -> Triangulation rightMode rightAnnotation rightDirected rightUndirected rightFace+      -> SiteRelation++intersection+      :: Triangulation 'Unconstrained () () () ()+      -> Triangulation 'Unconstrained () () () ()+      -> Either BuildError (Triangulation 'Unconstrained () () () ())++intersectionWith+      :: (leftAnnotation -> rightAnnotation -> annotation)+      -> Triangulation 'Unconstrained leftAnnotation () () ()+      -> Triangulation 'Unconstrained rightAnnotation () () ()+      -> Either BuildError (Triangulation 'Unconstrained annotation () () ())++difference+      :: Triangulation 'Unconstrained leftAnnotation () () ()+      -> Triangulation 'Unconstrained rightAnnotation () () ()+      -> Either BuildError (Triangulation 'Unconstrained leftAnnotation () () ())++symmetricDifference+      :: Triangulation 'Unconstrained annotation () () ()+      -> Triangulation 'Unconstrained annotation () () ()+      -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+```++## Constraints++* No `Semigroup`, no `Monoid`, no `<>`. A join the finite arena cannot+  represent is a `Left`; a partial class instance would lie about totality.+* `union` and `unions` glue overlapping annotations through+  `JoinSemilattice`. `intersectionWith` supplies the corresponding explicit+  overlap combiner. `difference` preserves the left annotation and+  `symmetricDifference` preserves the annotation of whichever exclusive site+  survives. Plain `intersection` remains the geometry-only specialization.+  Annotation-preserving restriction is derived rather than stored as a second+  operator: `intersectionWith const left mask`.+* `refine` composes after an operation. It is not a mode, a flag, or a second+  triangulation type.+* Mutation lives in `ST` behind `Moonlight.Triangulation.Internal.Mutable` and+  never escapes.+* `serialize` is absent from the facade by design; import+  `Moonlight.Triangulation.Serialization` to reach it.+* Coordinates are binary64 throughout the public surface. `vertexPoints` and+  `innerFaceVertexTriples` project dense vectors directly from the authoritative+  DCEL; callers do not reconstruct a sibling mesh DTO.+* One half-edge mesh underneath. `Cdt` is a mode index on it, not a second+  structure.++## Use++A triangulation is a value of its site set: construction returns `Either` with+typed obstructions, `union` returns the same typed refusal when the finite arena+cannot represent its result, and mesh quality is a+composition over the result rather than a second operation. This program+compiles against the facade alone; `fromList` is `GHC.Exts`, so nothing beyond+`base` and `moonlight-triangulation` is in scope.++```haskell+module Main where++import GHC.Exts (fromList)+import Moonlight.Triangulation++main :: IO ()+main = do+  let build :: [(Double, Double)] -> IO (DelaunayTriangulation Double ())+      build coords = case delaunay unitElementDefaults (fromList [Point x y | (x, y) <- coords]) of+        Left err -> fail (show err)+        Right result -> pure (mapVertices (const ()) (buildTriangulation result))+  a <- build [(x, y) | x <- [0 .. 9], y <- [0 .. 9]]+  b <- build [(x + 6, y) | x <- [0 .. 9], y <- [0 .. 9]]++  -- valid Delaunay representative of the union of sites+  joined <- either (fail . show) pure (union a b)++  -- meet and differences return typed obstructions, never partial results+  met <- either (fail . show) pure (intersection a b)++  -- mesh quality is a composition, not a second operation+  parameters <- either (fail . show) pure (withMinimumAngle 14 defaultRefinementParameters)+  result <- either (fail . show) pure (refine (const ()) parameters joined)+  let healed = refinedTriangulation result++  print (numVertices joined, numVertices met, numVertices healed, refinementComplete result)+```++Output: `(160,40,160,True)` — the union carries 160 sites, the meet 40, and+refinement inserts nothing because every triangle already clears the 14° bar;+`refinementComplete` states that sufficiency. Where operands leave concavities,+the same composition places Steiner sites exactly at the slivers it dissolves.++Payloads annotate geometry through `mapVertices`; the input `Point`s arrive as+their own vertex payload. The example deliberately erases them with+`mapVertices (const ())`, while annotation-preserving restriction is available+through `intersectionWith`, `difference`, and `symmetricDifference`. Constraints enter through+`constrainedDelaunay`; bulk incremental work names the machine-room module+directly (`Moonlight.Triangulation.BulkLoad` for `insertMany`,+`Moonlight.Triangulation.Session` for the owned editing transaction —+`withSession`: thaw once, insert and remove freely, publish once).++### Interior without hull-fill++A point set has no boundary, so `delaunay` necessarily meshes the convex hull:+concavities and holes are spanned by faces that belong to the hull, not to any+intended region. The region becomes real the moment its boundary is authored:+`constrainedDelaunay` takes the sites plus constraint segments as input-index+pairs, and interiority is then computable — `facesAtEvenBarrierDepth` runs a+0–1 BFS from the outer face and returns every face at even barrier depth,+which is exactly the outside (depth 0) plus anything nested behind a second+loop. The interior is the complement. `refine` consumes the same parity+through `refineExcludeOuterFaces`, so Steiner sites respect the boundary too.++```haskell+module Main where++import GHC.Exts (fromList)+import Moonlight.Triangulation++ring :: Double -> Int -> [(Double, Double)]+ring radius n =+  [ (radius * cos t, radius * sin t)+  | k <- [0 .. n - 1]+  , let t = 2 * pi * fromIntegral k / fromIntegral n+  ]++main :: IO ()+main = do+  let outer = ring 4 32+      inner = ring 2 16+      middle = ring 3 24+      pts = fromList [Point x y | (x, y) <- outer <> inner <> middle]+      loop base count = [(base + k, base + (k + 1) `mod` count) | k <- [0 .. count - 1]]+      constraints = fromList (loop 0 32 <> loop 32 16)+  annulus <- case constrainedDelaunay unitElementDefaults pts constraints of+    Left err -> fail (show err)+    Right result -> pure (buildTriangulation result)+  let outside =+        [ fromIntegral raw :: Int+        | FaceId raw <- facesAtEvenBarrierDepth annulus (isConstraintEdge annulus)+        ]+      interior =+        [ FaceId (fromIntegral k)+        | k <- [0 .. numFaces annulus - 1]+        , not (k `elem` outside)+        ]+  print (numFaces annulus, length interior)+```++Output: `(111,97)` — the annulus band is the 97 interior faces; the 14+excluded faces are the hole's hull-fill and the outer region. Rendering the+interior list draws the ring with a genuine void: no crop, no edge-length+heuristic, the engine's own verdict. `faceVertices` walks each interior face+for display, and a nested loop flips parity again, so islands inside holes+come back automatically.++### Deriving the boundary++When no boundary is known, the mesh itself carries one. Every Delaunay face+has a circumradius: faces inside a sampled region sit near the local pitch,+while faces spanning concavities and voids circumscribe them and blow up.+Keeping the faces below a threshold derived from the data — a multiple of the+median circumradius, so no authored constant — is the alpha-complex, and its+boundary falls out as the edges with exactly one kept side. Those edges are+already edges of the triangulation, so feeding them to `constrainedDelaunay`+as index pairs recovers without conflicts, and the parity machinery above+takes over from there.++```haskell+module Main where++import Data.List (sort, span)+import GHC.Exts (fromList)+import Moonlight.Triangulation++ring :: Double -> Int -> [(Double, Double)]+ring radius n =+  [ (radius * cos t, radius * sin t)+  | k <- [0 .. n - 1]+  , let t = 2 * pi * fromIntegral k / fromIntegral n+  ]++main :: IO ()+main = do+  let pts = ring 4 32 <> ring 2 16 <> ring 3 24+  mesh <- case delaunay unitElementDefaults (fromList [Point x y | (x, y) <- pts]) of+    Left err -> fail (show err)+    Right result -> pure (mapVertices (const () :: Point -> ()) (buildTriangulation result))+  let corners f =+        [(x, y) | v <- faceVertices mesh f, let Point x y = vertexPoint mesh v]+      circumradius (ax, ay) (bx, by) (cx, cy) =+        let dab = sqrt ((bx - ax) ** 2 + (by - ay) ** 2)+            dbc = sqrt ((cx - bx) ** 2 + (cy - by) ** 2)+            dca = sqrt ((ax - cx) ** 2 + (ay - cy) ** 2)+            area2 = abs ((bx - ax) * (cy - ay) - (cx - ax) * (by - ay))+        in if area2 == 0 then 1 / 0 else dab * dbc * dca / (2 * area2)+      radii =+        [ (k, circumradius p q s)+        | k <- [0 .. numFaces mesh - 1]+        , [p, q, s] <- [corners (FaceId (fromIntegral k))]+        ]+      sorted = sort (map snd radii)+      medianR = case drop (length sorted `div` 2) sorted of+        m : _ -> m+        [] -> 1+      kept = [FaceId (fromIntegral k) | (k, r) <- radii, r <= 1.35 * medianR]+      norm (p, q) = if p <= q then (p, q) else (q, p)+      edges f = case corners f of+        [p, q, s] -> [norm (p, q), norm (q, s), norm (s, p)]+        _ -> []+      runs xs = case xs of+        [] -> []+        x : rest -> let (same, more) = span (== x) rest in (x, 1 + length same) : runs more+      boundary = [e | (e, n) <- runs (sort (concatMap edges kept)), n == 1]+  print (length radii, length kept, length boundary)+```++Output: `(110,96,48)` — 110 finite faces, 96 in the alpha-complex, and the+derived boundary is exactly the 48 ring edges: both loops recovered from the+point set alone. The derived boundary walks through data sites, so it is as+jagged as the sampling; an authored boundary stays smooth at any pitch and+wins where the generator is known.++## The growing city++A triangulation is a value so that a large one can be extended without being+rebuilt or locked: a city mesh a district is added to, and then another.++`union` rebuilds last. `planPair` classifies the pair first — an empty or+repeated operand returns the other verbatim, separable operands merge along+their seam, a subset inserts into its superset, skewed sizes insert the smaller+into the larger.++```haskell+insertionIsCheaper addition base = addition <= 64 || addition <= base `quot` 8+```++A district is small against a city, so it inserts through a local copy-on-write+transaction. Publication scales with the insertion work and pages dirtied+rather than copying and renumbering the whole city.++The mesh being read is never the mesh being written. A render or pathfinding+thread queries the published value while the next is built: no lock, no+defensive copy, no interval in which the world and the mesh disagree. Mutation+offers only the choice between stalling in place and answering from a clone+that does not yet know what was built, and both are visible from the frame.++The same fact makes a failed union a `Left` over an untouched operand,+reverting an edit a selection, and a preview a second value rather than a copy.++`Moonlight.Triangulation.Parallel` reads the operation the other way: regions+triangulated apart, folded up a balanced tournament, each node's sides+concurrent.++## Representation++Structure-of-arrays over paged, copy-on-write storage. Half-edge twins are index+complements (`e xor 1`), so traversal is arithmetic rather than indirection.+Local insertion transactions copy only the pages they touch; mutation is+confined to `ST` behind `Moonlight.Triangulation.Internal.Mutable` and never+escapes.++## Predicates++`Moonlight.Triangulation.Internal.Dyadic` carries the exact layer: mantissas are+decoded and aligned to a common exponent, and determinants are evaluated over+`Integer`. The floating approximation is trusted only inside Shewchuk's error+bounds — `(3 + 16u)u` for orientation, `(10 + 96u)u` for incircle — and falls+through to the exact evaluation otherwise.++## Public sublibraries++Depend on the sublibrary you actually use, not on the facade. The footprint is+the interface: each row states what the token costs you, and a build that pulls+more than the row says is a bug in this table or in the cabal.++| Sublibrary | Surface |+| --- | --- |+| `core` | Exact-arithmetic scalars (`Scalar`, `LineSideInfo`) over paged, copy-on-write storage (`Internal.Dyadic`, `.Paged`, `.BoxedPaged`, `.PageDirectory`, `.Growable`, `.PackedIndex`, `.FaceQueue`). Depends only on `base`/`containers`/`deepseq`/`vector` — no other sublibrary. |+| `dcel` | The finite half-edge mesh and its whole read surface: `Types`, `Math`, `Interop`, `Dcel`, `Payload`, `JoinSemilattice`, `Handles` with its iterator family, `PointLocation`, `Validation`, `FloodFillIterator`, `IntersectionIterator`. Adds `primitive` and `vector-algorithms` over `core`. |+| `build` | Everything that *constructs*: `BulkLoad`, `Session`, `Removal`, typed `SetAlgebra`, `Cdt` constraint recovery, and `Refinement`. Adds no external dependency over `core` and `dcel`. |+| `parallel` | Concurrent evaluation of the pure union plan. Adds `async` at this effect boundary rather than below it. |+| `serialize` | `Serialization` — the versioned binary envelope, and the only sublibrary that costs you `binary`, `bytestring`, and `transformers`. Deliberately absent from the facade. |+| `dual` | The Voronoi dual and what reads it: `Voronoi`, `Voronoi.Handles`, `Interpolation` (natural-neighbour), `HintGenerator` (Delaunay hierarchy hints). Sits over `core`, `dcel` and `build`. |+| facade (`moonlight-triangulation`) | `Moonlight.Triangulation` alone: the equational surface, one export list stating a theory. It re-exports selected names from `core`/`dcel`/`build`/`dual` — and *not* `serialize`. A caller who wants more than the theory names the machine-room module directly. |++## Surface++* `Moonlight.Triangulation` — the apex facade.+* `.BulkLoad` — circle-sweep construction and incremental insertion.+* `.Cdt` — constraint recovery by conflict strip, with requeue on re-intersection.+* `.PointLocation`, `.HintGenerator` — walk location and Delaunay hierarchy hints.+* `.IntersectionIterator`, `.FloodFillIterator` — ordered line traversal and barrier fill.+* `.Voronoi`, `.Interpolation` — dual cells and natural-neighbour interpolation.+* `.Refinement` — Ruppert-style angle and area refinement.+* `.Validation` — structural and Delaunay-property audits.+* `.Serialization` (sublibrary `serialize`) — versioned binary envelope.
+ bench/aggregate/Main.hs view
@@ -0,0 +1,17 @@+-- | Every benchmark slice, in one process. This imports the slice modules+-- rather than restating their contents, so a benchmark added to a slice appears+-- here without anyone remembering to add it. An aggregate that duplicates its+-- slices instead of importing them drifts the moment a slice grows.+module Main (main) where++import qualified Moonlight.Triangulation.BuildBench as BuildBench+import qualified Moonlight.Triangulation.DcelBench as DcelBench+import qualified Moonlight.Triangulation.DualBench as DualBench+import qualified Moonlight.Triangulation.JoinBench as JoinBench++main :: IO ()+main = do+  BuildBench.benchmarks+  DcelBench.benchmarks+  DualBench.benchmarks+  JoinBench.benchmarks
+ bench/build/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.BuildBench as BuildBench++main :: IO ()+main = BuildBench.benchmarks
+ bench/build/Moonlight/Triangulation/BuildBench.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NumericUnderscores #-}++-- | The construction side: circle-sweep bulk load against the arrival-order+-- session kernel, persistent single insertion, constraint recovery and Ruppert+-- refinement. Each reports the library's own work counters alongside the time,+-- because the claim being measured is about work done rather than seconds.+module Moonlight.Triangulation.BuildBench (benchmarks) where++import BenchSupport (randomPoints, requireRight, timedValue)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Monad (forM_, unless)+import Data.List (sort)+import Data.Primitive.PrimArray (indexPrimArray, sizeofPrimArray)+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.BulkLoad (empty, insert)+import Moonlight.Triangulation.Cdt (constraintBatchStats, recoverConstraints)+-- The facade withholds this constructor. The benchmark indexes the builder's+-- own input mapping, so every handle it forges is one the builder issued, and+-- it owns that obligation explicitly by naming the module that grants it.+import Moonlight.Triangulation.Handles.HandleDefs (VertexId (VertexId))+import Moonlight.Triangulation.Session (insertVertex, withLocalSession, withSession)+import Moonlight.Triangulation.Types+  ( InsertionResult (insertionTriangulation)+  , refinementStats+  , statEdgeFlips+  , statLocationWalkSteps+  , statRefinementFaceChecks+  , statRefinementQueuePops+  )++benchmarks :: IO ()+benchmarks = do+  putStrLn "moonlight-triangulation native construction benchmark"+  forM_ [1_000, 10_000, 50_000] benchmarkConstruction+  forM_ [1_000, 10_000, 50_000, 100_000, 1_000_000] benchmarkSingletonInsertionCrossover+  benchmarkConstraints 8_000 800+  benchmarkRefinement 2_500++benchmarkConstruction :: Int -> IO ()+benchmarkConstruction count = do+  let points = V.fromList (randomPoints 0x9e3779b97f4a7c15 count)+  swept <- timedValue ("circle-sweep/" <> show count) $ requireRight (delaunay unitElementDefaults points)+  (_, sessioned, _) <- timedValue ("session/" <> show count) $+    requireRight+      ( withSession (empty unitElementDefaults) (V.length points) $+          V.mapM_ insertVertex points+      )+  evaluate (force (canonicalEdges (buildTriangulation swept) == canonicalEdges sessioned)) >>= \equal ->+    if equal then pure () else fail "circle-sweep and session construction disagree"++benchmarkSingletonInsertionCrossover :: Int -> IO ()+benchmarkSingletonInsertionCrossover count = do+  let points = V.fromList (randomPoints 0xd1b54a32d192ed03 count)+  built <- requireRight (delaunay unitElementDefaults points)+  let query = Point 0.000_123_456_7 (-0.000_765_432_1)+      base = buildTriangulation built+  scheduled <- timedValue ("singleton-scheduled-public-insert/" <> show count) $ requireRight (insert base query)+  (_, local, _) <- timedValue ("singleton-local-session-insert/" <> show count) $+    requireRight (withLocalSession base 1 (insertVertex query))+  let scheduledMesh = insertionTriangulation scheduled+  unless (null (validateTriangulation scheduledMesh)) $+    fail ("scheduled singleton insertion produced an invalid triangulation at " <> show count <> " sites")+  unless (null (validateTriangulation local)) $+    fail ("local singleton insertion produced an invalid triangulation at " <> show count <> " sites")+  scheduledCanonical <- requireRight (canonicalize scheduledMesh)+  localCanonical <- requireRight (canonicalize local)+  equal <- evaluate (force (scheduledCanonical == localCanonical))+  unless equal $+    fail ("scheduled and local singleton insertion disagree semantically at " <> show count <> " sites")+  putStrLn ("singleton-insertion-crossover/" <> show count <> "-semantic-witness: ok")++benchmarkConstraints :: Int -> Int -> IO ()+benchmarkConstraints pointCount constraintCount = do+  built <- requireRight (delaunay unitElementDefaults (V.fromList (randomPoints 0x94d049bb133111eb pointCount)))+  let cdt = fromDelaunay (buildTriangulation built)+      inputMapping = buildInputVertices built+      requestIndices =+        V.fromList+          ( take constraintCount+              [ (a, b)+              | index <- [0 ..]+              , let a = index `mod` pointCount+                    b = (index * 6151 + pointCount `quot` 2) `mod` pointCount+              , a /= b+              ]+          )+  pairs <-+    V.mapM+      (\(fromIndex, toIndex) ->+        let len = sizeofPrimArray inputMapping+            mFrom = if fromIndex >= 0 && fromIndex < len then Just (VertexId (indexPrimArray inputMapping fromIndex)) else Nothing+            mTo = if toIndex >= 0 && toIndex < len then Just (VertexId (indexPrimArray inputMapping toIndex)) else Nothing+        in case (mFrom, mTo) of+          (Just from, Just to) -> pure (from, to)+          _ -> fail "constraint benchmark endpoint is out of range"+      )+      requestIndices+  batch <- timedValue "cdt/recovery" (requireRight (recoverConstraints cdt pairs))+  putStrLn ("cdt/recovery-stats: " <> show (constraintBatchStats batch))++-- Ruppert refinement on a constrained square. The Steiner budget is the+-- variable of interest: both the encroachment search and the outer-region+-- classification are per-insertion costs, so their growth shows as a widening+-- gap between the two budgets rather than in either figure alone.+benchmarkRefinement :: Int -> IO ()+benchmarkRefinement steinerBudget = do+  cdtBuild <- requireRight $ constrainedDelaunay+    unitElementDefaults+    (V.fromList [Point 0 0, Point 64 0, Point 64 64, Point 0 64, Point 20 20, Point 44 44] :: V.Vector (Point))+    (V.fromList [(0, 1), (1, 2), (2, 3), (3, 0), (4, 5)])+  let cdt :: ConstrainedDelaunayTriangulation (Point)+      cdt = buildTriangulation cdtBuild+      parameters :: Int -> RefinementParameters+      parameters budget = defaultRefinementParameters+        { refineMaxAdditionalVertices = Just budget+        , refineMaxArea = Just 0.5+        , refineMaxRadiusEdgeRatio = Just 1.0+        , refineExcludeOuterFaces = True+        , refineKeepConstraintEdges = False+        }+  forM_ [steinerBudget `quot` 4, steinerBudget] $ \budget -> do+    refined <- timedValue ("refine/steiner-" <> show budget) (requireRight (refine id (parameters budget) cdt))+    let stats = refinementStats refined+    putStrLn ("refine-added/" <> show budget <> ": " <> show (refinementAddedVertices refined))+    putStrLn+      ( "refine-work/"+          <> show budget+          <> ": location-steps="+          <> show (statLocationWalkSteps stats)+          <> ", face-checks="+          <> show (statRefinementFaceChecks stats)+          <> ", queue-pops="+          <> show (statRefinementQueuePops stats)+          <> ", flips="+          <> show (statEdgeFlips stats)+      )++canonicalEdges :: Triangulation mode vertex directed undirected face -> [(Point, Point)]+canonicalEdges triangulation =+  sort+    [ ordered (vertexPoint triangulation (origin triangulation edge)) (vertexPoint triangulation (destination triangulation edge))+    | undirected <- undirectedEdges triangulation+    , let edge = normalizedDirected undirected+    ]+ where+  ordered :: Ord value => value -> value -> (value, value)+  ordered left right = if left <= right then (left, right) else (right, left)
+ bench/dcel/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.DcelBench as DcelBench++main :: IO ()+main = DcelBench.benchmarks
+ bench/dcel/Moonlight/Triangulation/DcelBench.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NumericUnderscores #-}++-- | Read-side traversal over a finished mesh: ordered line intersection and the+-- circle shape query. Construction here is fixture cost, not the subject.+module Moonlight.Triangulation.DcelBench (benchmarks) where++import BenchSupport (randomPoints, requireRight, timedValue)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.FloodFillIterator (edgesInCircle)+import Moonlight.Triangulation.IntersectionIterator (lineIntersections)++benchmarks :: IO ()+benchmarks = benchmarkQueries 20_000 10_000++benchmarkQueries :: Int -> Int -> IO ()+benchmarkQueries pointCount queryCount = do+  built <- requireRight (delaunay unitElementDefaults (V.fromList (randomPoints 0xbf58476d1ce4e5b9 pointCount)))+  circleEdges <- requireRight (edgesInCircle (buildTriangulation built) (Point 0 0) 0.25)+  queries <-+    requireRight+      (traverse mkQueryPoint (V.fromList (take (2 * queryCount) (randomPoints 0x632be59bd9b4e019 (2 * queryCount)))))+  let triangulation = buildTriangulation built+      total = V.ifoldl' (lineCount triangulation queries queryCount) 0 (V.take queryCount queries)+      shapeTotal = length circleEdges+  _ <- timedValue "line-and-shape-queries" (evaluate (force (total, shapeTotal)))+  pure ()+ where+  lineCount+    :: DelaunayTriangulation (Point)+    -> V.Vector (QueryPoint)+    -> Int+    -> Int+    -> Int+    -> QueryPoint+    -> Int+  lineCount triangulation queries stride !accumulator index from =+    accumulator + length (lineIntersections triangulation from (queries V.! (index + stride)))
+ bench/dual/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.DualBench as DualBench++main :: IO ()+main = DualBench.benchmarks
+ bench/dual/Moonlight/Triangulation/DualBench.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NumericUnderscores #-}++-- | The dual side: Delaunay-hierarchy hints against an unhinted walk, and+-- natural-neighbour interpolation over a reused workspace. Both report+-- allocation, because the claim in each case is about work avoided rather than+-- time taken.+module Moonlight.Triangulation.DualBench (benchmarks) where++import BenchSupport (randomPoints, requireRight, timedValue)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Monad.ST (stToIO)+import qualified Data.Vector as V+import GHC.Exts (RealWorld)+import GHC.Stats (RTSStats (allocated_bytes), getRTSStats, getRTSStatsEnabled)+import Moonlight.Triangulation+import Moonlight.Triangulation.HintGenerator+  ( HierarchyHint+  , buildHierarchyHint+  , defaultHierarchyBranchFactor+  , hierarchyHint+  , hierarchyLevelCount+  , hierarchyVertexCount+  )+import Moonlight.Triangulation.Interpolation+  ( NaturalNeighborWorkspace+  , interpolateNaturalNeighbor+  , newNaturalNeighborWorkspace+  , workspaceBytes+  )+import System.Mem (performGC)++benchmarks :: IO ()+benchmarks = do+  benchmarkHierarchy 20_000 5_000+  benchmarkSibson 10_000 5_000++benchmarkHierarchy :: Int -> Int -> IO ()+benchmarkHierarchy pointCount queryCount = do+  built <- requireRight (delaunay unitElementDefaults (V.fromList (randomPoints 0x123456789abcdef pointCount)))+  queries <-+    requireRight+      (traverse mkQueryPoint (V.fromList (take queryCount (randomPoints 0x3141592653589793 queryCount))))+  let triangulation = buildTriangulation built+  hierarchy <- requireRight (buildHierarchyHint defaultHierarchyBranchFactor triangulation)+  (_, baselineSteps) <- timedValue "nearest/no-hierarchy" (evaluate (force (walkTotal triangulation Nothing queries)))+  (_, hierarchySteps) <- timedValue "nearest/delaunay-hierarchy" (evaluate (force (walkHierarchyTotal triangulation hierarchy queries)))+  putStrLn ("hierarchy-levels: " <> show (hierarchyLevelCount hierarchy))+  putStrLn ("hierarchy-vertices: " <> show (hierarchyVertexCount hierarchy))+  putStrLn ("nearest-walk-steps/no-hierarchy: " <> show baselineSteps)+  putStrLn ("nearest-walk-steps/hierarchy: " <> show hierarchySteps)+ where+  walkTotal+    :: DelaunayTriangulation (Point)+    -> Maybe VertexId+    -> V.Vector (QueryPoint)+    -> (Int, Int)+  walkTotal triangulation hint queries = V.foldl' step (0 :: Int, 0 :: Int) queries+   where+    step (!count, !steps) query =+      case nearestNeighbor triangulation hint query of+        Nothing -> (count, steps)+        Just (_, stats) -> (count + 1, steps + nearestWalkSteps stats)++  walkHierarchyTotal+    :: DelaunayTriangulation (Point)+    -> HierarchyHint+    -> V.Vector (QueryPoint)+    -> (Int, Int)+  walkHierarchyTotal triangulation hierarchy queries = V.foldl' step (0 :: Int, 0 :: Int) queries+   where+    step (!count, !steps) query =+      let hint = case hierarchyHint hierarchy query of+            Just (VertexHint vertex) -> Just vertex+            _ -> Nothing+       in case nearestNeighbor triangulation hint query of+            Nothing -> (count, steps)+            Just (_, stats) -> (count + 1, steps + nearestWalkSteps stats)++benchmarkSibson :: Int -> Int -> IO ()+benchmarkSibson pointCount queryCount = do+  built <- requireRight (delaunay unitElementDefaults (V.fromList (randomPoints 0x8cb92baa3f3d8dd7 pointCount)))+  queries <-+    requireRight+      (traverse mkQueryPoint (V.fromList (take queryCount (randomPoints 0xdb4f0b9175ae2165 queryCount))))+  let triangulation = buildTriangulation built+      height vertex =+        let Point x y = vertexPoint triangulation vertex+         in x * x + 0.5 * y+  workspace <- stToIO (newNaturalNeighborWorkspace triangulation)+  putStrLn ("sibson-workspace-bytes: " <> show (workspaceBytes workspace))+  statsEnabled <- getRTSStatsEnabled+  if statsEnabled then performGC else pure ()+  before <- if statsEnabled then Just <$> getRTSStats else pure Nothing+  _ <- timedValue "sibson/reused-workspace" (queryLoop workspace height queries)+  after <- if statsEnabled then Just <$> getRTSStats else pure Nothing+  case (before, after) of+    (Just left, Just right) -> do+      let allocated = allocated_bytes right - allocated_bytes left+          perQuery = fromIntegral allocated / fromIntegral queryCount :: Double+      putStrLn ("sibson-allocated-bytes-total: " <> show allocated)+      putStrLn ("sibson-allocated-bytes/query: " <> show perQuery)+    _ -> putStrLn "sibson allocation counters unavailable; run with +RTS -T"+ where+  queryLoop+    :: NaturalNeighborWorkspace RealWorld 'Unconstrained (Point) () () ()+    -> (VertexId -> Double)+    -> V.Vector (QueryPoint)+    -> IO Double+  queryLoop workspace height queries = go 0 0+   where+    !count = V.length queries+    go !index !total+      | index >= count = evaluate total+      | otherwise = do+          (value, _) <- stToIO (interpolateNaturalNeighbor height workspace Nothing (queries V.! index))+          go (index + 1) (total + maybe 0 id value)
+ bench/join/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.JoinBench as JoinBench++main :: IO ()+main = JoinBench.benchmarks
+ bench/join/Moonlight/Triangulation/JoinBench.hs view
@@ -0,0 +1,438 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NumericUnderscores #-}++-- | What the join costs, and against what.+--+-- These lanes compare the public union schedules with rebuild, local insertion,+-- and explicit canonical observation. Schedule claims live or die by these+-- measurements rather than by asymptotic theatre.+module Moonlight.Triangulation.JoinBench+  ( benchmarks+  , publicationBenchmarks+  ) where++import BenchSupport (randomPoints, requireRight, timedValue)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Monad (foldM, unless)+import Data.List (sort, sortBy)+import Data.Ord (comparing)+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.BulkLoad (insertMany)+import Moonlight.Triangulation.Internal.PointIndex (lookupPointIndex)+import Moonlight.Triangulation.Internal.Representation+  ( Triangulation (triPointIndex, triPointX, triPointY)+  )+import System.Mem (performGC)++type Mesh = DelaunayTriangulation ()+type SiteMesh = DelaunayTriangulation (Point)++benchmarks :: IO ()+benchmarks = do+  benchmarkBalanced 20_000+  benchmarkSeparated 20_000+  benchmarkSkew 20_000 200+  benchmarkOverlap 20_000+  benchmarkTournament 20_000 16+  benchmarkSpatialTournament 20_000 16+  benchmarkTournamentScaling 20_000+  benchmarkCanonicalize 20_000+  benchmarkSetAlgebra 20_000++publicationBenchmarks :: IO ()+publicationBenchmarks = do+  benchmarkIndexedSupportContexts 1_000_000 5_000+  benchmarkPersistentSetOperations 1_000_000 5_000+  benchmarkPersistentPublication 5_000_000 5_000++benchmarkIndexedSupportContexts :: Int -> Int -> IO ()+benchmarkIndexedSupportContexts baseCount deltaCount = do+  let baseSites = randomPoints 0xcbbb9d5dc1059ed8 baseCount+      retainedSites = drop deltaCount baseSites+  benchmarkColdRelationWarmIntersection baseSites retainedSites+  performGC+  benchmarkColdIntersectionWarmRelation baseSites retainedSites+  performGC++benchmarkColdRelationWarmIntersection :: [Point] -> [Point] -> IO ()+benchmarkColdRelationWarmIntersection baseSites retainedSites = do+  base <- geometryMesh baseSites+  retained <- geometryMesh retainedSites+  _ <- evaluate (force (base, retained))+  relation <- timedValue "set-relation-near-full-cold-index" (evaluate (force (siteRelation base retained)))+  unless (relation == RightProperSubset) $+    fail "cold indexed relation misclassified the retained operand"+  forceExactPointIndex base baseSites+  benchmarkIndexedIntersection "set-intersection-near-full-warm-index" base retained++benchmarkColdIntersectionWarmRelation :: [Point] -> [Point] -> IO ()+benchmarkColdIntersectionWarmRelation baseSites retainedSites = do+  base <- geometryMesh baseSites+  retained <- geometryMesh retainedSites+  _ <- evaluate (force (base, retained))+  benchmarkIndexedIntersection "set-intersection-near-full-cold-index" base retained+  forceExactPointIndex base baseSites+  relation <- timedValue "set-relation-near-full-warm-index" (evaluate (force (siteRelation base retained)))+  unless (relation == RightProperSubset) $+    fail "warm indexed relation misclassified the retained operand"++benchmarkIndexedIntersection :: String -> Mesh -> Mesh -> IO ()+benchmarkIndexedIntersection label base retained = do+  result <- benchmarkValidatedSetOperation label (intersection base retained)+  observedCanonical <- evaluate . force =<< requireRight (canonicalize result)+  expectedCanonical <- evaluate . force =<< requireRight (canonicalize retained)+  unless (observedCanonical == expectedCanonical) $+    fail (label <> " disagreed with the retained operand")++forceExactPointIndex :: Mesh -> [Point] -> IO ()+forceExactPointIndex triangulation points =+  case points of+    [] -> fail "cannot warm a point index without a witness"+    witness : _ ->+      case+          lookupPointIndex+            (triPointX triangulation)+            (triPointY triangulation)+            (triPointIndex triangulation)+            witness+        of+          Nothing -> fail "point-index warmup missed its exact witness"+          Just vertex -> () <$ evaluate (force vertex)++-- | Two halves of one point set, joined.+--+-- The balanced pair rebuilds from its combined site set. The input-order and+-- ranked lanes distinguish ordinary construction from construction whose+-- vertex numbering is already canonical.+benchmarkBalanced :: Int -> IO ()+benchmarkBalanced total = do+  let sites = randomPoints 0x9e3779b97f4a7c15 total+      (left, right) = splitAt (total `div` 2) sites+  leftMesh <- geometryMesh left+  rightMesh <- geometryMesh right+  _ <- evaluate (force (leftMesh, rightMesh))+  _ <- timedValue "join-balanced" (evaluate . force =<< requireRight (union leftMesh rightMesh))+  _ <- timedValue "join-balanced-rebuild-input-order" (evaluate . force =<< geometryMesh sites)+  _ <- timedValue "join-balanced-rebuild-ranked-order" (evaluate . force =<< geometryMesh (canonical sites))+  pure ()++-- | Two operands whose sites are separated by a vertical line.+--+-- This is the stratum a seam merge is defined on, and the number here is the+-- one it has to beat: the reference schedule does not know the operands are+-- separated and rebuilds the union regardless. A linear-time merge wins+-- asymptotically over an @O(n log n)@ rebuild; whether it wins at the sizes+-- anything actually merges at is this measurement and not an argument.+--+-- Three gap widths, because the seam's work is the cross-edge chain and the+-- deletions it drives, and how far the two clouds stand apart decides how much+-- of each interior the chain disturbs. A distant pair is the easy case — the+-- chain is short and nothing inside either operand dies. An abutting pair is+-- the hard one.+benchmarkSeparated :: Int -> IO ()+benchmarkSeparated total = do+  let half = total `div` 2+      sites = randomPoints 0xd1b54a32d192ed03 half+      extent = 2 * maximum [abs x | Point x _ <- sites]+  leftMesh <- geometryMesh sites+  _ <- evaluate (force leftMesh)+  mapM_+    ( \(name, gap) -> do+        let shifted = [Point (x + gap * extent) y | Point x y <- sites]+        rightMesh <- geometryMesh shifted+        _ <- evaluate (force rightMesh)+        _ <- timedValue ("join-separated-" <> name) (evaluate . force =<< requireRight (union leftMesh rightMesh))+        pure ()+    )+    [("distant" :: String, 8), ("near", 2), ("abutting", 1.02)]++-- | A large mesh joined with a small one. Rebuilding costs the whole union;+-- inserting the small operand's sites into the large mesh costs only the+-- insertions. This is the ratio that says whether a skewed lane is worth+-- having, and it needs no new algorithm — 'insertMany' is already the+-- one-transaction batch path.+--+-- Both lanes carry the same vertex payload so the comparison is of the+-- schedules and not of the stores.+benchmarkSkew :: Int -> Int -> IO ()+benchmarkSkew large small = do+  let bulk = randomPoints 0xbf58476d1ce4e5b9 large+      addition = randomPoints 0x94d049bb133111eb small+  bulkMesh <- siteMesh bulk+  _ <- evaluate (force bulkMesh)+  _ <-+    timedValue+      "join-skew-rebuild"+      (evaluate . force =<< siteMesh (canonical (bulk <> addition)))+  _ <-+    timedValue+      "join-skew-insert-many"+      ( evaluate . force . buildTriangulation+          =<< requireRight (insertMany bulkMesh (V.fromList addition))+      )+  pure ()++benchmarkPersistentPublication :: Int -> Int -> IO ()+benchmarkPersistentPublication baseCount extensionCount = do+  let baseSites = randomPoints 0x6a09e667f3bcc909 baseCount+      extensionSites =+        fmap+          (\(Point x y) -> Point (1.2 + 0.1 * x) y)+          (randomPoints 0xbb67ae8584caa73b extensionCount)+  base <- geometryMesh baseSites+  extension <- geometryMesh extensionSites+  _ <- evaluate (force (base, extension))+  putStrLn ("publication-base-sites: " <> show (numVertices base))+  putStrLn ("publication-base-faces: " <> show (numFaces base))+  putStrLn ("publication-extension-sites: " <> show (numVertices extension))+  putStrLn ("publication-extension-faces: " <> show (numFaces extension))+  joined <-+    timedValue+      "publication-skew-union"+      (evaluate . force =<< requireRight (union base extension))+  case validateTriangulation joined of+    [] -> pure ()+    violations -> fail ("publication-skew-union invalid: " <> show violations)+  canonicalResult <-+    timedValue+      "publication-explicit-canonicalize"+      (evaluate . force =<< requireRight (canonicalize joined))+  unless (numVertices canonicalResult == numVertices joined) $+    fail "publication canonicalization changed the site count"+  putStrLn ("publication-result-sites: " <> show (numVertices joined))+  putStrLn ("publication-result-faces: " <> show (numFaces joined))++benchmarkPersistentSetOperations :: Int -> Int -> IO ()+benchmarkPersistentSetOperations baseCount deltaCount = do+  let baseSites = randomPoints 0xcbbb9d5dc1059ed8 baseCount+      removedSites = take deltaCount baseSites+      retainedSites = drop deltaCount baseSites+      extensionSites =+        fmap+          (\(Point x y) -> Point (1.2 + 0.1 * x) y)+          (randomPoints 0x629a292a367cd507 deltaCount)+  base <- geometryMesh baseSites+  removed <- geometryMesh removedSites+  retained <- geometryMesh retainedSites+  extension <- geometryMesh extensionSites+  empty <- requireRight (unions [])+  _ <- evaluate (force (base, removed, retained, extension, empty))+  putStrLn ("set-publication-base-sites: " <> show (numVertices base))+  putStrLn ("set-publication-delta-sites: " <> show (numVertices removed))+  _ <- benchmarkValidatedSetOperation "set-publication-difference-right-empty" (difference base empty)+  _ <- benchmarkValidatedSetOperation "set-publication-symmetric-difference-left-empty" (symmetricDifference empty base)+  _ <- benchmarkValidatedSetOperation "set-publication-symmetric-difference-right-empty" (symmetricDifference base empty)+  benchmarkPublishedSetOperation+    "set-publication-difference-skew"+    (difference base removed)+    (pure retained)+  benchmarkPublishedSetOperation+    "set-publication-intersection-skew"+    (intersection base retained)+    (pure retained)+  benchmarkPublishedSetOperation+    "set-publication-symmetric-difference-disjoint-skew"+    (symmetricDifference base extension)+    (geometryMesh (baseSites <> extensionSites))+  benchmarkPublishedSetOperation+    "set-publication-symmetric-difference-small-output"+    (symmetricDifference base retained)+    (pure removed)++benchmarkPublishedSetOperation :: String -> Either BuildError Mesh -> IO Mesh -> IO ()+benchmarkPublishedSetOperation label operation expectedWitness = do+  result <- benchmarkValidatedSetOperation label operation+  observedCanonical <-+    timedValue+      (label <> "-explicit-canonicalize")+      (evaluate . force =<< requireRight (canonicalize result))+  expected <- expectedWitness+  expectedCanonical <- evaluate . force =<< requireRight (canonicalize expected)+  unless (observedCanonical == expectedCanonical) $+    fail (label <> " disagreed with the independently rebuilt witness")++benchmarkValidatedSetOperation :: String -> Either BuildError Mesh -> IO Mesh+benchmarkValidatedSetOperation label operation = do+  result <- timedValue label (evaluate . force =<< requireRight operation)+  case validateTriangulation result of+    [] -> pure ()+    violations -> fail (label <> " invalid: " <> show violations)+  pure result++-- | The same operand sizes at three overlap fractions. A join is sized by the+-- union, so wholly overlapping operands must cost what one of them costs.+benchmarkOverlap :: Int -> IO ()+benchmarkOverlap total = do+  let sites = randomPoints 0x2545f4914f6cdd1d total+      half = total `div` 2+  disjointLeft <- geometryMesh (take half sites)+  disjointRight <- geometryMesh (drop half sites)+  halfLeft <- geometryMesh (take half sites)+  halfRight <- geometryMesh (drop (half `div` 2) (take (half + half `div` 2) sites))+  sameLeft <- geometryMesh (take half sites)+  sameRight <- geometryMesh (reverse (take half sites))+  _ <- evaluate (force (disjointLeft, disjointRight, halfLeft, halfRight, sameLeft, sameRight))+  _ <- timedValue "join-overlap-000" (evaluate . force =<< requireRight (union disjointLeft disjointRight))+  _ <- timedValue "join-overlap-050" (evaluate . force =<< requireRight (union halfLeft halfRight))+  _ <- timedValue "join-overlap-100" (evaluate . force =<< requireRight (union sameLeft sameRight))+  pure ()++-- | 'unions' is a balanced tournament and not a fold, which is a cost claim+-- and therefore has to be measured rather than asserted. A fold republishes an+-- accumulator that grows by one shard per step.+--+-- This lane once reported the fold as the faster of the two, which was true and+-- was not a fact about the schedules: @joinBalanced@ carried no specialization,+-- so every join inside the tournament ran through a dictionary while+-- the left-associated schedule at a known element type ran specialized. The tournament was+-- paying twice for arithmetic, and that swamped the asymptotic gap it was+-- supposed to be demonstrating.+--+-- The shards are dealt round-robin, so every one of them spans the whole extent+-- and no join in the tournament is separable. That is deliberate: it is the+-- adversarial sharding, and it measures the operator with no structure to+-- exploit. 'benchmarkSpatialTournament' is the same tournament over the+-- sharding a caller who wanted it to be fast would actually choose.+benchmarkTournament :: Int -> Int -> IO ()+benchmarkTournament total shardCount = do+  let sites = randomPoints 0x14057b7ef767814f total+      indexed = zip [0 :: Int ..] sites+  shards <-+    traverse+      (\shard -> geometryMesh [site | (index, site) <- indexed, index `mod` shardCount == shard])+      [0 .. shardCount - 1]+  _ <- evaluate (force shards)+  _ <- timedValue "join-tournament" (evaluate . force =<< requireRight (unions shards))+  _ <- timedValue "join-left-fold" (evaluate . force =<< requireRight (unionsLeftAssociated shards))+  pure ()++-- | Where the tournament's advantage over the fold actually appears.+--+-- A fold republishes an accumulator that grows by one shard per step, so it+-- rebuilds @Θ(nk)@ sites over @k@ shards where halving rebuilds @Θ(n log k)@.+-- That is a statement about @k@, and at the sixteen shards the lane above uses+-- the predicted factor is barely two — small enough to be swamped by the+-- per-join costs both schedules pay fifteen times each. This sweep is here+-- because a cost claim that only holds asymptotically has to say at what size+-- it starts holding, and the answer has to be measured rather than asserted.+benchmarkTournamentScaling :: Int -> IO ()+benchmarkTournamentScaling total =+  mapM_+    ( \shardCount -> do+        let sites = randomPoints 0x9e3779b97f4a7c15 total+            indexed = zip [0 :: Int ..] sites+        shards <-+          traverse+            (\shard -> geometryMesh [site | (index, site) <- indexed, index `mod` shardCount == shard])+            [0 .. shardCount - 1]+        _ <- evaluate (force shards)+        _ <- timedValue ("join-shards-" <> show shardCount <> "-tournament") (evaluate . force =<< requireRight (unions shards))+        _ <- timedValue ("join-shards-" <> show shardCount <> "-fold") (evaluate . force =<< requireRight (unionsLeftAssociated shards))+        pure ()+    )+    [4 :: Int, 16, 64]+++-- | The same tournament over shards cut by abscissa rather than dealt.+--+-- This is the workload a seam schedule exists for, and the only one where it+-- can pay off more than once. Shards cut into contiguous x-ranges are pairwise+-- separated; so is every intermediate result, because the union of two adjacent+-- ranges is a range. Every one of the fifteen joins in the tournament is+-- therefore separable — the tournament /is/ the divide-and-conquer recursion,+-- entered from the leaves.+--+-- Against the reference schedule this must cost about what the dealt+-- tournament costs, since a rebuild cannot tell the two shardings apart. That+-- agreement is the baseline; the gap that opens between these two lanes is the+-- whole return on a merge kernel.+benchmarkSpatialTournament :: Int -> Int -> IO ()+benchmarkSpatialTournament total shardCount = do+  let sites = randomPoints 0x3c6ef372fe94f82a total+      ordered = sortBy (comparing (\(Point x _) -> x)) sites+      width = (total + shardCount - 1) `div` shardCount+  shards <-+    traverse+      (\shard -> geometryMesh (take width (drop (shard * width) ordered)))+      [0 .. shardCount - 1]+  _ <- evaluate (force shards)+  _ <- timedValue "join-spatial-tournament" (evaluate . force =<< requireRight (unions shards))+  pure ()++-- | The renumbering pass on its own, against the construction it follows.+benchmarkCanonicalize :: Int -> IO ()+benchmarkCanonicalize total = do+  let sites = randomPoints 0x27d4eb2f165667c5 total+  mesh <- geometryMesh sites+  _ <- evaluate (force mesh)+  _ <- timedValue "canonicalize-alone" (evaluate (force (canonicalize mesh)))+  pure ()++-- | The shared canonical rebuild boundary under half overlap, on both its+-- geometry-only specializations and its annotation-preserving surface. Setup+-- and source publication are forced before every clock; the measurements are+-- therefore the exact site classification, rebuild, canonical publication and+-- payload transport the public operations own.+benchmarkSetAlgebra :: Int -> IO ()+benchmarkSetAlgebra total = do+  let common = total `quot` 2+      sites = randomPoints 0x6A09E667F3BCC909 (total + common)+      leftPoints = take total sites+      rightPoints = drop common sites+  leftGeometry <- geometryMesh leftPoints+  rightGeometry <- geometryMesh rightPoints+  emptyGeometry <- requireRight (unions [])+  _ <- evaluate (force (leftGeometry, rightGeometry, emptyGeometry))+  _ <- timedValue "set-intersection-unit" (evaluate . force =<< requireRight (intersection leftGeometry rightGeometry))+  _ <- timedValue "set-difference-unit" (evaluate . force =<< requireRight (difference leftGeometry rightGeometry))+  _ <-+    timedValue+      "set-symmetric-difference-unit"+      (evaluate . force =<< requireRight (symmetricDifference leftGeometry rightGeometry))+  _ <-+    timedValue+      "set-difference-right-empty"+      (evaluate . force =<< requireRight (difference leftGeometry emptyGeometry))+  _ <-+    timedValue+      "set-symmetric-difference-left-empty"+      (evaluate . force =<< requireRight (symmetricDifference emptyGeometry leftGeometry))+  _ <- timedValue "set-relation-half-overlap" (evaluate (force (siteRelation leftGeometry rightGeometry)))+  leftAnnotated <- siteMesh leftPoints+  rightAnnotated <- siteMesh rightPoints+  _ <- evaluate (force (leftAnnotated, rightAnnotated))+  _ <-+    timedValue+      "set-intersection-annotated"+      (evaluate . force =<< requireRight (intersectionWith (,) leftAnnotated rightAnnotated))+  _ <-+    timedValue+      "set-difference-annotated"+      (evaluate . force =<< requireRight (difference leftAnnotated rightAnnotated))+  _ <-+    timedValue+      "set-symmetric-difference-annotated"+      (evaluate . force =<< requireRight (symmetricDifference leftAnnotated rightAnnotated))+  pure ()+++canonical :: [Point] -> [Point]+canonical points = [Point x y | (x, y) <- dropAdjacentDuplicates (sort [(x, y) | Point x y <- points])]++dropAdjacentDuplicates :: Eq a => [a] -> [a]+dropAdjacentDuplicates (first : second : rest)+  | first == second = dropAdjacentDuplicates (second : rest)+  | otherwise = first : dropAdjacentDuplicates (second : rest)+dropAdjacentDuplicates rest = rest++geometryMesh :: [Point] -> IO Mesh+geometryMesh points = mapVertices (const ()) <$> siteMesh points++siteMesh :: [Point] -> IO SiteMesh+siteMesh points =+  buildTriangulation <$> requireRight (delaunay unitElementDefaults (V.fromList points))++unionsLeftAssociated :: [Mesh] -> Either BuildError Mesh+unionsLeftAssociated meshes = unions [] >>= \identity -> foldM union identity meshes
+ bench/publication/PublicationMain.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.JoinBench as JoinBench++main :: IO ()+main = JoinBench.publicationBenchmarks
+ bench/support/BenchSupport.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE NumericUnderscores #-}++-- | The measurement harness every benchmark slice shares. Deliberately not+-- @tasty-bench@: allocated bytes and the work counters the library reports+-- about itself are the figures a slice is here to expose, and a harness built+-- around a timing distribution cannot express either.+module BenchSupport+  ( timedValue+  , requireRight+  , randomPoints+  ) where++import Control.DeepSeq (NFData, force)+import Control.Exception (evaluate)+import Data.Word (Word64)+import GHC.Clock (getMonotonicTimeNSec)+import GHC.Stats (RTSStats (allocated_bytes), getRTSStats, getRTSStatsEnabled)+import Moonlight.Triangulation (Point (Point))+import System.CPUTime (getCPUTime)++-- | Both clocks, because they answer different questions and neither+-- substitutes for the other. Elapsed is what anything is compared against —+-- the board against spade is wall clock, and a parallel construction that used+-- more cores gets no allowance for having used them. CPU is the work receipt:+-- on one capability the two agree, and where they diverge the ratio is the+-- parallelism actually obtained. Reporting CPU alone, as this did, would let a+-- change that halves elapsed time and doubles total work read as a regression.+timedValue :: NFData value => String -> IO value -> IO value+timedValue label action = do+  statsEnabled <- getRTSStatsEnabled+  before <- if statsEnabled then Just <$> getRTSStats else pure Nothing+  wallStart <- getMonotonicTimeNSec+  cpuStart <- getCPUTime+  value <- action >>= evaluate . force+  cpuEnd <- getCPUTime+  wallEnd <- getMonotonicTimeNSec+  after <- if statsEnabled then Just <$> getRTSStats else pure Nothing+  putStrLn (label <> "-elapsed: " <> show (fromIntegral (wallEnd - wallStart) / 1.0e9 :: Double) <> "s")+  putStrLn (label <> "-cpu: " <> show (fromIntegral (cpuEnd - cpuStart) / 1.0e12 :: Double) <> "s")+  case (before, after) of+    (Just left, Just right) ->+      putStrLn (label <> "-allocated-bytes: " <> show (allocated_bytes right - allocated_bytes left))+    _ -> pure ()+  pure value++requireRight :: Show error => Either error value -> IO value+requireRight value = case value of+  Left failure -> fail (show failure)+  Right result -> pure result++randomPoints :: Word64 -> Int -> [Point]+randomPoints seed count = take count (go seed)+ where+  go :: Word64 -> [Point]+  go state =+    let state1 = state * 6364136223846793005 + 1442695040888963407+        state2 = state1 * 6364136223846793005 + 1442695040888963407+        unit :: Word64 -> Double+        unit value = fromIntegral (value `div` 2048) / 9_007_199_254_740_992+     in Point (2 * unit state1 - 1) (2 * unit state2 - 1) : go state2
+ docs/ARCHITECTURE.md view
@@ -0,0 +1,170 @@+# moonlight-triangulation architecture laws++`moonlight-triangulation.cabal` is the authoritative component, module, and+dependency graph. Duplicating that inventory here only manufactures a stale+second owner. This document records the laws the manifest cannot express.++## Geometry has one owner++The coordinate pages `triPointX` and `triPointY` own vertex geometry. Vertex+payloads are independent annotations: `setVertexData` and `mapVertices` may+change them without moving a vertex. `triPointIndex` is a derived lookup over+the coordinate pages.++Construction may read a position from an incoming payload through+`HasPosition`; no operation may later reconstruct geometry from that payload.+The versioned serialization boundary therefore persists coordinate pages and+payloads independently, then derives only the point index on decode.++## Topology is finite and mutation is sealed++The half-edge DCEL is a structure of arrays. Twin half-edges are arithmetic+complements (`e xor 1`), and every inner face has a three-edge cycle. Persistent+operations thaw into `MutableDcel` in `ST`, perform a bounded local rewrite, and+freeze the result; mutable references never escape.++Validation descends in two stages. Structural cardinality, range, link, face,+vertex, point-index, and Euler obligations must glue first. Geometric+orientation and Delaunay checks run only after that structural section is+valid, because reading geometry through malformed links would turn a reported+obstruction into an indexing crash.++## Constrained regions descend by barrier parity++For a constrained triangulation, a face's region is determined by the minimum+number of constrained edges crossed from the outer face. Even depths are+outside: depth zero is the exterior, depth one the first bounded domain, depth+two a hole, and so on. A dangling constraint can be walked around at depth+zero.++`FloodFillIterator.facesAtEvenBarrierDepth` owns this derived classification.+CDT queries and refinement import it; neither maintains a second definition of+"outside."++## Component cuts justify dependencies++Sublibraries are proof boundaries, not size buckets. In particular,+`serialize` alone owns the `binary` and `bytestring` dependencies. Modules named+`Internal` may be exposed only where Cabal sublibraries must cross them; that+exposure does not make them a supported public API.++## The surface states a theory++`Moonlight.Triangulation` is one export list read as the statement of a theory,+in eight sections: the object, generation, the annotation functor, the+finite-set algebra and its normal form, the constraint layer, refinement,+observations, discharge. A name reaches the surface because a law mentions it.++The headline law is a homomorphism from finite site sets to canonical+observations of triangulations,++    publish (A ∪ B) = canonicalize (union (publish A) (publish B))++where `publish` sends a site set through `delaunay` and then through+`canonicalize . mapVertices (const ())`. A raw build or local union may retain+the schedule that produced it, so structural `Eq` compares resident+representations while the finite-set laws compare their canonical,+payload-free images. `canonicalize` is that explicit physical normal form, and+`mapVertices (const ())` is the arrow onto the carrier used by the+geometry-only laws. Annotated `union` and `unions` glue equal-site payloads+through `JoinSemilattice` without allowing payloads to author geometry.++The exact support order is observed by `siteRelation`: equality, either proper+subset direction, disjointness, or a positive partial-overlap count. Restriction+descends through the same private site-set owner. `intersectionWith` combines+the left and right annotations only where both supports contain the coordinate;+`difference` preserves the left annotation; `symmetricDifference` preserves+the annotation of whichever exclusive support contains the coordinate. All+three publish through the same canonical rebuild boundary as the geometry-only+operations.++The generator is named `delaunay` because the equation is false of+triangulations in general and true of Delaunay triangulations. The name has to+make the law true.++The topology arena is finite, so union is not total. `union` and `unions`+therefore return `Either BuildError`; arena exhaustion is a typed obstruction,+not a lawful `Semigroup` instance with a trapdoor beneath it.++The constrained layer is not a total semilattice and does not pretend to be+one. Its+extension is the pair lattice of site sets and segment sets under componentwise+union, on which `constrainedDelaunay` is a partial homomorphism restricted to+the realizable sublattice: partiality kills `Semigroup`, and greedy+totalization kills associativity. `unionConstrained` is therefore surfaced as+an explicit operation returning `ConstrainedUnionError`, never as a typeclass+instance.++## Tiers govern names at their export site++Four tiers, and a name's tier is where it is exported rather than where it is+defined — a surface name may be defined below without lowering its tier.++The facade is the surface, and a subtraction there is a major version. The+sublibrary components are a partition: no manifest outside this package names+one, the in-repo spade referent excepted, since it ships with the package it+measures. Non-`Internal` sublibrary modules are the machine room, semi-stable+and reached by consumers who accept that. `Internal` modules promise nothing.++## Results are values, not histories++`BuildResult` and `RefinementResult` are abstract, reached through named+projections; `buildStats` and the rest of the telemetry stay below the wall.+Neither derives `Eq` or `Show`, because a derived instance observes through a+facade that hides — equality would consult counters the surface does not admit+exist.++## One concept has one owner++`isConstraintEdge` is owned by `Dcel`, polymorphic in the constraint mode;+`Cdt` does not restate it, and no alias survives. `innerFaceVertices` remains a+genuine collision — `Dcel`'s takes raw identifiers and answers `Maybe`, while+`Handles.Dynamic`'s takes and answers handles. Neither is surfaced, so the+collision stays in the machine room and callers name the module they mean.++## Vocabulary precedes representation++`Internal.Types` holds the vocabulary the surface names, none of which mentions+the stored mesh. `Internal.Representation` holds the structure of arrays, the+payload traversals, and the records that carry a built mesh beside its+telemetry. Representation imports vocabulary; the reverse import does not+exist. A type whose definition mentions the `Triangulation` record belongs to+Representation, which is why the result records live there.++## Mechanical acceptance++The native suite checks geometry and topology laws without depending on+`serialize`; the serialization suite checks the binary boundary separately. The+algebra suite is three slices with three dependency sets: fixtures, the laws+stated against the facade alone, and the agreement between the seam schedule+and the reference rebuild, which names an internal schedule and travels with+it. The parallel suite owns tournament behavior. The separate coherence test+imports every slice against the union of their dependencies at `-O0`; it detects+module and instance collisions but does not execute the behavioral suites a+second time.+The package's `warnings-as-errors` flag and `weeder.toml` turn compiler warnings+and unreachable internal declarations into refusals. The dedicated GitHub+workflow selects all library components from Cabal's generated plan rather than+restating build directories by hand.++## Published documentation is assembled, not generated++Cabal writes a Haddock interface for every sublibrary and hands none of them to+the siblings. The facade re-exports names it therefore cannot resolve, and+renders them as text. Cabal also writes one documentation tarball per+component, each under the same name, so the components overwrite one another+and only the last to run survives.++Hackage adds conditions of its own. A module on the package page links to its+documentation only when that page sits at the documentation root, so Cabal's+per-sublibrary subdirectories leave every module listed and unreachable. A+tarball is refused outright for a colon in any filename — which is how Cabal+names the sublibrary Hoogle databases — and for the extended attributes a macOS+`tar` attaches unbidden.++None of this is a defect in the component cuts. The repair changes no module,+no export, and no dependency; it is entirely downstream of the manifest, which+is why the manifest cannot express it. `release/hackage-docs.sh` owns it:+regenerate the facade against every sibling interface, flatten the module pages+to one root, cut a portable tarball. A release that skips the script publishes+a surface of unlinked names.
+ fuzz/README.md view
@@ -0,0 +1,25 @@+# Coverage-guided fuzzing++The fuzz executables are byte-oriented boundaries for an external coverage-guided engine. They are excluded from ordinary builds and add no dependency to any library component.++```bash+cabal build -ffuzz-targets \+  exe:moonlight-triangulation-fuzz-decode \+  exe:moonlight-triangulation-fuzz-constraints \+  exe:moonlight-triangulation-fuzz-refinement+```++Each executable accepts one corpus path in `@@` form or reads the input from standard input. On Linux, AFL++ can guide an uninstrumented GHC executable through QEMU mode:++```bash+afl-fuzz -Q -i fuzz/corpus/decode -o fuzz/artifacts/decode -- \+  "$(cabal list-bin -ffuzz-targets exe:moonlight-triangulation-fuzz-decode)" @@++afl-fuzz -Q -i fuzz/corpus/constraints -o fuzz/artifacts/constraints -- \+  "$(cabal list-bin -ffuzz-targets exe:moonlight-triangulation-fuzz-constraints)" @@++afl-fuzz -Q -i fuzz/corpus/refinement -o fuzz/artifacts/refinement -- \+  "$(cabal list-bin -ffuzz-targets exe:moonlight-triangulation-fuzz-refinement)" @@+```++Decoder refusals, unrealizable constraint batches, invalid refinement parameters, and rejected domains are expected typed outcomes. A target fails only when an admitted result violates the DCEL laws or serialization round-trip.
+ fuzz/constraints/Main.hs view
@@ -0,0 +1,27 @@+module Main (main) where++import qualified Data.ByteString as BS+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.Cdt+import Moonlight.Triangulation.Fuzz.Boundary (runFuzzTarget)+import Moonlight.Triangulation.Fuzz.Input (decodeConstraints, decodePoints)++newtype ConstraintFuzzFailure = ConstraintInvariantFailure (NonEmpty InvariantViolation)+  deriving stock (Show)++main :: IO ()+main = runFuzzTarget fuzzConstraintRecovery++fuzzConstraintRecovery :: BS.ByteString -> Either ConstraintFuzzFailure ()+fuzzConstraintRecovery bytes =+  case constrainedDelaunayMaximal unitElementDefaults points constraints of+    Left _ -> Right ()+    Right result ->+      case validateTriangulation (cdtBuildTriangulation result) of+        violation : violations -> Left (ConstraintInvariantFailure (violation :| violations))+        [] -> Right ()+ where+  points = decodePoints bytes+  constraints = decodeConstraints bytes (V.length points)
+ fuzz/corpus/constraints/seed.bin view

binary file changed (absent → 12 bytes)

+ fuzz/corpus/decode/seed.bin view

binary file changed (absent → 482 bytes)

+ fuzz/corpus/refinement/seed.bin view

binary file changed (absent → 14 bytes)

+ fuzz/decode/Main.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DataKinds #-}++module Main (main) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.List.NonEmpty (NonEmpty (..))+import Moonlight.Triangulation+import Moonlight.Triangulation.Fuzz.Boundary (runFuzzTarget)+import Moonlight.Triangulation.Serialization+import Moonlight.Triangulation.Types (KnownConstraintMode)++data DecodeFuzzFailure+  = DecodeInvariantFailure !(NonEmpty InvariantViolation)+  | DecodeRoundTripFailure+  deriving stock (Show)++main :: IO ()+main = runFuzzTarget fuzzDecodeTriangulation++fuzzDecodeTriangulation :: BS.ByteString -> Either DecodeFuzzFailure ()+fuzzDecodeTriangulation bytes =+  checkUnconstrained (decodeTriangulation lazyBytes)+    *> checkConstrained (decodeTriangulation lazyBytes)+ where+  lazyBytes = BL.fromStrict bytes++checkUnconstrained+  :: Either SerializationError (Triangulation 'Unconstrained () () () ())+  -> Either DecodeFuzzFailure ()+checkUnconstrained = either (const (Right ())) checkDecoded++checkConstrained+  :: Either SerializationError (Triangulation 'Constrained () () () ())+  -> Either DecodeFuzzFailure ()+checkConstrained = either (const (Right ())) checkDecoded++checkDecoded+  :: KnownConstraintMode mode+  => Triangulation mode () () () ()+  -> Either DecodeFuzzFailure ()+checkDecoded triangulation =+  case validateTriangulation triangulation of+    violation : violations -> Left (DecodeInvariantFailure (violation :| violations))+    [] ->+      case decodeTriangulation (encodeTriangulation triangulation) of+        Right decoded+          | decoded == triangulation -> Right ()+        _ -> Left DecodeRoundTripFailure
+ fuzz/refinement/Main.hs view
@@ -0,0 +1,117 @@+module Main (main) where++import qualified Data.ByteString as BS+import qualified Data.Set as Set+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.Cdt+import Moonlight.Triangulation.Fuzz.Boundary (runFuzzTarget)+import Moonlight.Triangulation.Fuzz.Input+  ( decodeConstraints+  , decodePoints+  , decodeRefinementParameters+  , inputByte+  )+import Moonlight.Triangulation.Handles.HandleDefs+  ( FaceId (..)+  , UndirectedEdgeId (..)+  )++data RefinementFuzzFailure+  = RefinementInvariantFailure !(NonEmpty InvariantViolation)+  | RefinementFullDomainInvariantFailure !(NonEmpty InvariantViolation)+  | RefinementDomainInvariantFailure !(NonEmpty InvariantViolation)+  deriving stock (Show)++main :: IO ()+main = runFuzzTarget fuzzRefinementAdmission++fuzzRefinementAdmission :: BS.ByteString -> Either RefinementFuzzFailure ()+fuzzRefinementAdmission bytes =+  case constrainedDelaunayMaximal unitElementDefaults points constraints of+    Left _ -> Right ()+    Right buildResult ->+      let triangulation = cdtBuildTriangulation buildResult+       in checkOrdinary triangulation+            *> checkFullDomain triangulation+            *> checkHostileDomain triangulation+ where+  points = decodePoints bytes+  constraints = decodeConstraints bytes (V.length points)+  parameters = decodeRefinementParameters bytes+  checkOrdinary triangulation =+    case validateRefinementParameters parameters of+      Left _ -> Right ()+      Right () ->+        either+          (const (Right ()))+          (checkResult RefinementInvariantFailure)+          (refine id parameters triangulation)+  checkFullDomain triangulation =+    either+      (const (Right ()))+      (checkResult RefinementFullDomainInvariantFailure . refinementDomainResult)+      ( refineWithinDomain+          id+          domainParameters+          (allInnerFaces triangulation)+          Set.empty+          triangulation+      )+  checkHostileDomain triangulation =+    either+      (const (Right ()))+      (checkResult RefinementDomainInvariantFailure . refinementDomainResult)+      ( refineWithinDomain+          id+          domainParameters+          (faceSelection triangulation)+          (edgeSelection triangulation)+          triangulation+      )+  allInnerFaces+    :: Triangulation mode vertex directed undirected face+    -> Set.Set FaceId+  allInnerFaces triangulation =+    Set.fromDistinctAscList+      (FaceId . fromIntegral <$> [1 .. numFaces triangulation - 1])+  domainParameters =+    defaultRefinementParameters+      { refineMaxAdditionalVertices = Just (fromIntegral (inputByte bytes 7) `mod` 9)+      , refineMaxArea = Just (fromIntegral (inputByte bytes 8) / 8 + 1 / 8)+      , refinePreserveConvexHull = True+      , refineKeepConstraintEdges = True+      , refineExcludeOuterFaces = False+      }+  faceSelection triangulation =+    Set.fromList+      ( V.toList+          ( V.generate+              (min 24 (fromIntegral (inputByte bytes 9)))+              (FaceId . fromIntegral . selectedFace triangulation)+          )+      )+  selectedFace triangulation index+    | inputByte bytes (index + 10) `mod` 8 == 0 = numFaces triangulation + index+    | otherwise = fromIntegral (inputByte bytes (index + 10)) `mod` max 1 (numFaces triangulation)+  edgeSelection triangulation =+    Set.fromList+      ( V.toList+          ( V.generate+              (min 24 (fromIntegral (inputByte bytes 34)))+              (UndirectedEdgeId . fromIntegral . selectedEdge triangulation)+          )+      )+  selectedEdge triangulation index+    | inputByte bytes (index + 35) `mod` 8 == 0 = numUndirectedEdges triangulation + index+    | otherwise = fromIntegral (inputByte bytes (index + 35)) `mod` max 1 (numUndirectedEdges triangulation)++checkResult+  :: (NonEmpty InvariantViolation -> RefinementFuzzFailure)+  -> RefinementResult mode vertex directed undirected face+  -> Either RefinementFuzzFailure ()+checkResult failure result =+  case validateTriangulation (refinedTriangulation result) of+    violation : violations -> Left (failure (violation :| violations))+    [] -> Right ()
+ fuzz/support/Moonlight/Triangulation/Fuzz/Boundary.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE LambdaCase #-}++module Moonlight.Triangulation.Fuzz.Boundary+  ( runFuzzTarget+  ) where++import qualified Data.ByteString as BS+import System.Environment (getArgs)+import System.Exit (die)++runFuzzTarget :: Show failure => (BS.ByteString -> Either failure ()) -> IO ()+runFuzzTarget target =+  readInput >>= either (die . show) (const (pure ())) . target++readInput :: IO BS.ByteString+readInput =+  getArgs >>= \case+    [] -> BS.getContents+    [path] -> BS.readFile path+    _ -> die "expected zero arguments for stdin or one input path"
+ fuzz/support/Moonlight/Triangulation/Fuzz/Input.hs view
@@ -0,0 +1,65 @@+module Moonlight.Triangulation.Fuzz.Input+  ( decodeConstraints+  , decodePoints+  , decodeRefinementParameters+  , inputByte+  ) where++import qualified Data.ByteString as BS+import qualified Data.Vector as V+import Data.Word (Word8)+import Moonlight.Triangulation++decodePoints :: BS.ByteString -> V.Vector Point+decodePoints bytes =+  V.generate pointCount $ \index ->+    Point+      (coordinate (inputByte bytes (2 * index)) + fromIntegral (index `mod` 3) / 1024)+      (coordinate (inputByte bytes (2 * index + 1)) + fromIntegral ((index * index) `mod` 5) / 1024)+ where+  pointCount = max 3 (min 64 ((BS.length bytes + 1) `quot` 2))+  coordinate :: Word8 -> Double+  coordinate value = (fromIntegral value - 127.5) / 4++decodeConstraints :: BS.ByteString -> Int -> V.Vector (Int, Int)+decodeConstraints bytes pointCount =+  V.generate constraintCount $ \index ->+    (endpoint (inputByte bytes (2 * index)), endpoint (inputByte bytes (2 * index + 1)))+ where+  constraintCount = max 1 (min 96 ((BS.length bytes + 1) `quot` 2))+  endpoint value+    | value `mod` 8 == 0 = pointCount + fromIntegral (value `mod` 5)+    | otherwise = fromIntegral value `mod` pointCount++decodeRefinementParameters :: BS.ByteString -> RefinementParameters+decodeRefinementParameters bytes =+  defaultRefinementParameters+    { refineMaxAdditionalVertices = budget (inputByte bytes 0)+    , refineMinArea = metric (inputByte bytes 1)+    , refineMaxArea = metric (inputByte bytes 2)+    , refineMaxRadiusEdgeRatio = metric (inputByte bytes 3)+    , refinePreserveConvexHull = odd (inputByte bytes 4)+    , refineKeepConstraintEdges = odd (inputByte bytes 5)+    , refineExcludeOuterFaces = odd (inputByte bytes 6)+    }+ where+  budget :: Word8 -> Maybe Int+  budget value =+    case value `mod` 5 of+      0 -> Nothing+      1 -> Just (-1)+      _ -> Just (fromIntegral value `mod` 17)+  metric :: Word8 -> Maybe Double+  metric value =+    case value `mod` 8 of+      0 -> Nothing+      1 -> Just (-1)+      2 -> Just 0+      3 -> Just (0 / 0)+      4 -> Just (1 / 0)+      _ -> Just (fromIntegral value / 8)++inputByte :: BS.ByteString -> Int -> Word8+inputByte bytes index+  | BS.null bytes = fromIntegral index+  | otherwise = BS.index bytes (index `mod` BS.length bytes)
+ moonlight-triangulation.cabal view
@@ -0,0 +1,583 @@+cabal-version:       3.4+name:                moonlight-triangulation+version:             0.1.0.0+synopsis:            Delaunay triangulations as a lawful finite-set algebra.+description:         Delaunay and constrained Delaunay triangulation as a lawful+                     finite-set algebra: a mesh is a value of its site set, so+                     union, intersection and difference return triangulations+                     and refinement composes after them rather than replacing+                     them. One structure-of-arrays half-edge mesh carries the+                     constrained and unconstrained layers, split into public+                     sublibraries by role: exact binary64 predicates and paged+                     storage; the finite DCEL with its handle,+                     iterator, location and validation surface; circle-sweep bulk+                     load, incremental insertion, removal, conflict-strip+                     constraint recovery and Ruppert refinement; the Voronoi dual+                     with natural-neighbour interpolation and Delaunay hierarchy+                     hints; a bounded-concurrency interpreter for the join+                     tournament; and a versioned binary serialization surface.+                     Failure is values: every refusal names its witness.+license:             MIT+license-file:        LICENSE+author:              Fable, Blue Rose+maintainer:          rosaliafialkova@gmail.com+copyright:           (c) 2026 Fable, Blue Rose+category:            Geometry, Math+homepage:            https://github.com/PaleRoses/moonlight+bug-reports:         https://github.com/PaleRoses/moonlight/issues+build-type:          Simple+tested-with:         GHC == 9.10.3+                     GHC == 9.12.4+                     GHC == 9.14.1+extra-doc-files:+  README.md+  CHANGELOG.md+  docs/ARCHITECTURE.md+extra-source-files:+  weeder.toml+  fuzz/README.md+  fuzz/corpus/constraints/seed.bin+  fuzz/corpus/decode/seed.bin+  fuzz/corpus/refinement/seed.bin++source-repository head+  type:     git+  location: https://github.com/PaleRoses/moonlight.git+  subdir:   moonlight-triangulation++flag warnings-as-errors+  description: Treat compiler warnings as errors in package validation.+  default: False+  manual: True++flag fuzz-targets+  description: Build the external coverage-guided fuzz entrypoints.+  default: False+  manual: True++common shared-properties+  default-language: GHC2024+  ghc-options:+    -Wall+    -Wcompat+    -Widentities+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wredundant-constraints+    -Wpartial-fields+    -Wno-missing-import-lists+  if flag(warnings-as-errors)+    ghc-options: -Werror++-- ── the tower ────────────────────────────────────────────────────────────────+-- The main tower is core <- dcel <- build <- dual <- facade.  Serialize branches+-- from dcel and parallel branches from build, keeping their effect dependencies+-- out of the tower.  The graph is acyclic and uses no @.hs-boot@ files.++library core+  import: shared-properties+  visibility: public+  hs-source-dirs: src-core+  exposed-modules:+    Moonlight.Triangulation.Scalar+    Moonlight.Triangulation.LineSideInfo+    Moonlight.Triangulation.Internal.Dyadic+    Moonlight.Triangulation.Internal.PageDirectory+    Moonlight.Triangulation.Internal.Paged+    Moonlight.Triangulation.Internal.BoxedPaged+    Moonlight.Triangulation.Internal.Growable+    Moonlight.Triangulation.Internal.PackedIndex+    Moonlight.Triangulation.Internal.FaceQueue+  build-depends:+    base >= 4.20 && < 5+    , containers >= 0.8 && < 0.9+    , deepseq >= 1.5 && < 1.6+    , vector >= 0.13 && < 0.14+  ghc-options: -fexpose-all-unfoldings++library dcel+  import: shared-properties+  visibility: public+  hs-source-dirs: src-dcel+  exposed-modules:+    Moonlight.Triangulation.Types+    Moonlight.Triangulation.Math+    Moonlight.Triangulation.Interop+    Moonlight.Triangulation.Dcel+    Moonlight.Triangulation.Payload+    Moonlight.Triangulation.JoinSemilattice+    Moonlight.Triangulation.Handles+    Moonlight.Triangulation.Handles.HandleDefs+    Moonlight.Triangulation.Handles.Dynamic+    Moonlight.Triangulation.Handles.Iterators+    Moonlight.Triangulation.Handles.Iterators.CircularIterator+    Moonlight.Triangulation.Handles.Iterators.DynamicIterators+    Moonlight.Triangulation.Handles.Iterators.FixedIterators+    Moonlight.Triangulation.Handles.Iterators.HullIterator+    Moonlight.Triangulation.PointLocation+    Moonlight.Triangulation.Validation+    Moonlight.Triangulation.FloodFillIterator+    Moonlight.Triangulation.IntersectionIterator+    Moonlight.Triangulation.Internal.FaceProbe+    Moonlight.Triangulation.Internal.Types+    Moonlight.Triangulation.Internal.Representation+    Moonlight.Triangulation.Internal.PointIndex+    Moonlight.Triangulation.Internal.Mutable+    Moonlight.Triangulation.Internal.OperationState+    Moonlight.Triangulation.Internal.Probe+    Moonlight.Triangulation.Internal.DcelOperations+    Moonlight.Triangulation.Internal.DcelOperations.CandidateArena+    Moonlight.Triangulation.Internal.DcelOperations.Chain+    Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite+    Moonlight.Triangulation.Internal.DcelOperations.FlipRule+    Moonlight.Triangulation.Internal.DcelOperations.Hull+    Moonlight.Triangulation.Internal.DcelOperations.Legalize+    Moonlight.Triangulation.Internal.DcelOperations.Normalize+    Moonlight.Triangulation.Internal.DcelOperations.Subdivide+    Moonlight.Triangulation.Internal.DcelOperations.Twin+    Moonlight.Triangulation.Internal.Canonical+  build-depends:+    base >= 4.20 && < 5+    , containers >= 0.8 && < 0.9+    , deepseq >= 1.5 && < 1.6+    , primitive >= 0.9 && < 0.10+    , vector >= 0.13 && < 0.14+    , vector-algorithms >= 0.9 && < 0.10+    , moonlight-triangulation:core+  ghc-options: -fexpose-all-unfoldings++library build+  import: shared-properties+  visibility: public+  hs-source-dirs: src-build+  exposed-modules:+    Moonlight.Triangulation.BulkLoad+    Moonlight.Triangulation.Removal+    Moonlight.Triangulation.Session+    Moonlight.Triangulation.Cdt+    Moonlight.Triangulation.Refinement+    Moonlight.Triangulation.SetAlgebra+    Moonlight.Triangulation.Internal.Cdt.Build+    Moonlight.Triangulation.Internal.Cdt.Query+    Moonlight.Triangulation.Internal.Cdt.Types+    Moonlight.Triangulation.Internal.Cdt.Union+    Moonlight.Triangulation.Internal.Join+    Moonlight.Triangulation.Internal.Join.Seam+  other-modules:+    Moonlight.Triangulation.Insertion+    Moonlight.Triangulation.Internal.Capacity+    Moonlight.Triangulation.Internal.Cdt.Admission+    Moonlight.Triangulation.Internal.Cdt.Batch+    Moonlight.Triangulation.Internal.Cdt.Combinators+    Moonlight.Triangulation.Internal.Cdt.Corridor+    Moonlight.Triangulation.Internal.Cdt.Corridor.Trace+    Moonlight.Triangulation.Internal.Cdt.Recovery+    Moonlight.Triangulation.Internal.Cdt.Region+    Moonlight.Triangulation.Internal.Cdt.Segment+    Moonlight.Triangulation.Internal.Cdt.Site+    Moonlight.Triangulation.Internal.Cdt.Split+    Moonlight.Triangulation.Internal.Excision+    Moonlight.Triangulation.Internal.Location+    Moonlight.Triangulation.Internal.CircleSweep+    Moonlight.Triangulation.Internal.Refinement+    Moonlight.Triangulation.Internal.Transaction+    Moonlight.Triangulation.Internal.Join.Plan+    Moonlight.Triangulation.Internal.Join.Rebuild+    Moonlight.Triangulation.Internal.Join.SiteSet+  build-depends:+    base >= 4.20 && < 5+    , containers >= 0.8 && < 0.9+    , deepseq >= 1.5 && < 1.6+    , primitive >= 0.9 && < 0.10+    , vector >= 0.13 && < 0.14+    , vector-algorithms >= 0.9 && < 0.10+    , moonlight-triangulation:core+    , moonlight-triangulation:dcel+  ghc-options: -fexpose-all-unfoldings++-- Concurrency is an effect boundary over the pure build planner. Keeping it in+-- its own sublibrary prevents @async@ from infecting the geometry core.+library parallel+  import: shared-properties+  visibility: public+  hs-source-dirs: src-parallel+  exposed-modules:+    Moonlight.Triangulation.Parallel+  build-depends:+    base >= 4.20 && < 5+    , async >= 2.2 && < 2.3+    , deepseq >= 1.5 && < 1.6+    , moonlight-triangulation:core+    , moonlight-triangulation:build+    , moonlight-triangulation:dcel+  ghc-options: -fexpose-all-unfoldings++-- Its own sublibrary so that @binary@ and @bytestring@ stay out of the minimal+-- geometry core.  This is a dependency boundary, not a size split; it replaces+-- the former @serialization@ flag, which could not be checked by a single build.+library serialize+  import: shared-properties+  visibility: public+  hs-source-dirs: src-serialize+  exposed-modules:+    Moonlight.Triangulation.Serialization+  build-depends:+    base >= 4.20 && < 5+    , binary >= 0.8 && < 0.9+    , bytestring >= 0.12 && < 0.13+    , containers >= 0.8 && < 0.9+    , transformers >= 0.6 && < 0.7+    , vector >= 0.13 && < 0.14+    , moonlight-triangulation:core+    , moonlight-triangulation:dcel+  -- The @Binary@ instances for the identifier and point types are orphans by+  -- construction: the types belong to @dcel@ and the class to @binary@, and the+  -- whole purpose of this component is that neither one has to know about the+  -- other.  Rehoming them would pull @binary@ into the core and defeat the split.+  ghc-options: -fexpose-all-unfoldings -Wno-orphans++library dual+  import: shared-properties+  visibility: public+  hs-source-dirs: src-dual+  exposed-modules:+    Moonlight.Triangulation.Voronoi+    Moonlight.Triangulation.Voronoi.Handles+    Moonlight.Triangulation.Interpolation+    Moonlight.Triangulation.HintGenerator+  other-modules:+    Moonlight.Triangulation.Internal.InterpolationWorkspace+  build-depends:+    base >= 4.20 && < 5+    , deepseq >= 1.5 && < 1.6+    , primitive >= 0.9 && < 0.10+    , vector >= 0.13 && < 0.14+    , moonlight-triangulation:core+    , moonlight-triangulation:dcel+    , moonlight-triangulation:build+  ghc-options: -fexpose-all-unfoldings++library+  import: shared-properties+  hs-source-dirs: src-public+  exposed-modules:+    Moonlight.Triangulation+  build-depends:+    base >= 4.20 && < 5+    , moonlight-triangulation:core+    , moonlight-triangulation:dcel+    , moonlight-triangulation:build+    , moonlight-triangulation:dual+  ghc-options: -fexpose-all-unfoldings++common triangulation-fuzz-properties+  import: shared-properties+  hs-source-dirs: fuzz/support+  other-modules:+    Moonlight.Triangulation.Fuzz.Boundary+    Moonlight.Triangulation.Fuzz.Input+  build-depends:+    base >= 4.20 && < 5+    , bytestring >= 0.12 && < 0.13+    , containers >= 0.8 && < 0.9+    , vector >= 0.13 && < 0.14+    , moonlight-triangulation+    , moonlight-triangulation:build+    , moonlight-triangulation:dcel++executable moonlight-triangulation-fuzz-decode+  import: triangulation-fuzz-properties+  if !flag(fuzz-targets)+    buildable: False+  main-is: Main.hs+  hs-source-dirs: fuzz/decode+  build-depends:+    binary >= 0.8 && < 0.9+    , moonlight-triangulation:serialize++executable moonlight-triangulation-fuzz-constraints+  import: triangulation-fuzz-properties+  if !flag(fuzz-targets)+    buildable: False+  main-is: Main.hs+  hs-source-dirs: fuzz/constraints++executable moonlight-triangulation-fuzz-refinement+  import: triangulation-fuzz-properties+  if !flag(fuzz-targets)+    buildable: False+  main-is: Main.hs+  hs-source-dirs: fuzz/refinement++-- ── test slices ──────────────────────────────────────────────────────────────++-- Each slice is an ATOM: a @common@ stanza binding a spec module to the+-- dependencies and RTS options that module requires.  A suite is then a choice+-- of atoms and nothing more.  The coherence component below imports every atom+-- and therefore checks their combined module, instance, and dependency surface+-- without running every behavioral suite a second time.++common triangulation-test-properties+  import: shared-properties+  build-depends:+    base >= 4.20 && < 5+    , deepseq >= 1.5 && < 1.6+    , vector >= 0.13 && < 0.14+    , primitive >= 0.9 && < 0.10+    , moonlight-triangulation++common triangulation-test-support-slice+  other-modules: Support++common triangulation-native-test-slice+  other-modules:+    Moonlight.Triangulation.NativeSpec+    Moonlight.Triangulation.FilteredPredicateOptimizationSpec+  -- The RTS options this module needs are named on the SUITES rather than+  -- here, which is the one place the slice-owns-its-requirements rule cannot+  -- hold.  @-with-rtsopts@ is CONCATENATED by GHC across repetitions, so a+  -- suite importing two slices that both name it links a binary whose RTS+  -- string is the two spliced together — @-N4 -T-N4 -T@ — which the RTS+  -- discards whole, silently disarming both.  It must appear exactly once per+  -- suite, so @triangulation-suite-rtsopts@ below carries it.+  ghc-options: -threaded -rtsopts+  build-depends:+    containers >= 0.8 && < 0.9+    , moonlight-triangulation:core+    , moonlight-triangulation:dcel+    , moonlight-triangulation:build+    , moonlight-triangulation:dual++common triangulation-serialization-test-slice+  other-modules: Moonlight.Triangulation.SerializationSpec+  build-depends:+    binary >= 0.8 && < 0.9+    , bytestring >= 0.12 && < 0.13+    , moonlight-triangulation:serialize++-- The operand meshes both algebra slices are stated over.  It sits at the+-- surface tier with them, so the fixtures cannot quietly acquire a+-- machine-room dependency that the law slice would then inherit.+common triangulation-algebra-fixture-slice+  other-modules: Moonlight.Triangulation.AlgebraFixtures+  build-depends: containers >= 0.8 && < 0.9++-- The finite-set laws, stated against the facade a caller has.+common triangulation-algebra-law-slice+  other-modules: Moonlight.Triangulation.AlgebraSpec+  build-depends: containers >= 0.8 && < 0.9++-- The agreement between the seam schedule and the reference rebuild.  It names+-- an internal schedule, so it reaches below the wall and travels with the+-- schedule it names: a replacement kernel carries its own copy of this.+common triangulation-algebra-schedule-slice+  other-modules: Moonlight.Triangulation.ScheduleAgreementSpec+  build-depends: moonlight-triangulation:build++common triangulation-parallel-test-slice+  other-modules: Moonlight.Triangulation.ParallelSpec+  ghc-options: -threaded -rtsopts+  build-depends: moonlight-triangulation:parallel++-- The single statement of the RTS environment every suite runs under: -N so+-- that the concurrent tournament has more than one capability to be scheduled+-- onto, -T so that the filtered-predicate test can read allocation counters.+-- It is one stanza rather than a line on each slice because @-with-rtsopts@+-- concatenates rather than replaces, so naming it twice in one suite produces+-- a spliced string the RTS rejects entirely.  Every behavioral suite that+-- needs those capabilities imports this exactly once; the compile-only+-- coherence suite deliberately installs no runtime defaults.+common triangulation-suite-rtsopts+  ghc-options: -threaded -rtsopts "-with-rtsopts=-N4 -T"++test-suite moonlight-triangulation-native-test+  import:+    triangulation-suite-rtsopts,+    triangulation-test-properties,+    triangulation-test-support-slice,+    triangulation-native-test-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    test/native+    test/support++test-suite moonlight-triangulation-serialization-test+  import:+    triangulation-test-properties,+    triangulation-test-support-slice,+    triangulation-serialization-test-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    test/serialization+    test/support++test-suite moonlight-triangulation-algebra-test+  import:+    triangulation-test-properties,+    triangulation-test-support-slice,+    triangulation-algebra-fixture-slice,+    triangulation-algebra-law-slice,+    triangulation-algebra-schedule-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    test/algebra+    test/support++test-suite moonlight-triangulation-parallel-test+  import:+    triangulation-suite-rtsopts,+    triangulation-test-properties,+    triangulation-test-support-slice,+    triangulation-algebra-fixture-slice,+    triangulation-parallel-test-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    test/parallel+    test/algebra+    test/support++-- This component owns only cross-slice compile coherence.  Behavioral ownership+-- remains in the four focused suites.  The shared test-properties stanza keeps+-- every test body at @-O0@, so the union retains type/module/instance collision+-- detection without paying to optimize a second copy of every test body.+test-suite moonlight-triangulation-coherence-test+  import:+    triangulation-test-properties,+    triangulation-test-support-slice,+    triangulation-native-test-slice,+    triangulation-serialization-test-slice,+    triangulation-algebra-fixture-slice,+    triangulation-algebra-law-slice,+    triangulation-algebra-schedule-slice,+    triangulation-parallel-test-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    test/coherence+    test/native+    test/serialization+    test/algebra+    test/parallel+    test/support++-- ── benchmark slices ─────────────────────────────────────────────────────────+-- Deliberately not @tasty-bench@: these report allocated bytes and the work+-- counters the library keeps about itself — hierarchy walk steps, refinement+-- queue pops, bytes per interpolation query — and a wall-clock harness cannot+-- express any of them.  @core@ and @serialize@ carry no benchmark today; that is+-- stated rather than filled with an invented one.++common triangulation-benchmark-properties+  import: shared-properties+  -- The allocation arms read GHC.Stats, which is dark without -T.  As with the+  -- test suites, @-with-rtsopts@ is CONCATENATED by GHC across repetitions, so+  -- it must appear exactly once per benchmark: this stanza is that one place,+  -- and no benchmark slice may name it again.+  ghc-options: -threaded -rtsopts "-with-rtsopts=-T"+  build-depends:+    base >= 4.20 && < 5+    , deepseq >= 1.5 && < 1.6+    , vector >= 0.13 && < 0.14+    , moonlight-triangulation++common triangulation-benchmark-support-slice+  other-modules: BenchSupport++common triangulation-build-benchmark-slice+  other-modules: Moonlight.Triangulation.BuildBench+  build-depends:+    primitive >= 0.9 && < 0.10+    , moonlight-triangulation:dcel+    , moonlight-triangulation:build++common triangulation-dcel-benchmark-slice+  other-modules: Moonlight.Triangulation.DcelBench+  build-depends: moonlight-triangulation:dcel++common triangulation-dual-benchmark-slice+  other-modules: Moonlight.Triangulation.DualBench+  build-depends: moonlight-triangulation:dual++common triangulation-join-benchmark-slice+  other-modules: Moonlight.Triangulation.JoinBench+  build-depends:+    moonlight-triangulation:dcel+    , moonlight-triangulation:build++benchmark moonlight-triangulation-build-bench+  import:+    triangulation-benchmark-properties,+    triangulation-benchmark-support-slice,+    triangulation-build-benchmark-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    bench/build+    bench/support++benchmark moonlight-triangulation-dcel-bench+  import:+    triangulation-benchmark-properties,+    triangulation-benchmark-support-slice,+    triangulation-dcel-benchmark-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    bench/dcel+    bench/support++benchmark moonlight-triangulation-dual-bench+  import:+    triangulation-benchmark-properties,+    triangulation-benchmark-support-slice,+    triangulation-dual-benchmark-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    bench/dual+    bench/support++benchmark moonlight-triangulation-join-bench+  import:+    triangulation-benchmark-properties,+    triangulation-benchmark-support-slice,+    triangulation-join-benchmark-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    bench/join+    bench/support++benchmark moonlight-triangulation-publication-bench+  import:+    triangulation-benchmark-properties,+    triangulation-benchmark-support-slice,+    triangulation-join-benchmark-slice+  type: exitcode-stdio-1.0+  main-is: PublicationMain.hs+  hs-source-dirs:+    bench/publication+    bench/join+    bench/support++benchmark moonlight-triangulation-bench+  import:+    triangulation-benchmark-properties,+    triangulation-benchmark-support-slice,+    triangulation-build-benchmark-slice,+    triangulation-dcel-benchmark-slice,+    triangulation-dual-benchmark-slice,+    triangulation-join-benchmark-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    bench/aggregate+    bench/build+    bench/dcel+    bench/dual+    bench/join+    bench/support
+ src-build/Moonlight/Triangulation/BulkLoad.hs view
@@ -0,0 +1,552 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Generation. @delaunay@ builds a mesh from a whole site set by circle sweep;+-- the insertion verbs extend an existing mesh one site at a time.+module Moonlight.Triangulation.BulkLoad+  ( empty+  , clear+  , delaunay+  , DuplicatePayloadPolicy (..)+  , delaunayFromCoordinates+  , insert+  , insertAt+  , insertMany+  ) where++import Control.Monad (forM_)+import Control.Monad.ST (ST, runST)+import qualified Data.IntSet as IntSet+import Data.Primitive.PrimArray+  ( MutablePrimArray+  , newPrimArray+  , unsafeFreezePrimArray+  , writePrimArray+  )+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32)+import Moonlight.Triangulation.Dcel (numInnerFaces, numVertices)+import Moonlight.Triangulation.Handles.HandleDefs (DirectedEdgeId (..), FaceId (..), VertexId (..))+import Moonlight.Triangulation.Internal.BoxedPaged (boxedFromVector, boxedUpdate, emptyBoxedPaged)+import Moonlight.Triangulation.Internal.Capacity (ensureCapacity)+import Moonlight.Triangulation.Insertion (insertExistingVertexAtLocation, insertVertexAtPoint)+import Moonlight.Triangulation.Internal.Location (MutableLocation (..))+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , freezeBuildStats+  , newOperationState+  , setCounter+  )+import Moonlight.Triangulation.Internal.CircleSweep (circleSweepInsert)+import Moonlight.Triangulation.Internal.PointIndex+  ( MutablePointIndex+  , emptyPointIndex+  , newMutablePointIndex+  , resolveMutablePoint+  , seedMutablePointIndex+  )+import Moonlight.Triangulation.Math (canonicalCoordinate, validatePoint)+import Moonlight.Triangulation.PointLocation (locatePointWithHint)+import Moonlight.Triangulation.Internal.Probe (Probe (..))+import Moonlight.Triangulation.Internal.Representation (Triangulation (..))+import Moonlight.Triangulation.Internal.PackedIndex (noIndex)+import Moonlight.Triangulation.Internal.Paged (TransactionShape (DenseTransaction, LocalTransaction), emptyPaged, fromVector)+import Moonlight.Triangulation.Internal.Transaction (runTransaction)+import Moonlight.Triangulation.Types++-- | The vertexless triangulation: the outer face and nothing else. This is the+-- canonical origin of the type — bulk loading, incremental insertion and+-- refinement all agree with growing this value.+empty+  :: ElementDefaults directed undirected face+  -> Triangulation mode vertex directed undirected face+empty defaults@ElementDefaults{defaultDirectedEdgeData, defaultUndirectedEdgeData, defaultFaceData} =+  Triangulation+    { triPointX = emptyPaged+    , triPointY = emptyPaged+    , triPointIndex = emptyPointIndex+    , triVertexOut = emptyPaged+    , triVertexData = emptyBoxedPaged Nothing+    , triHalfTopology = emptyPaged+    , triDirectedData = emptyBoxedPaged (Just defaultDirectedEdgeData)+    , triUndirectedData = emptyBoxedPaged (Just defaultUndirectedEdgeData)+    , triFaceEdge = fromVector noIndex (U.singleton noIndex)+    , triFaceData = boxedFromVector (Just defaultFaceData) (V.singleton defaultFaceData)+    , triConstraint = emptyPaged+    , triConstraintCount = 0+    , triConstraintEdges = IntSet.empty+    , triElementDefaults = defaults+    }++-- | Discard every vertex while retaining the element defaults the+-- triangulation was built with.+clear+  :: Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex directed undirected face+clear = empty . triElementDefaults++-- | How a canonical bulk source combines payloads whose exact coordinates+-- coincide. Geometry identity is settled independently by the point index.+data DuplicatePayloadPolicy vertex+  = KeepFirstPayload+  | CombineDuplicatePayload !(vertex -> vertex -> vertex)++-- | Build a finite Delaunay DCEL while preserving the first input payload at+-- every duplicate position. The returned mapping relates every input slot to+-- the canonical stored vertex.+delaunay+  :: forall vertex directed undirected face+   . HasPosition vertex+  => ElementDefaults directed undirected face+  -> V.Vector vertex+  -> Either BuildError (BuildResult 'Unconstrained vertex directed undirected face)+delaunay defaults input = do+  validateVertices input+  buildDelaunayFromSource+    defaults+    (V.length input)+    (position . (input V.!))+    (input V.!)+    KeepFirstPayload++-- | Canonical construction from separate geometry and annotation sources.+-- The coordinate vector remains the only geometry in ingress; payloads never+-- acquire a fabricated 'HasPosition' instance merely to reach the loader.+delaunayFromCoordinates+  :: forall vertex directed undirected face+   . ElementDefaults directed undirected face+  -> V.Vector (Point)+  -> V.Vector vertex+  -> DuplicatePayloadPolicy vertex+  -> Either BuildError (BuildResult 'Unconstrained vertex directed undirected face)+delaunayFromCoordinates defaults coordinates payloads duplicatePolicy+  | coordinateCount /= payloadCount =+      Left (CoordinatePayloadCountMismatch coordinateCount payloadCount)+  | otherwise = do+      V.iforM_ coordinates (\index point -> validatePoint (Just index) point)+      buildDelaunayFromSource+        defaults+        coordinateCount+        (coordinates V.!)+        (payloads V.!)+        duplicatePolicy+ where+  !coordinateCount = V.length coordinates+  !payloadCount = V.length payloads++buildDelaunayFromSource+  :: forall vertex directed undirected face+   . ElementDefaults directed undirected face+  -> Int+  -> (Int -> Point)+  -> (Int -> vertex)+  -> DuplicatePayloadPolicy vertex+  -> Either BuildError (BuildResult 'Unconstrained vertex directed undirected face)+buildDelaunayFromSource defaults inputCount pointAtInput payloadAtInput duplicatePolicy = do+  ensureCapacity inputCount+  runST $ do+    mutable <- newMutableDcel defaults inputCount+    operation <- newOperationState (halfEdgeCapacity mutable)+    table <- newMutablePointIndex inputCount+    mapping <- newPrimArray inputCount+    ingressed <- ingress mutable operation table mapping 0 0 0+    case ingressed of+      Left failure -> pure (Left failure)+      Right (sumX, sumY) -> do+        unique <- pointCount mutable+        inserted <-+          if unique == 0+            then pure (Right 0)+            else do+              let !scale = recip (fromIntegral unique)+              arena <-+                fillRadialArena+                  mutable+                  (sumX * scale)+                  (sumY * scale)+                  (\index -> pure (fromIntegral index))+                  unique+              circleSweepInsert mutable operation arena+        case inserted of+          Left failure -> pure (Left failure)+          Right seedCount -> do+            setCounter operation CounterSpatialSeedPoints seedCount+            frozenOutcome <- freezeTriangulation mutable+            case frozenOutcome of+              Left failure -> pure (Left failure)+              Right frozen -> do+                mapped <- unsafeFreezePrimArray mapping+                stats <- freezeBuildStats operation+                pure+                  ( Right+                      BuildResult+                        { buildTriangulation = frozen+                        , buildInputVertices = mapped+                        , buildStats = stats+                        }+                  )+ where+  -- One indexed ingress loop: read the position once, claim it against the+  -- transient table, write the input mapping, and accumulate the sort centre+  -- over the vertices that are actually new. No list, no decorated vector.+  ingress+    :: forall s+     . MutableDcel s vertex directed undirected face+    -> OperationState s+    -> MutablePointIndex s+    -> MutablePrimArray s Word32+    -> Int+    -> Double+    -> Double+    -> ST s (Either BuildError (Double, Double))+  ingress mutable operation table mapping !index !sumX !sumY+    | index >= inputCount = pure (Right (sumX, sumY))+    | otherwise = do+        addCounter operation CounterInputPoints 1+        let !vertexData = payloadAtInput index+        claimed <- claimPosition mutable table (pointAtInput index) vertexData+        case claimed of+          Left failure -> pure (Left failure)+          Right (vertex, fresh) -> do+            writePrimArray mapping index (fromIntegral vertex)+            if fresh+              then do+                addCounter operation CounterUniquePoints 1+                x <- readPointX mutable vertex+                y <- readPointY mutable vertex+                ingress mutable operation table mapping (index + 1) (sumX + x) (sumY + y)+              else do+                case duplicatePolicy of+                  KeepFirstPayload -> pure ()+                  CombineDuplicatePayload combine -> do+                    resident <- vertexDataAt mutable vertex+                    writeVertexData mutable vertex (combine resident vertexData)+                addCounter operation CounterDuplicatePoints 1+                ingress mutable operation table mapping (index + 1) sumX sumY++-- | Insert or replace a vertex payload. A payload at an existing position is+-- overwritten without changing topology.+--+-- The published mesh is independent of the one passed in. A singleton below+-- ten thousand resident sites copies densely; larger bases publish through+-- copy-on-write pages. A caller inserting a sequence wants one+-- 'Moonlight.Triangulation.Session.withSession' over+-- 'Moonlight.Triangulation.Session.insertVertex' instead — see 'insertAt'.+insert+  :: HasPosition vertex+  => Triangulation mode vertex directed undirected face+  -> vertex+  -> Either BuildError (InsertionResult mode vertex directed undirected face)+insert triangulation vertexData = insertAt triangulation (position vertexData) vertexData++-- | Insert at a stated point. 'insert' is this with the point read out of the+-- payload, which is what a caller holding only a payload wants; a caller that+-- computed the point — a constraint split, a Steiner refinement — wants to say+-- so rather than build a payload and hope the round trip through 'HasPosition'+-- returns what it started with.+--+-- This is one shaped transaction over a single insertion. Replacing a fold of+-- it with one session is sound because the two agree on every mesh and differ+-- only in how many intermediate meshes they publish. A fold publishes @k@+-- meshes and pays a thaw for each, so it runs in Θ(n·k); the session pays one+-- thaw and runs in O(k·log n) expected.+insertAt+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> vertex+  -> Either BuildError (InsertionResult mode vertex directed undirected face)+insertAt triangulation rawPoint vertexData = do+  queryPoint <- validatePoint Nothing rawPoint+  case locatePointWithHint triangulation Nothing queryPoint of+    (OnVertex resident, walked) ->+      Right (replaceResidentPayload triangulation resident walked vertexData)+    (located, walked) -> do+      let transactionShape =+            if numVertices triangulation < 10_000+              then DenseTransaction+              else LocalTransaction+      ((vertex, disposition), frozen, stats) <-+        runTransaction+          id+          transactionShape+          triangulation+          1+          (\mutable operation -> do+             addCounter operation CounterInputPoints 1+             inserted <-+               case located of+                 -- A frozen degenerate-line location points at an arbitrary visible+                 -- segment, while the line extension interpreter requires a terminal+                 -- edge. The frozen section carries no terminal witness, so retain+                 -- the existing mutable line locator for this one non-lawful case.+                 OutsideConvexHull (Just _)+                   | numInnerFaces triangulation == 0 ->+                       insertVertexAtPoint @'ProbeOff mutable operation Nothing (queryPointValue queryPoint) vertexData+                 _ -> do+                   capacityOutcome <- ensurePointCapacity mutable 1+                   case capacityOutcome of+                     Left failure -> pure (Left failure)+                     Right () -> do+                       vertex <- appendVertex mutable (queryPointValue queryPoint) vertexData+                       let thawedLocation =+                             case located of+                               EmptyTriangulation -> MutableEmpty+                               OnEdge (DirectedEdgeId raw) -> MutableOnEdge (fromIntegral raw)+                               InFace (FaceId raw) -> MutableInFace (fromIntegral raw)+                               -- The frozen locator emits no edge only for a+                               -- singleton mesh. Its mutable interpreter ignores+                               -- this sentinel while constructing the second vertex.+                               OutsideConvexHull Nothing -> MutableOutsideHull 0+                               OutsideConvexHull (Just (DirectedEdgeId raw)) -> MutableOutsideHull (fromIntegral raw)+                       ((vertex, Inserted) <$) <$> insertExistingVertexAtLocation @'ProbeOff mutable operation vertex thawedLocation+             case inserted of+               Left failure -> pure (Left failure)+               Right (vertex, disposition) -> do+                 case disposition of+                   Inserted -> addCounter operation CounterUniquePoints 1+                   AlreadyPresent -> do+                     writeVertexData mutable vertex vertexData+                     addCounter operation CounterExistingPoints 1+                     addCounter operation CounterDuplicatePoints 1+                 pure (Right (vertex, disposition))+          )+      pure+        InsertionResult+          { insertionTriangulation = frozen+          , insertionVertex = VertexId (fromIntegral vertex)+          , insertionDisposition = disposition+          , insertionStats = withFrozenLocationStats walked stats+          }++-- | Publish a payload replacement without opening a transaction.+--+-- A position already resident changes exactly one thing: the payload slot the+-- vertex already occupies. No coordinate, no half-edge, no constraint flag and+-- no face record differs, so the five unboxed planes are the ones the argument+-- already holds rather than copies taken out of it — which is what a thaw costs+-- and what this exists to refuse. They are immutable values; nothing reached+-- from here is a mutable buffer, and 'boxedUpdate' materializes a fresh page+-- for the one it rewrites, leaving the argument's own directory intact.+--+-- The location counters are the frozen walk's, not a thawed walk's. They+-- describe the walk that actually ran.+replaceResidentPayload+  :: Triangulation mode vertex directed undirected face+  -> VertexId+  -> LocationStats+  -> vertex+  -> InsertionResult mode vertex directed undirected face+replaceResidentPayload triangulation resident@(VertexId raw) walked vertexData =+  InsertionResult+    { insertionTriangulation =+        triangulation+          { triVertexData =+              boxedUpdate (fromIntegral raw) vertexData (triVertexData triangulation)+          }+    , insertionVertex = resident+    , insertionDisposition = AlreadyPresent+    , insertionStats =+        withFrozenLocationStats+          walked+          emptyBuildStats+            { statInputPoints = 1+            , statExistingPoints = 1+            , statDuplicatePoints = 1+            }+    }++-- | Add the frozen locator's observation to the local topology interpreter's+-- operation-owned counters. Direct frozen-site insertion contributes no mutable+-- walk; the degenerate fallback contributes its real mutable walk rather than+-- having it erased from the published result.+withFrozenLocationStats :: LocationStats -> BuildStats -> BuildStats+withFrozenLocationStats walked stats =+  stats+    { statLocationWalkSteps = locationWalkSteps walked + statLocationWalkSteps stats+    , statLocationMaxWalk = max (locationWalkSteps walked) (statLocationMaxWalk stats)+    , statLocationFallbacks = (if locationUsedFallback walked then 1 else 0) + statLocationFallbacks stats+    }++-- | Apply a batch in one page transaction. Duplicate positions are processed+-- in input order, so their last payload wins exactly as repeated 'insert'+-- calls would, while topology is inserted only once per new position.+insertMany+  :: forall mode vertex directed undirected face+   . HasPosition vertex+  => Triangulation mode vertex directed undirected face+  -> V.Vector vertex+  -> Either BuildError (BuildResult mode vertex directed undirected face)+insertMany triangulation input = do+  validateVertices input+  ensureCapacity (numVertices triangulation + V.length input)+  runST $ do+    mutable <-+      thawTriangulationDense+        (numVertices triangulation + V.length input)+        triangulation+    operation <- newOperationState (halfEdgeCapacity mutable)+    table <- newMutablePointIndex (numVertices triangulation + V.length input)+    seeded <- seedPointTable mutable table+    case seeded of+      Left failure -> pure (Left failure)+      Right () -> do+        mapping <- newPrimArray (V.length input)+        freshBuffer <- MUV.new (V.length input)+        filled <- fill mutable operation table mapping freshBuffer 0 0 0 0+        case filled of+          Left failure -> pure (Left failure)+          Right (sumX, sumY, freshCount) -> do+            inserted <-+              if freshCount == 0+                then pure (Right 0)+                else do+                  let !scale = recip (fromIntegral freshCount)+                  arena <-+                    fillRadialArena+                      mutable+                      (sumX * scale)+                      (sumY * scale)+                      (MUV.unsafeRead freshBuffer)+                      freshCount+                  circleSweepInsert mutable operation arena+            case inserted of+              Left failure -> pure (Left failure)+              Right seedCount -> do+                setCounter operation CounterSpatialSeedPoints seedCount+                frozenOutcome <- freezeTriangulation mutable+                case frozenOutcome of+                  Left failure -> pure (Left failure)+                  Right frozen -> do+                    mapped <- unsafeFreezePrimArray mapping+                    stats <- freezeBuildStats operation+                    pure+                      ( Right+                          BuildResult+                            { buildTriangulation = frozen+                            , buildInputVertices = mapped+                            , buildStats = stats+                            }+                      )+ where+  fill+    :: forall s+     . MutableDcel s vertex directed undirected face+    -> OperationState s+    -> MutablePointIndex s+    -> MutablePrimArray s Word32+    -> MUV.MVector s Word32+    -> Int+    -> Double+    -> Double+    -> Int+    -> ST s (Either BuildError (Double, Double, Int))+  fill mutable operation table mapping freshBuffer !index !sumX !sumY !freshCount+    | index >= V.length input = pure (Right (sumX, sumY, freshCount))+    | otherwise = do+        addCounter operation CounterInputPoints 1+        let !vertexData = input V.! index+        claimed <- claimPosition mutable table (position vertexData) vertexData+        case claimed of+          Left failure -> pure (Left failure)+          Right (vertex, fresh) -> do+            writePrimArray mapping index (fromIntegral vertex)+            if fresh+              then do+                addCounter operation CounterUniquePoints 1+                MUV.unsafeWrite freshBuffer freshCount (fromIntegral vertex)+                x <- readPointX mutable vertex+                y <- readPointY mutable vertex+                fill+                  mutable+                  operation+                  table+                  mapping+                  freshBuffer+                  (index + 1)+                  (sumX + x)+                  (sumY + y)+                  (freshCount + 1)+              else do+                writeVertexData mutable vertex vertexData+                addCounter operation CounterExistingPoints 1+                addCounter operation CounterDuplicatePoints 1+                fill mutable operation table mapping freshBuffer (index + 1) sumX sumY freshCount++-- | One packed radial record per swept vertex — the derived sort fields and+-- the vertex handle, nothing else — filled straight from the coordinate+-- arenas and consumed in place by the sweep. The squared distance is stated+-- against the ingress-accumulated centre, in the widened comparison format.+fillRadialArena+  :: MutableDcel s vertex directed undirected face+  -> Double+  -> Double+  -> (Int -> ST s Word32)+  -> Int+  -> ST s (MUV.MVector s (Double, Double, Double, Word32))+fillRadialArena mutable centerX centerY lookupId count = do+  arena <- MUV.new count+  forM_ [0 .. count - 1] $ \index -> do+    raw <- lookupId index+    x <- readPointX mutable (fromIntegral raw)+    y <- readPointY mutable (fromIntegral raw)+    let !wideX = x+        !wideY = y+        !deltaX = centerX - wideX+        !deltaY = centerY - wideY+    MUV.unsafeWrite arena index (deltaX * deltaX + deltaY * deltaY, wideX, wideY, raw)+  pure arena++-- | Claim a position for the vertex the arena would append next, or answer the+-- vertex already holding it. The claim is written before the append, so the two+-- must stay adjacent: nothing may consume a vertex slot in between.+claimPosition+  :: MutableDcel s vertex directed undirected face+  -> MutablePointIndex s+  -> Point+  -> vertex+  -> ST s (Either BuildError (Int, Bool))+claimPosition mutable table rawPoint vertexData =+  case rawPoint of+    Point x y -> do+      let !canonicalX = canonicalCoordinate x+          !canonicalY = canonicalCoordinate y+      candidate <- pointCount mutable+      owner <-+        resolveMutablePoint+          table+          (readPointX mutable)+          (readPointY mutable)+          canonicalX+          canonicalY+          candidate+      case owner of+        Left failure -> pure (Left failure)+        Right (Just existing) -> pure (Right (existing, False))+        Right Nothing -> do+          vertex <- appendVertexCoordinates mutable canonicalX canonicalY vertexData+          pure (Right (vertex, True))+-- | Enter the positions a batch inherits from the triangulation it extends, so+-- that an input repeating one of them maps to the vertex already there.+seedPointTable+  :: MutableDcel s vertex directed undirected face+  -> MutablePointIndex s+  -> ST s (Either BuildError ())+seedPointTable mutable table = do+  existing <- pointCount mutable+  seedMutablePointIndex+    table+    existing+    (readPointX mutable)+    (readPointY mutable)++validateVertices :: HasPosition vertex => V.Vector vertex -> Either BuildError ()+validateVertices vertices =+  V.iforM_ vertices (\index vertexData -> validatePoint (Just index) (position vertexData))
+ src-build/Moonlight/Triangulation/Cdt.hs view
@@ -0,0 +1,120 @@+-- | The constraint layer: the partial map from sites and segments, defined+-- exactly on realizable segment sets and naming its witness where it is not.+module Moonlight.Triangulation.Cdt+  ( ConstrainedDelaunayTriangulation+  , CdtError (..)+  , CorridorObstruction (..)+  , ConstraintResult (..)+  , ConstraintOutcome (..)+  , ConstraintBatchStats (..)+  , ConstraintBatchResult (..)+  , ConstrainedExtensionResult (..)+  , ConstrainedSeamSource (..)+  , ConstrainedSeamFaceEvidence+  , constrainedSeamSourceFace+  , constrainedSeamTargetFace+  , constrainedSeamFaceFirstPoint+  , constrainedSeamFaceSecondPoint+  , constrainedSeamFaceThirdPoint+  , ConstrainedSeamConstraintEvidence+  , constrainedSeamConstraintSegment+  , constrainedSeamConstraintRecovery+  , ConstrainedSeamResult+  , constrainedSeamResultTriangulation+  , constrainedSeamLeftFaceEvidence+  , constrainedSeamRightFaceEvidence+  , constrainedSeamNewFaces+  , constrainedSeamLeftConstraintEvidence+  , constrainedSeamRightConstraintEvidence+  , constrainedSeamConstraintStats+  , constrainedSeamBuildStats+  , ConstraintSplitBatchResult (..)+  , CdtBuildResult (..)+  , constrainedDelaunay+  , constrainedDelaunayMaximal+  , fromDelaunay+  , constraintEdges+  , CanonicalSegment+  , segmentStart+  , segmentEnd+  , ConstraintConflict+  , conflictFirstSegment+  , conflictSecondSegment+  , ConstrainedUnionError (..)+  , constraintSegments+  , unionConstrainedWith+  , unionConstrained+  , joinSeparatedConstrainedWith+  , extendConstrainedWith+  , constraintStorageBytes+  , existsConstraint+  , canAddConstraint+  , intersectsConstraint+  , getConflictingEdgesBetweenPoints+  , getConflictingEdgesBetweenVertices+  , recoverConstraints+  , addConstraintEdge+  , addConstraintEdges+  , addConstraintAndSplit+  , addConstraintsAndSplit+  , removeConstraintEdge+  , outerRegionFaces+  , boundedRegionFaces+  ) where++import Moonlight.Triangulation.Internal.Cdt.Batch (recoverConstraints)+import Moonlight.Triangulation.Internal.Cdt.Build+  ( constrainedDelaunay+  , constrainedDelaunayMaximal+  , fromDelaunay+  )+import Moonlight.Triangulation.Internal.Cdt.Query+  ( canAddConstraint+  , constraintEdges+  , constraintStorageBytes+  , existsConstraint+  , getConflictingEdgesBetweenPoints+  , getConflictingEdgesBetweenVertices+  , intersectsConstraint+  )+import Moonlight.Triangulation.Internal.Cdt.Region+  ( boundedRegionFaces+  , outerRegionFaces+  )+import Moonlight.Triangulation.Internal.Cdt.Segment+  ( addConstraintEdge+  , addConstraintEdges+  , removeConstraintEdge+  )+import Moonlight.Triangulation.Internal.Cdt.Split+  ( addConstraintAndSplit+  , addConstraintsAndSplit+  )+import Moonlight.Triangulation.Internal.Cdt.Types+  ( CanonicalSegment (..)+  , CdtBuildResult (..)+  , CdtError (..)+  , ConstrainedUnionError (..)+  , ConstraintBatchResult (..)+  , ConstraintBatchStats (..)+  , ConstrainedExtensionResult (..)+  , ConstrainedSeamConstraintEvidence (..)+  , ConstrainedSeamFaceEvidence (..)+  , ConstrainedSeamResult (..)+  , ConstrainedSeamSource (..)+  , ConstraintConflict (..)+  , ConstraintOutcome (..)+  , ConstraintResult (..)+  , ConstraintSplitBatchResult (..)+  , CorridorObstruction (..)+  )+import Moonlight.Triangulation.Internal.Cdt.Union+  ( constraintSegments+  , extendConstrainedWith+  , joinSeparatedConstrainedWith+  , unionConstrained+  , unionConstrainedWith+  )+import Moonlight.Triangulation.Internal.Representation+  ( ConstrainedDelaunayTriangulation+  )
+ src-build/Moonlight/Triangulation/Insertion.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Moonlight.Triangulation.Insertion+  ( insertExistingVertex+  , insertExistingVertexWithHint+  , insertPointCombining+  , insertVertexAtPoint+  , insertExistingVertexAtLocation+  ) where++import Control.Monad.ST (ST)+import Moonlight.Triangulation.Handles.HandleDefs (VertexId (..))+import Moonlight.Triangulation.Internal.DcelOperations+import Moonlight.Triangulation.Internal.Location+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  )+import Moonlight.Triangulation.Internal.Probe (KnownProbe, Probe (..))+import Moonlight.Triangulation.Math+import Moonlight.Triangulation.Types++-- | The shared exact-site insertion interpreter. Geometry decides whether a+-- site is new; callers choose only the annotation law for an occupied site.+-- Keeping the validation, location, placement, and counters here prevents+-- sessions and constrained extension from drifting into two insertion+-- semantics merely because they own different enclosing transactions.+insertPointCombining+  :: (vertex -> vertex -> vertex)+  -> Maybe Int+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Point+  -> vertex+  -> ST s (Either BuildError (Int, InsertionDisposition))+insertPointCombining combine seed mutable operation point payload =+  case validatePoint Nothing point of+    Left failure -> pure (Left failure)+    Right _ -> do+      addCounter operation CounterInputPoints 1+      outcome <- insertVertexAtPoint @'ProbeOff mutable operation seed point payload+      case outcome of+        Left failure -> pure (Left failure)+        Right resolved@(vertex, disposition) -> do+          case disposition of+            AlreadyPresent -> do+              resident <- vertexDataAt mutable vertex+              writeVertexData mutable vertex (combine resident payload)+              addCounter operation CounterExistingPoints 1+              addCounter operation CounterDuplicatePoints 1+            Inserted -> addCounter operation CounterUniquePoints 1+          pure (Right resolved)+{-# INLINE insertPointCombining #-}++insertExistingVertex+  :: forall p s vertex directed undirected face+   . KnownProbe p+  => MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> ST s (Either BuildError ())+insertExistingVertex mutable operation = insertExistingVertexWithHint @p mutable operation Nothing++-- | Insert a materialized vertex while beginning point location from a face+-- already known to be geometrically adjacent to the request. The hint changes+-- only the amount of walking; the located site remains authoritative.+insertExistingVertexWithHint+  :: forall p s vertex directed undirected face+   . KnownProbe p+  => MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Maybe Int+  -> Int+  -> ST s (Either BuildError ())+insertExistingVertexWithHint mutable operation hint vertex = do+  query <- pointAt mutable vertex+  located <- locateMutable mutable operation hint query+  case located of+    Left obstruction -> pure (Left obstruction)+    Right site -> insertExistingVertexAtLocation @p mutable operation vertex site++-- | Locate before materializing a point, so duplicate detection remains a+-- topological fact rather than a resident coordinate index.+insertVertexAtPoint+  :: forall p s vertex directed undirected face+   . KnownProbe p+  => MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Maybe Int+  -> Point+  -> vertex+  -> ST s (Either BuildError (Int, InsertionDisposition))+insertVertexAtPoint mutable operation hint point vertexData = do+  located <- locateMutable mutable operation hint point+  case located of+    Left obstruction -> pure (Left obstruction)+    Right (MutableOnVertex existing) -> pure (Right (existing, AlreadyPresent))+    Right site -> do+      capacity <- ensurePointCapacity mutable 1+      case capacity of+        Left obstruction -> pure (Left obstruction)+        Right () -> do+          vertex <- appendVertex mutable point vertexData+          inserted <- insertExistingVertexAtLocation @p mutable operation vertex site+          pure ((vertex, Inserted) <$ inserted)++-- | Interpret a point-location result without locating the same point again.+-- Callers may hold this witness only while no topology mutation intervenes.+--+-- The site decides which counts are consulted, and the vertex's own point is+-- read only by the two strata that compare against it — the degenerate line and+-- the failure report. The area strata already stand on a located site and would+-- otherwise rebuild a point the locate stage was handed.+insertExistingVertexAtLocation+  :: forall p s vertex directed undirected face+   . KnownProbe p+  => MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> MutableLocation+  -> ST s (Either BuildError ())+insertExistingVertexAtLocation mutable operation vertex located =+  case located of+    MutableOnVertex existing ->+      pure+        ( Left+            ( FreshInsertionMatchedExistingVertex+                (VertexId (fromIntegral vertex))+                (VertexId (fromIntegral existing))+            )+        )+    MutableEmpty -> do+      connected <- connectedCount mutable+      if connected == 0+        then setupFirstVertex mutable vertex >> pure (Right ())+        else locationFailed+    MutableOnEdge edge -> do+      faces <- faceCount mutable+      if faces <= 1+        then splitLineEdge mutable operation edge vertex+        else insertOnEdge @p mutable operation edge vertex+    MutableInFace face -> do+      faces <- faceCount mutable+      if faces <= 1+        then locationFailed+        else insertIntoFace @p mutable operation face vertex+    MutableOutsideHull edge -> do+      connected <- connectedCount mutable+      if connected == 1+        then setupSecondVertex mutable vertex+        else do+          faces <- faceCount mutable+          if faces <= 1+            then extendDegenerateLine edge+            else insertOutsideHull @p mutable operation edge vertex+ where+  extendDegenerateLine edge = do+    from <- edgeOriginPoint mutable edge+    to <- edgeOriginPoint mutable (edge `xorInt` 1)+    query <- pointAt mutable vertex+    if orient2d from to query == EQ+      then do+        endpoint <- readOrigin mutable edge+        extendLine mutable operation endpoint vertex+      else lineToArea @p mutable operation vertex++  locationFailed = do+    query <- pointAt mutable vertex+    pure (Left (PointLocationFailed query))++xorInt :: Int -> Int -> Int+xorInt value 1 = if even value then value + 1 else value - 1+xorInt value _ = value+{-# INLINE xorInt #-}
+ src-build/Moonlight/Triangulation/Internal/Capacity.hs view
@@ -0,0 +1,18 @@+-- | Admissibility of a requested vertex count against the packed index limit.+module Moonlight.Triangulation.Internal.Capacity+  ( ensureCapacity+  ) where++import Moonlight.Triangulation.Internal.PackedIndex (indexLimit)+import Moonlight.Triangulation.Internal.Types (BuildError (..))++ensureCapacity :: Int -> Either BuildError ()+ensureCapacity count+  | count < 0 || count > maximumVertexCapacity = Left (CapacityExceeded count)+  | otherwise = Right ()++-- Mutable allocation reserves @8n + 16@ directed-edge slots. Every topology+-- handle is packed below 'indexLimit', so admissibility is stated against that+-- actual representation bound rather than the machine 'Int' bound.+maximumVertexCapacity :: Int+maximumVertexCapacity = (indexLimit - 16) `quot` 8
+ src-build/Moonlight/Triangulation/Internal/Cdt/Admission.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Immutable admission of one requested segment against the sparse+-- constrained-edge section, decided without thawing topology.+module Moonlight.Triangulation.Internal.Cdt.Admission+  ( ConstraintAdmission (..)+  , constraintAdmission+  , segmentBoxesAreDisjoint+  ) where++import qualified Data.IntSet as IntSet+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Math++-- | Immutable admission descends through the sparse constrained-edge section,+-- not through every ordinary edge in the requested corridor. Constraint+-- cardinality is the lawful index here: rejection depends only on a proper+-- crossing with an existing protected segment, while shared endpoints,+-- duplicate segments, and collinear overlap remain recoverable by the mutable+-- corridor algebra. Accepted singleton requests descend once more inside their+-- sealed transaction; the overwhelmingly common rejected request stops here+-- without thawing topology.+data ConstraintAdmission+  = ConstraintBlocked !UndirectedEdgeId+  | ConstraintAdmitted++constraintAdmission+  :: Triangulation 'Constrained vertex directed undirected face+  -> VertexId+  -> VertexId+  -> ConstraintAdmission+constraintAdmission triangulation from to =+  IntSet.foldr firstBlocking ConstraintAdmitted (triConstraintEdges triangulation)+ where+  !requestFrom = Dcel.vertexPoint triangulation from+  !requestTo = Dcel.vertexPoint triangulation to++  firstBlocking raw later =+    let !edge = UndirectedEdgeId (fromIntegral raw)+        (!edgeFromId, !edgeToId) = Dcel.undirectedEndpoints triangulation edge+     in if+          from == edgeFromId+            || from == edgeToId+            || to == edgeFromId+            || to == edgeToId+          then later+          else+            let !edgeFrom = Dcel.vertexPoint triangulation edgeFromId+                !edgeTo = Dcel.vertexPoint triangulation edgeToId+             in if segmentBoxesAreDisjoint requestFrom requestTo edgeFrom edgeTo+                  then later+                  else+                    if segmentsProperlyCross requestFrom requestTo edgeFrom edgeTo+                      then ConstraintBlocked edge+                      else later++segmentBoxesAreDisjoint+  :: Point+  -> Point+  -> Point+  -> Point+  -> Bool+segmentBoxesAreDisjoint (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy) =+  max ax bx < min cx dx+    || max cx dx < min ax bx+    || max ay by < min cy dy+    || max cy dy < min ay by+{-# INLINE segmentBoxesAreDisjoint #-}
+ src-build/Moonlight/Triangulation/Internal/Cdt/Batch.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | The batch interpreter: many constraint requests in order inside one sealed+-- dense transaction, with rejection carried as a value.+module Moonlight.Triangulation.Internal.Cdt.Batch+  ( recoverConstraints+  , recoverConstraintBatch+  , initialConstraintBatchStats+  , interpretConstraintRequest+  , interpretConstraintRequests+  ) where++import Control.Monad.ST (ST)+import Data.Either (isRight)+import qualified Data.Vector as V+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Internal.Cdt.Combinators (foldWhileM)+import Moonlight.Triangulation.Internal.Cdt.Query (validateEndpoints)+import Moonlight.Triangulation.Internal.Cdt.Recovery (applyMutableConstraint)+import Moonlight.Triangulation.Internal.Cdt.Types+import Moonlight.Triangulation.Internal.Growable+  ( GrowableWord32+  , newGrowableWord32+  )+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( OperationState )+import Moonlight.Triangulation.Internal.Paged (TransactionShape (DenseTransaction))+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Transaction (runTransaction)+import Moonlight.Triangulation.Internal.Types (ConstraintMode (..))++-- | Interpret constraint requests in order inside one sealed mutable DCEL+-- transaction. Rejections are values because an earlier accepted request can+-- lawfully obstruct a later request; structural recovery failures remain typed+-- errors and prevent a partially rewritten mesh from escaping. The public batch+-- interpreter amortizes dense materialization; known singleton repair sites+-- reuse this algebra under the sparse persistent-page interpretation.+recoverConstraints+  :: Triangulation 'Constrained vertex directed undirected face+  -> V.Vector (VertexId, VertexId)+  -> Either (CdtError) (ConstraintBatchResult vertex directed undirected face)+recoverConstraints triangulation requests+  | V.null requests =+      Right+        ConstraintBatchResult+          { constraintBatchTriangulation = triangulation+          , constraintBatchOutcomes = V.empty+          , constraintBatchStats = initialConstraintBatchStats 0+          }+  | otherwise =+      recoverConstraintBatch+        triangulation+        requests++recoverConstraintBatch+  :: Triangulation 'Constrained vertex directed undirected face+  -> V.Vector (VertexId, VertexId)+  -> Either (CdtError) (ConstraintBatchResult vertex directed undirected face)+recoverConstraintBatch triangulation requests = do+  V.mapM_ (uncurry (validateEndpoints triangulation)) requests+  (completed, frozen, _) <-+    runTransaction+      CdtBuildError+      DenseTransaction+      triangulation+      0+      (interpretConstraintRequests requests)+  pure (finalizeConstraintBatch frozen completed)+{-# INLINE recoverConstraintBatch #-}++-- | Interpret a complete constraint request section against an already-open+-- transaction. Both ordinary recovery and asymmetric constrained extension+-- use this one interpreter; callers decide only which request section is+-- resident before it begins.+interpretConstraintRequests+  :: V.Vector (VertexId, VertexId)+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> ST s (Either (CdtError) ConstraintBatchAccumulator)+interpretConstraintRequests requests mutable operation = do+  programWords <- newGrowableWord32 256+  let initialAccumulator =+        ConstraintBatchAccumulator+          { accumulatedConstraintOutcomes = []+          , accumulatedConstraintStats =+              initialConstraintBatchStats (V.length requests)+          }+  foldWhileM+    isRight+    (interpretConstraintRequest programWords mutable operation)+    (Right initialAccumulator)+    requests+{-# INLINE interpretConstraintRequests #-}++-- | Materialize the ordinary recovery receipt only after the enclosing+-- transaction has frozen. The mutable accumulator cannot escape as a partial+-- constrained mesh.+finalizeConstraintBatch+  :: Triangulation 'Constrained vertex directed undirected face+  -> ConstraintBatchAccumulator+  -> ConstraintBatchResult vertex directed undirected face+finalizeConstraintBatch frozen completed =+  ConstraintBatchResult+    { constraintBatchTriangulation = frozen+    , constraintBatchOutcomes = V.fromList (reverse (accumulatedConstraintOutcomes completed))+    , constraintBatchStats = accumulatedConstraintStats completed+    }+{-# INLINE finalizeConstraintBatch #-}++initialConstraintBatchStats :: Int -> ConstraintBatchStats+initialConstraintBatchStats requestCount =+  ConstraintBatchStats+    { constraintBatchRequests = requestCount+    , constraintBatchAccepted = 0+    , constraintBatchRejected = 0+    , constraintBatchCorridors = 0+    , constraintBatchReusedFaces = 0+    , constraintBatchCrossedEdges = 0+    }++interpretConstraintRequest+  :: GrowableWord32 s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Either (CdtError) ConstraintBatchAccumulator+  -> (VertexId, VertexId)+  -> ST s (Either (CdtError) ConstraintBatchAccumulator)+interpretConstraintRequest _ _ _ rejected@(Left _) _ = pure rejected+interpretConstraintRequest programWords mutable operation (Right accumulator) (from, to) = do+  applied <- applyMutableConstraint programWords mutable operation from to+  pure $ case applied of+    Left obstruction -> Left obstruction+    Right (MutableConstraintRejected blocking) ->+      let previousStats = accumulatedConstraintStats accumulator+       in Right+            accumulator+              { accumulatedConstraintOutcomes =+                  ConstraintRejected blocking : accumulatedConstraintOutcomes accumulator+              , accumulatedConstraintStats =+                  previousStats+                    { constraintBatchRejected = constraintBatchRejected previousStats + 1+                    }+              }+    Right (MutableConstraintAccepted request) ->+      let previousStats = accumulatedConstraintStats accumulator+       in Right+            accumulator+              { accumulatedConstraintOutcomes =+                  ConstraintAccepted+                    (V.fromList (reverse (accumulatedRequestPath request)))+                    (accumulatedRequestAddedEdges request)+                    : accumulatedConstraintOutcomes accumulator+              , accumulatedConstraintStats =+                  previousStats+                    { constraintBatchAccepted = constraintBatchAccepted previousStats + 1+                    , constraintBatchCorridors =+                        constraintBatchCorridors previousStats + accumulatedRequestCorridors request+                    , constraintBatchReusedFaces =+                        constraintBatchReusedFaces previousStats + accumulatedRequestReusedFaces request+                    , constraintBatchCrossedEdges =+                        constraintBatchCrossedEdges previousStats + accumulatedRequestCrossedEdges request+                    }+              }
+ src-build/Moonlight/Triangulation/Internal/Cdt/Build.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Constrained bulk loading: an unconstrained load promoted to the+-- constrained layer, then driven through the batch corridor interpreter.+module Moonlight.Triangulation.Internal.Cdt.Build+  ( fromDelaunay+  , constrainedDelaunay+  , constrainedDelaunayMaximal+  ) where++import qualified Data.Vector as V+import Data.Primitive.PrimArray (PrimArray, indexPrimArray, sizeofPrimArray)+import Data.Word (Word32)+import Moonlight.Triangulation.BulkLoad (delaunay)+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Internal.Cdt.Batch (recoverConstraints)+import Moonlight.Triangulation.Internal.Cdt.Combinators (mapLeft)+import Moonlight.Triangulation.Internal.Cdt.Types+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types++-- | Promote an unconstrained mesh into the constrained layer with no marked edges.+fromDelaunay+  :: Triangulation 'Unconstrained vertex directed undirected face+  -> Triangulation 'Constrained vertex directed undirected face+fromDelaunay = promoteConstrained++-- | Build a constrained triangulation, refusing the complete request when any+-- input constraint cannot be admitted.+constrainedDelaunay+  :: HasPosition vertex+  => ElementDefaults directed undirected face+  -> V.Vector vertex+  -> V.Vector (Int, Int)+  -> Either (CdtError) (BuildResult 'Constrained vertex directed undirected face)+constrainedDelaunay defaults inputVertices constraints = do+  result <- constrainedDelaunayMaximal defaults inputVertices constraints+  if V.null (cdtRejectedConstraints result)+    then+      Right+        BuildResult+          { buildTriangulation = cdtBuildTriangulation result+          , buildInputVertices = cdtBuildInputVertices result+          , buildStats = cdtBuildStats result+          }+    else Left (ConstraintInputConflicts (cdtRejectedConstraints result))++-- | Stable constrained bulk loading. Duplicate input vertices are rerouted to+-- the first surviving handle. Every proper constraint conflict is returned in+-- input order; accepted constraints remain in the result.+constrainedDelaunayMaximal+  :: HasPosition vertex+  => ElementDefaults directed undirected face+  -> V.Vector vertex+  -> V.Vector (Int, Int)+  -> Either (CdtError) (CdtBuildResult vertex directed undirected face)+constrainedDelaunayMaximal defaults inputVertices constraints = do+  built <- mapLeft CdtBuildError (delaunay defaults inputVertices)+  let !mapping = buildInputVertices built+      !initial = fromDelaunay (buildTriangulation built)+  requests <- V.mapM (mapConstraintRequest mapping) constraints+  batch <- recoverConstraints initial requests+  let rejected =+        V.mapMaybe+          (\(request, outcome) ->+            case outcome of+              ConstraintAccepted _ _ -> Nothing+              ConstraintRejected _ -> Just request+          )+          (V.zip constraints (constraintBatchOutcomes batch))+  pure+    CdtBuildResult+      { cdtBuildTriangulation = constraintBatchTriangulation batch+      , cdtBuildInputVertices = mapping+      , cdtBuildStats = buildStats built+      , cdtRejectedConstraints = rejected+      }+ where+  mapConstraintRequest+    :: PrimArray Word32+    -> (Int, Int)+    -> Either (CdtError) (VertexId, VertexId)+  mapConstraintRequest mapping (fromIndex, toIndex) =+    (,)+      <$> mapConstraintEndpoint mapping fromIndex+      <*> mapConstraintEndpoint mapping toIndex++  mapConstraintEndpoint+    :: PrimArray Word32+    -> Int+    -> Either (CdtError) VertexId+  mapConstraintEndpoint mapping endpointIndex+    | endpointIndex >= 0 && endpointIndex < sizeofPrimArray mapping =+        Right (VertexId (indexPrimArray mapping endpointIndex))+    | otherwise =+        Left (ConstraintEndpointIndexOutOfRange endpointIndex (sizeofPrimArray mapping))
+ src-build/Moonlight/Triangulation/Internal/Cdt/Combinators.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Bounded monadic folding, refusable transaction sequencing, and the handle+-- and error coercions the constrained layer shares.+module Moonlight.Triangulation.Internal.Cdt.Combinators+  ( foldWhileM+  , bindMutable+  , asConstraintStep+  , mapLeft+  , vertexInt+  , directedInt+  ) where++import Moonlight.Triangulation.Handles.HandleDefs+  ( DirectedEdgeId (..)+  , VertexId (..)+  )+import Moonlight.Triangulation.Internal.Cdt.Types (CdtError (..))+import Moonlight.Triangulation.Internal.Types (BuildError)++-- | Monadic left fold whose continuation is supplied by a lazy right fold.+-- The state predicate decides descent before the next effect is constructed,+-- so graph walks stop at their authoritative local answer without mutable loop+-- control or traversing the unused safety suffix.+foldWhileM+  :: (Foldable container, Monad monad)+  => (state -> Bool)+  -> (state -> item -> monad state)+  -> state+  -> container item+  -> monad state+foldWhileM shouldContinue step initial items =+  foldr+    (\item continuation state ->+      if shouldContinue state+        then step state item >>= continuation+        else pure state+    )+    pure+    items+    initial+{-# INLINE foldWhileM #-}++-- | Sequence two refusable transaction steps. Refusal short-circuits, so a+-- transaction that abandons never reaches its publication; writing the bind+-- once is what keeps the constraint verbs from nesting their case analysis+-- five deep.+bindMutable :: Monad monad => monad (Either failure a) -> (a -> monad (Either failure b)) -> monad (Either failure b)+bindMutable step continue = do+  outcome <- step+  case outcome of+    Left failure -> pure (Left failure)+    Right value -> continue value+{-# INLINE bindMutable #-}++-- | Relabel a step whose refusal is a build failure, so it composes with the+-- constraint layer's own.+asConstraintStep :: Functor f => f (Either BuildError a) -> f (Either (CdtError) a)+asConstraintStep = fmap (mapLeft CdtBuildError)+{-# INLINE asConstraintStep #-}++mapLeft :: (left -> right) -> Either left value -> Either right value+mapLeft convert = either (Left . convert) Right++vertexInt :: VertexId -> Int+vertexInt (VertexId value) = fromIntegral value++directedInt :: DirectedEdgeId -> Int+directedInt (DirectedEdgeId value) = fromIntegral value
+ src-build/Moonlight/Triangulation/Internal/Cdt/Corridor.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | The corridor walk: one traversal of the requested segment that yields+-- either the first oriented blocking witness or a complete recovery program.+module Moonlight.Triangulation.Internal.Cdt.Corridor+  ( constraintWorkspaceFor+  , scanMutableConstraint+  , advanceMutablePlan+  , continueMutablePlan+  , beginMutableRecover+  , finishMutableRecover+  , settleMutableProgram+  , mutablePlanIsActive+  , writeConstraintProgram+  , readConstraintProgram+  , existingProgramTag+  , recoverProgramTag+  ) where++import Control.Monad.ST (ST)+import Data.Bits (xor)+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.IntersectionIterator (Intersection (..))+import Moonlight.Triangulation.Internal.Cdt.Combinators+  ( directedInt+  , foldWhileM+  , vertexInt+  )+import Moonlight.Triangulation.Internal.Cdt.Corridor.Trace (nextMutableIntersection)+import Moonlight.Triangulation.Internal.Cdt.Types+import Moonlight.Triangulation.Internal.Growable+  ( GrowableWord32+  , clearGrowable+  , readGrowable+  , writeGrowable+  )+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.Types (Point)++-- | The walk budget bounds a corridor through the mesh as it stands, so it is+-- taken per request rather than per transaction: a verb that inserts before it+-- recovers has changed the mesh the budget describes. Recovery itself adds+-- neither vertex nor edge, so a batch reads the same number every time.+constraintWorkspaceFor+  :: GrowableWord32 s+  -> MutableDcel s vertex directed undirected face+  -> ST s (ConstraintWorkspace s)+constraintWorkspaceFor constraintProgramWords mutable = do+  halfEdges <- directedEdgeCount mutable+  vertices <- pointCount mutable+  pure+    ConstraintWorkspace+      { constraintProgramWords+      , constraintWalkBudget = 2 * halfEdges + vertices + 8+      }++writeConstraintProgram :: ConstraintWorkspace s -> Int -> Int -> ST s ()+writeConstraintProgram ConstraintWorkspace{constraintProgramWords} index value =+  writeGrowable constraintProgramWords index (fromIntegral value)+{-# INLINE writeConstraintProgram #-}++readConstraintProgram :: ConstraintWorkspace s -> Int -> ST s Int+readConstraintProgram ConstraintWorkspace{constraintProgramWords} index =+  fromIntegral <$> readGrowable constraintProgramWords index+{-# INLINE readConstraintProgram #-}++-- | Walk one corridor once, gluing the local observations into either the+-- first oriented blocking witness or a complete recovery program. The former+-- admission/planning pair traversed every admitted corridor twice and could+-- disagree if either walk evolved independently; this scanner is their single+-- semantic owner.+scanMutableConstraint+  :: ConstraintWorkspace s+  -> MutableDcel s vertex directed undirected face+  -> VertexId+  -> VertexId+  -> ST s (Either (CdtError) MutableConstraintScan)+scanMutableConstraint workspace@ConstraintWorkspace{constraintProgramWords, constraintWalkBudget} mutable from to = do+  clearGrowable constraintProgramWords+  lineFrom <- pointAt mutable (vertexInt from)+  lineTo <- pointAt mutable (vertexInt to)+  initialCursor <- beginMutableRecover workspace 0 from 0 False+  walked <-+    foldWhileM+      mutablePlanIsActive+      (advanceMutablePlan workspace mutable lineFrom lineTo to)+      (MutablePlanActive (VertexIntersection from) initialCursor)+      [1 .. constraintWalkBudget]+  pure $ case walked of+    MutablePlanComplete plan -> Right (MutableConstraintScanAdmitted plan)+    MutablePlanBlocked blocking -> Right (MutableConstraintScanBlocked blocking)+    MutablePlanFailed obstruction -> Left (ConstraintCorridorObstructed obstruction)+    MutablePlanActive _ _ ->+      Left+        ( ConstraintCorridorObstructed+            (CorridorWalkDidNotTerminate constraintWalkBudget)+        )++advanceMutablePlan+  :: ConstraintWorkspace s+  -> MutableDcel s vertex directed undirected face+  -> Point+  -> Point+  -> VertexId+  -> MutablePlanWalk+  -> Int+  -> ST s MutablePlanWalk+advanceMutablePlan _ _ _ _ _ complete@(MutablePlanComplete _) _ = pure complete+advanceMutablePlan _ _ _ _ _ blocked@(MutablePlanBlocked _) _ = pure blocked+advanceMutablePlan _ _ _ _ _ failed@(MutablePlanFailed _) _ = pure failed+advanceMutablePlan workspace mutable lineFrom lineTo target (MutablePlanActive event cursor) _ =+  case event of+    EdgeIntersection directed -> do+      constrained <- readConstraint mutable (directedInt directed)+      if constrained+        then pure (MutablePlanBlocked directed)+        else do+          writeConstraintProgram workspace (mutableCursorWriteAt cursor) (directedInt directed)+          continueMutablePlan+            workspace+            mutable+            lineFrom+            lineTo+            target+            event+            cursor+              { mutableCursorWriteAt = mutableCursorWriteAt cursor + 1+              , mutableCursorConflictCount = mutableCursorConflictCount cursor + 1+              , mutableCursorAfterOverlap = False+              }+    VertexIntersection vertex+      | mutableCursorAfterOverlap cursor ->+          continueMutablePlan+            workspace+            mutable+            lineFrom+            lineTo+            target+            event+            cursor{mutableCursorAfterOverlap = False}+      | vertex == mutableCursorAt cursor ->+          continueMutablePlan+            workspace+            mutable+            lineFrom+            lineTo+            target+            event+            cursor{mutableCursorAfterOverlap = False}+      | otherwise -> do+          finished <- finishMutableRecover workspace vertex cursor+          nextCursor <-+            beginMutableRecover+              workspace+              (mutableCursorWriteAt finished)+              vertex+              (mutableCursorPieceCount finished)+              False+          continueMutablePlan workspace mutable lineFrom lineTo target event nextCursor+    EdgeOverlap rawDirected -> do+      let rawEdge = directedInt rawDirected+      rawOrigin <- readOrigin mutable rawEdge+      rawDestination <- readOrigin mutable (rawEdge `xor` 1)+      let current = vertexInt (mutableCursorAt cursor)+          oriented+            | rawOrigin == current = Just rawEdge+            | rawDestination == current = Just (rawEdge `xor` 1)+            | otherwise = Nothing+      case oriented of+        Nothing ->+          pure+            ( MutablePlanFailed+                ( CorridorBoundaryMissing+                    (mutableCursorAt cursor)+                    (VertexId (fromIntegral rawOrigin))+                )+            )+        Just edge -> do+          prefix <-+            if mutableCursorConflictCount cursor == 0+              then pure cursor+              else finishMutableRecover workspace (mutableCursorAt cursor) cursor+          let !existingAt =+                if mutableCursorConflictCount cursor == 0+                  then mutableCursorHeader cursor+                  else mutableCursorWriteAt prefix+              !edgeDestination =+                VertexId+                  ( fromIntegral+                      (if edge == rawEdge then rawDestination else rawOrigin)+                  )+              !pieceCount = mutableCursorPieceCount prefix + 1+              !nextHeader = existingAt + 2+          writeConstraintProgram workspace existingAt existingProgramTag+          writeConstraintProgram workspace (existingAt + 1) edge+          nextCursor <-+            beginMutableRecover+              workspace+              nextHeader+              edgeDestination+              pieceCount+              True+          continueMutablePlan workspace mutable lineFrom lineTo target event nextCursor++continueMutablePlan+  :: ConstraintWorkspace s+  -> MutableDcel s vertex directed undirected face+  -> Point+  -> Point+  -> VertexId+  -> Intersection+  -> MutableProgramCursor+  -> ST s MutablePlanWalk+continueMutablePlan workspace mutable lineFrom lineTo target event cursor = do+  following <- nextMutableIntersection mutable lineFrom lineTo event+  case following of+    Just nextEvent -> pure (MutablePlanActive nextEvent cursor)+    Nothing -> MutablePlanComplete <$> settleMutableProgram workspace target cursor++beginMutableRecover+  :: ConstraintWorkspace s+  -> Int+  -> VertexId+  -> Int+  -> Bool+  -> ST s MutableProgramCursor+beginMutableRecover workspace header from pieceCount afterOverlap = do+  writeConstraintProgram workspace header recoverProgramTag+  writeConstraintProgram workspace (header + 1) (vertexInt from)+  writeConstraintProgram workspace (header + 2) 0+  writeConstraintProgram workspace (header + 3) 0+  pure+    MutableProgramCursor+      { mutableCursorAt = from+      , mutableCursorHeader = header+      , mutableCursorWriteAt = header + 4+      , mutableCursorConflictCount = 0+      , mutableCursorPieceCount = pieceCount+      , mutableCursorAfterOverlap = afterOverlap+      }++finishMutableRecover+  :: ConstraintWorkspace s+  -> VertexId+  -> MutableProgramCursor+  -> ST s MutableProgramCursor+finishMutableRecover workspace to cursor = do+  writeConstraintProgram workspace (mutableCursorHeader cursor + 2) (vertexInt to)+  writeConstraintProgram workspace (mutableCursorHeader cursor + 3) (mutableCursorConflictCount cursor)+  pure+    cursor+      { mutableCursorAt = to+      , mutableCursorPieceCount = mutableCursorPieceCount cursor + 1+      }++settleMutableProgram+  :: ConstraintWorkspace s+  -> VertexId+  -> MutableProgramCursor+  -> ST s MutableConstraintProgram+settleMutableProgram workspace target cursor+  | mutableCursorAt cursor == target =+      pure+        MutableConstraintProgram+          { mutableProgramWordCount = mutableCursorHeader cursor+          , mutableProgramPieceCount = mutableCursorPieceCount cursor+          }+  | otherwise = do+      finished <- finishMutableRecover workspace target cursor+      pure+        MutableConstraintProgram+          { mutableProgramWordCount = mutableCursorWriteAt finished+          , mutableProgramPieceCount = mutableCursorPieceCount finished+          }++existingProgramTag :: Int+existingProgramTag = 0++recoverProgramTag :: Int+recoverProgramTag = 1++mutablePlanIsActive :: MutablePlanWalk -> Bool+mutablePlanIsActive (MutablePlanActive _ _) = True+mutablePlanIsActive _ = False
+ src-build/Moonlight/Triangulation/Internal/Cdt/Corridor/Trace.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Local direction tracing inside the thawed mesh: where a directed line+-- leaves the vertex or edge it currently stands on.+module Moonlight.Triangulation.Internal.Cdt.Corridor.Trace+  ( MutableVertexOut (..)+  , MutableVertexTrace (..)+  , MutableEdgeOut (..)+  , nextMutableIntersection+  , traceMutableDirectionOutOfVertex+  , advanceMutableVertexTrace+  , traceMutableDirectionOutOfEdge+  , mutableEdgeIntersectsNonCollinear+  , mutableVertexTraceIsSearching+  ) where++import Control.Monad.ST (ST)+import Data.Bits (xor)+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.IntersectionIterator+import Moonlight.Triangulation.Internal.Cdt.Combinators+  ( directedInt+  , foldWhileM+  , vertexInt+  )+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Math+import Moonlight.Triangulation.Scalar (orient2dCoordinates)++data MutableVertexOut+  = MutableVertexOutHull+  | MutableVertexOutOverlap {-# UNPACK #-} !Int+  | MutableVertexOutEdge {-# UNPACK #-} !Int++data MutableVertexTrace+  = MutableVertexTraceSearching {-# UNPACK #-} !Int !Ordering+  | MutableVertexTraceComplete !MutableVertexOut++data MutableEdgeOut+  = MutableEdgeOutHull+  | MutableEdgeOutVertex {-# UNPACK #-} !Int+  | MutableEdgeOutEdge {-# UNPACK #-} !Int+  | MutableEdgeOutNone++nextMutableIntersection+  :: MutableDcel s vertex directed undirected face+  -> Point+  -> Point+  -> Intersection+  -> ST s (Maybe Intersection)+nextMutableIntersection mutable lineFrom lineTo current =+  case current of+    EdgeIntersection directed -> do+      edgeOut <- traceMutableDirectionOutOfEdge mutable (directedInt directed) lineFrom lineTo+      pure $ case edgeOut of+        MutableEdgeOutHull -> Nothing+        MutableEdgeOutVertex vertex ->+          Just (VertexIntersection (VertexId (fromIntegral vertex)))+        MutableEdgeOutEdge edge ->+          Just (EdgeIntersection (DirectedEdgeId (fromIntegral edge)))+        MutableEdgeOutNone -> Nothing+    VertexIntersection vertex -> do+      currentPoint <- pointAt mutable (vertexInt vertex)+      if currentPoint == lineTo+        then pure Nothing+        else do+          vertexOut <- traceMutableDirectionOutOfVertex mutable (vertexInt vertex) lineTo+          case vertexOut of+            MutableVertexOutHull -> pure Nothing+            MutableVertexOutOverlap edge ->+              pure (Just (EdgeOverlap (DirectedEdgeId (fromIntegral edge))))+            MutableVertexOutEdge edge -> do+              edgeFrom <- edgeOriginPoint mutable edge+              edgeTo <- edgeOriginPoint mutable (edge `xor` 1)+              pure+                ( if orient2d edgeFrom edgeTo lineTo == LT+                    then Nothing+                    else Just (EdgeIntersection (DirectedEdgeId (fromIntegral edge)))+                )+    EdgeOverlap directed+      | lineFrom == lineTo -> pure Nothing+      | otherwise -> do+          destination <- readOrigin mutable (directedInt directed `xor` 1)+          destinationPoint <- pointAt mutable destination+          pure+            ( if onClosedSegment lineFrom lineTo destinationPoint+                then Just (VertexIntersection (VertexId (fromIntegral destination)))+                else Nothing+            )++traceMutableDirectionOutOfVertex+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> Point+  -> ST s MutableVertexOut+traceMutableDirectionOutOfVertex mutable vertex target = do+  start <- readVertexOut mutable vertex+  if start < 0+    then pure MutableVertexOutHull+    else do+      currentPoint <- pointAt mutable vertex+      startTarget <- edgeOriginPoint mutable (start `xor` 1)+      halfEdges <- directedEdgeCount mutable+      let startSide = orient2d currentPoint startTarget target+          rotateCounterClockwise = startSide == GT+      traced <-+        foldWhileM+          mutableVertexTraceIsSearching+          (advanceMutableVertexTrace mutable currentPoint target rotateCounterClockwise)+          (MutableVertexTraceSearching start startSide)+          [0 .. halfEdges]+      pure $ case traced of+        MutableVertexTraceComplete result -> result+        MutableVertexTraceSearching _ _ -> MutableVertexOutHull++advanceMutableVertexTrace+  :: MutableDcel s vertex directed undirected face+  -> Point+  -> Point+  -> Bool+  -> MutableVertexTrace+  -> Int+  -> ST s MutableVertexTrace+advanceMutableVertexTrace _ _ _ _ complete@(MutableVertexTraceComplete _) _ = pure complete+advanceMutableVertexTrace mutable currentPoint target rotateCounterClockwise (MutableVertexTraceSearching current currentSide) _ = do+  currentTarget <- edgeOriginPoint mutable (current `xor` 1)+  if currentSide == EQ && projectionFactor currentPoint currentTarget target >= 0+    then pure (MutableVertexTraceComplete (MutableVertexOutOverlap current))+    else do+      following <-+        if rotateCounterClockwise+          then (`xor` 1) <$> readPrevious mutable current+          else readNext mutable (current `xor` 1)+      followingTarget <- edgeOriginPoint mutable (following `xor` 1)+      let followingSide = orient2d currentPoint followingTarget target+      if followingSide == EQ && projectionFactor currentPoint followingTarget target >= 0+        then pure (MutableVertexTraceComplete (MutableVertexOutOverlap following))+        else do+          faceBetween <-+            readFace mutable (if rotateCounterClockwise then current else following)+          if faceBetween == 0+            then pure (MutableVertexTraceComplete MutableVertexOutHull)+            else+              if rotateCounterClockwise == (followingSide == LT)+                then do+                  segment <-+                    if rotateCounterClockwise+                      then readNext mutable current+                      else readPrevious mutable (current `xor` 1)+                  pure+                    ( MutableVertexTraceComplete+                        (MutableVertexOutEdge (segment `xor` 1))+                    )+                else pure (MutableVertexTraceSearching following followingSide)++traceMutableDirectionOutOfEdge+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> Point+  -> Point+  -> ST s MutableEdgeOut+traceMutableDirectionOutOfEdge mutable edge lineFrom lineTo = do+  incident <- readFace mutable edge+  if incident == 0+    then pure MutableEdgeOutHull+    else do+      edgePrevious <- readPrevious mutable edge+      edgeNext <- readNext mutable edge+      edgeOrigin <- edgeOriginPoint mutable edge+      oppositeVertex <- edgeOriginPoint mutable edgePrevious+      let !originSide = orient2d lineFrom lineTo edgeOrigin+          !oppositeSide = orient2d lineFrom lineTo oppositeVertex+      if originSide == EQ || oppositeSide == EQ+        then classifyDegenerate edgePrevious edgeNext+        else+          if originSide == oppositeSide+            then do+              nextOrigin <- edgeOriginPoint mutable edgeNext+              let !outgoing = edgeNext `xor` 1+                  !targetSide = orient2d oppositeVertex nextOrigin lineTo+              pure+                ( if targetSide == LT+                    then MutableEdgeOutNone+                    else MutableEdgeOutEdge outgoing+                )+            else do+              let !outgoing = edgePrevious `xor` 1+                  !targetSide = orient2d edgeOrigin oppositeVertex lineTo+              pure+                ( if targetSide == LT+                    then MutableEdgeOutNone+                    else MutableEdgeOutEdge outgoing+                )+ where+  classifyDegenerate edgePrevious edgeNext = do+    previousIntersects <- mutableEdgeIntersectsNonCollinear mutable lineFrom lineTo edgePrevious+    nextIntersects <- mutableEdgeIntersectsNonCollinear mutable lineFrom lineTo edgeNext+    case (previousIntersects, nextIntersects) of+      (True, False) -> pure (MutableEdgeOutEdge (edgePrevious `xor` 1))+      (False, True) -> pure (MutableEdgeOutEdge (edgeNext `xor` 1))+      (True, True) -> MutableEdgeOutVertex <$> readOrigin mutable edgePrevious+      (False, False) -> pure MutableEdgeOutNone++mutableEdgeIntersectsNonCollinear+  :: MutableDcel s vertex directed undirected face+  -> Point+  -> Point+  -> Int+  -> ST s Bool+mutableEdgeIntersectsNonCollinear+  mutable+  (Point lineFromX lineFromY)+  (Point lineToX lineToY)+  edge = do+    edgeFromVertex <- readOrigin mutable edge+    edgeToVertex <- readOrigin mutable (edge `xor` 1)+    Point edgeFromX edgeFromY <- pointAt mutable edgeFromVertex+    Point edgeToX edgeToY <- pointAt mutable edgeToVertex+    let !lineFromSide =+          orient2dCoordinates+            edgeFromX edgeFromY edgeToX edgeToY lineFromX lineFromY+        !lineToSide =+          orient2dCoordinates+            edgeFromX edgeFromY edgeToX edgeToY lineToX lineToY+        !edgeFromSide =+          orient2dCoordinates+            lineFromX lineFromY lineToX lineToY edgeFromX edgeFromY+        !edgeToSide =+          orient2dCoordinates+            lineFromX lineFromY lineToX lineToY edgeToX edgeToY+    pure+      ( lineFromSide /= lineToSide+          && edgeFromSide /= edgeToSide+      )++mutableVertexTraceIsSearching :: MutableVertexTrace -> Bool+mutableVertexTraceIsSearching (MutableVertexTraceSearching _ _) = True+mutableVertexTraceIsSearching _ = False
+ src-build/Moonlight/Triangulation/Internal/Cdt/Query.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Read-only interrogation of the constrained layer, over both the published+-- mesh and the thawed one, plus the endpoint validity the verbs share.+module Moonlight.Triangulation.Internal.Cdt.Query+  ( constraintEdges+  , constraintStorageBytes+  , existsConstraint+  , canAddConstraint+  , intersectsConstraint+  , getConflictingEdgesBetweenPoints+  , getConflictingEdgesBetweenVertices+  , findDirectedEdge+  , findMutableEdge+  , validateEndpoints+  , validVertex+  ) where++import Control.Monad.ST (ST)+import Data.Bits (xor)+import qualified Data.IntSet as IntSet+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.IntersectionIterator+import Moonlight.Triangulation.Internal.Cdt.Admission+  ( ConstraintAdmission (..)+  , constraintAdmission+  )+import Moonlight.Triangulation.Internal.Cdt.Types (CdtError (..))+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.Paged (pagedLength)+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types++-- | Marked undirected edges in ascending identifier order.+constraintEdges+  :: Triangulation 'Constrained vertex directed undirected face+  -> [UndirectedEdgeId]+constraintEdges =+  fmap (UndirectedEdgeId . fromIntegral)+    . IntSet.toAscList+    . triConstraintEdges+{-# INLINE constraintEdges #-}++constraintStorageBytes+  :: Triangulation 'Constrained vertex directed undirected face+  -> Integer+constraintStorageBytes = toInteger . pagedLength . triConstraint++existsConstraint+  :: Triangulation 'Constrained vertex directed undirected face+  -> VertexId+  -> VertexId+  -> Bool+existsConstraint triangulation from to =+  case findDirectedEdge triangulation from to of+    Just edge -> Dcel.isConstraintEdge triangulation (asUndirected edge)+    Nothing -> False++canAddConstraint+  :: Triangulation 'Constrained vertex directed undirected face+  -> VertexId+  -> VertexId+  -> Bool+canAddConstraint triangulation from to =+  from /= to+    && validVertex triangulation from+    && validVertex triangulation to+    && case constraintAdmission triangulation from to of+      ConstraintBlocked _ -> False+      ConstraintAdmitted -> True++intersectsConstraint+  :: Triangulation 'Constrained vertex directed undirected face+  -> QueryPoint+  -> QueryPoint+  -> Bool+intersectsConstraint triangulation from to =+  case foldCorridorBetweenPoints triangulation from to firstBlocking () of+    Just (Left ()) -> True+    Just (Right ()) -> False+    Nothing -> not (null (getConflictingEdgesBetweenPoints triangulation from to))+ where+  firstBlocking :: () -> Intersection -> Either () ()+  firstBlocking _ (EdgeIntersection edge)+    | Dcel.isConstraintEdge triangulation (asUndirected edge) = Left ()+  firstBlocking _ _ = Right ()++getConflictingEdgesBetweenPoints+  :: Triangulation 'Constrained vertex directed undirected face+  -> QueryPoint+  -> QueryPoint+  -> [DirectedEdgeId]+getConflictingEdgesBetweenPoints triangulation from to =+  [ edge+  | EdgeIntersection edge <- lineIntersections triangulation from to+  , Dcel.isConstraintEdge triangulation (asUndirected edge)+  ]++getConflictingEdgesBetweenVertices+  :: Triangulation 'Constrained vertex directed undirected face+  -> VertexId+  -> VertexId+  -> [DirectedEdgeId]+getConflictingEdgesBetweenVertices triangulation from to+  | not (validVertex triangulation from && validVertex triangulation to) = []+  | otherwise =+      [ edge+      | EdgeIntersection edge <- lineIntersectionsBetweenVertices triangulation from to+      , Dcel.isConstraintEdge triangulation (asUndirected edge)+      ]++findDirectedEdge :: Triangulation 'Constrained vertex directed undirected face -> VertexId -> VertexId -> Maybe DirectedEdgeId+findDirectedEdge triangulation from to =+  case filter ((== to) . Dcel.destination triangulation) (Dcel.vertexOutgoingEdges triangulation from) of+    edge : _ -> Just edge+    [] -> Nothing++findMutableEdge :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s (Maybe Int)+findMutableEdge mutable from to = do+  start <- readVertexOut mutable from+  halfEdges <- directedEdgeCount mutable+  if start < 0+    then pure Nothing+    else go (halfEdges + 1) start start False+ where+  go !remaining !start !edge !visited+    | remaining <= 0 = pure Nothing+    | visited && edge == start = pure Nothing+    | otherwise = do+        destination <- readOrigin mutable (edge `xor` 1)+        if destination == to+          then pure (Just edge)+          else do+            previousEdge <- readPrevious mutable edge+            go (remaining - 1) start (previousEdge `xor` 1) True++validateEndpoints :: Triangulation 'Constrained vertex directed undirected face -> VertexId -> VertexId -> Either (CdtError) ()+validateEndpoints triangulation from to+  | not (validVertex triangulation from) = Left (InvalidConstraintVertex from)+  | not (validVertex triangulation to) = Left (InvalidConstraintVertex to)+  | otherwise = Right ()++validVertex :: Triangulation 'Constrained vertex directed undirected face -> VertexId -> Bool+validVertex triangulation (VertexId vertex) = fromIntegral vertex < Dcel.numVertices triangulation
+ src-build/Moonlight/Triangulation/Internal/Cdt/Recovery.hs view
@@ -0,0 +1,396 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Interpretation of a recovery program against the thawed mesh: conflict+-- strips are flipped away segment by segment and the constraints are set.+module Moonlight.Triangulation.Internal.Cdt.Recovery+  ( ConflictRecovery (..)+  , applyMutableConstraint+  , emptyConstraintRequest+  , recoverMutableRequest+  , recoverMutableProgramPiece+  , recordRecoveredSegment+  , resolveConflictStrip+  , mutableEdgeCrosses+  ) where++import Control.Monad.ST (ST)+import Data.Bits (xor)+import Data.Either (isRight)+import Data.Foldable (traverse_)+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Internal.Cdt.Combinators+  ( foldWhileM+  , vertexInt+  )+import Moonlight.Triangulation.Internal.Cdt.Corridor+  ( constraintWorkspaceFor+  , existingProgramTag+  , readConstraintProgram+  , recoverProgramTag+  , scanMutableConstraint+  )+import Moonlight.Triangulation.Internal.Cdt.Query (findMutableEdge)+import Moonlight.Triangulation.Internal.Cdt.Types+import Moonlight.Triangulation.Internal.DcelOperations+import Moonlight.Triangulation.Internal.Growable (GrowableWord32)+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , readScratch+  , writeScratch+  )+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Scalar (orient2dCoordinates)++data ConflictRecovery = ConflictRecovery+  { recoveredConstraintEdge :: {-# UNPACK #-} !Int+  , recoveredConstraintFresh :: !Bool+  }++-- | Admit one request against the thawed mesh and recover it. Every constraint+-- verb in this module reaches the topology through here; the callers differ+-- only in what they do with a rejection and in when they publish.+applyMutableConstraint+  :: GrowableWord32 s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> VertexId+  -> VertexId+  -> ST s (Either (CdtError) MutableConstraintOutcome)+applyMutableConstraint programWords mutable operation from to+  | from == to = pure (Right (MutableConstraintAccepted emptyConstraintRequest))+  | otherwise = do+      workspace <- constraintWorkspaceFor programWords mutable+      scanned <- scanMutableConstraint workspace mutable from to+      case scanned of+        Left failure -> pure (Left failure)+        Right (MutableConstraintScanBlocked blocking) ->+          pure (Right (MutableConstraintRejected (asUndirected blocking)))+        Right (MutableConstraintScanAdmitted program) ->+          fmap MutableConstraintAccepted+            <$> recoverMutableRequest workspace mutable operation program++emptyConstraintRequest :: ConstraintRequestAccumulator+emptyConstraintRequest =+  ConstraintRequestAccumulator+    { accumulatedRequestPath = []+    , accumulatedRequestAddedEdges = 0+    , accumulatedRequestCorridors = 0+    , accumulatedRequestReusedFaces = 0+    , accumulatedRequestCrossedEdges = 0+    }++recoverMutableRequest+  :: ConstraintWorkspace s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> MutableConstraintProgram+  -> ST s (Either (CdtError) ConstraintRequestAccumulator)+recoverMutableRequest workspace mutable operation program = do+  interpreted <-+    foldWhileM+      isRight+      (recoverMutableProgramPiece workspace mutable operation (mutableProgramWordCount program))+      ( Right+          ConstraintProgramAccumulator+            { accumulatedProgramCursor = 0+            , accumulatedProgramRequest = emptyConstraintRequest+            }+      )+      [1 .. mutableProgramPieceCount program]+  pure $ case interpreted of+    Left obstruction -> Left obstruction+    Right completed+      | accumulatedProgramCursor completed == mutableProgramWordCount program ->+          Right (accumulatedProgramRequest completed)+      | otherwise ->+          Left+            ( ConstraintCorridorObstructed+                (CorridorProgramMalformed (accumulatedProgramCursor completed))+            )++recoverMutableProgramPiece+  :: ConstraintWorkspace s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Either (CdtError) ConstraintProgramAccumulator+  -> Int+  -> ST s (Either (CdtError) ConstraintProgramAccumulator)+recoverMutableProgramPiece _ _ _ _ failed@(Left _) _ = pure failed+recoverMutableProgramPiece workspace mutable operation wordCount (Right accumulator) _ = do+  let !cursor = accumulatedProgramCursor accumulator+      malformed =+        Left+          ( ConstraintCorridorObstructed+              (CorridorProgramMalformed cursor)+          )+  if cursor < 0 || cursor >= wordCount+    then pure malformed+    else do+      tag <- readConstraintProgram workspace cursor+      case tag of+        _+          | tag == existingProgramTag && cursor + 1 < wordCount -> do+              edge <- readConstraintProgram workspace (cursor + 1)+              fresh <- setConstraint mutable edge+              pure+                ( Right+                    accumulator+                      { accumulatedProgramCursor = cursor + 2+                      , accumulatedProgramRequest =+                          recordRecoveredSegment+                            (accumulatedProgramRequest accumulator)+                            edge+                            fresh+                            0+                            0+                      }+                )+          | tag == recoverProgramTag && cursor + 3 < wordCount -> do+              rawFrom <- readConstraintProgram workspace (cursor + 1)+              rawTo <- readConstraintProgram workspace (cursor + 2)+              conflictCount <- readConstraintProgram workspace (cursor + 3)+              let !conflictStart = cursor + 4+                  !nextCursor = conflictStart + conflictCount+                  !from = VertexId (fromIntegral rawFrom)+                  !to = VertexId (fromIntegral rawTo)+              if conflictCount < 0 || nextCursor > wordCount+                then pure malformed+                else do+                  direct <- findMutableEdge mutable rawFrom rawTo+                  recovered <-+                    case direct of+                      Just edge -> do+                        fresh <- setConstraint mutable edge+                        pure+                          ( Right+                              ConflictRecovery+                                { recoveredConstraintEdge = edge+                                , recoveredConstraintFresh = fresh+                                }+                          )+                      Nothing+                        | conflictCount == 0 ->+                            pure+                              ( Left+                                  ( ConstraintCorridorObstructed+                                      (CorridorTargetMissing from to)+                                  )+                              )+                        | otherwise ->+                            resolveConflictStrip+                              workspace+                              mutable+                              operation+                              from+                              to+                              conflictStart+                              conflictCount+                  pure $ case recovered of+                    Left obstruction -> Left obstruction+                    Right recovery ->+                      Right+                        accumulator+                          { accumulatedProgramCursor = nextCursor+                          , accumulatedProgramRequest =+                              recordRecoveredSegment+                                (accumulatedProgramRequest accumulator)+                                (recoveredConstraintEdge recovery)+                                (recoveredConstraintFresh recovery)+                                conflictCount+                                (if conflictCount == 0 then 0 else conflictCount + 1)+                          }+          | otherwise -> pure malformed++recordRecoveredSegment+  :: ConstraintRequestAccumulator+  -> Int+  -> Bool+  -> Int+  -> Int+  -> ConstraintRequestAccumulator+recordRecoveredSegment accumulator edge fresh crossed reusedFaces =+  accumulator+    { accumulatedRequestPath = DirectedEdgeId (fromIntegral edge) : accumulatedRequestPath accumulator+    , accumulatedRequestAddedEdges =+        accumulatedRequestAddedEdges accumulator + if fresh then 1 else 0+    , accumulatedRequestCorridors =+        accumulatedRequestCorridors accumulator + if crossed == 0 then 0 else 1+    , accumulatedRequestReusedFaces =+        accumulatedRequestReusedFaces accumulator + reusedFaces+    , accumulatedRequestCrossedEdges =+        accumulatedRequestCrossedEdges accumulator + crossed+    }++resolveConflictStrip+  :: ConstraintWorkspace s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> VertexId+  -> VertexId+  -> Int+  -> Int+  -> ST s (Either (CdtError) ConflictRecovery)+resolveConflictStrip workspace mutable operation from to conflictStart stripLength = do+  fromPoint <- pointAt mutable (vertexInt from)+  toPoint <- pointAt mutable (vertexInt to)+  traverse_+    (\index -> do+      edge <- readConstraintProgram workspace (conflictStart + index)+      writeScratch operation index edge+    )+    [0 .. stripLength - 1]+  recovered <-+    recover+      stripLength+      safetyBudget+      0+      0+      stripLength+      stripLength+      []+      fromPoint+      toPoint+  case recovered of+    Left failure -> pure (Left failure)+    Right (edge, flipped) -> do+      fresh <- setConstraint mutable edge+      legalizeEdges mutable operation flipped+      pure+        ( Right+            ConflictRecovery+              { recoveredConstraintEdge = edge+              , recoveredConstraintFresh = fresh+              }+        )+ where+  safetyBudget = max 64 (32 * (stripLength + 1) * (stripLength + 1))++  -- The corridor is an ordered section through the current triangulation.+  -- Until an original section is dequeued, no flip can have changed that+  -- edge's endpoints: flips only repurpose the identity being flipped, and+  -- requeued identities remain behind every unseen original in this FIFO.+  -- Consequently the first visit inherits the crossing proof established by+  -- the corridor walk. Only requeued edges require the predicate again.+  recover !capacity !remaining !stalled !headIndex !pendingCount !unseenOriginalCount !flipped !fromPoint !toPoint+    | remaining <= 0 =+        pure+          ( Left+              ( ConstraintRecoverySafetyBudgetExhausted+                  from+                  to+                  safetyBudget+                  (safetyBudget - remaining)+              )+          )+    | pendingCount <= 0 = do+        direct <- findMutableEdge mutable (vertexInt from) (vertexInt to)+        case direct of+          Just edge -> pure (Right (edge, flipped))+          Nothing ->+            pure+              (Left (ConstraintRecoveryStripExhausted from to stripLength))+    | otherwise = do+        edge <- readScratch operation headIndex+        let !nextHead = advance capacity headIndex+            !restCount = pendingCount - 1+            !nextUnseenOriginalCount = max 0 (unseenOriginalCount - 1)+        stillCrosses <-+          if unseenOriginalCount > 0+            then pure True+            else mutableEdgeCrosses mutable fromPoint toPoint edge+        if not stillCrosses+          then recover capacity (remaining - 1) 0 nextHead restCount nextUnseenOriginalCount flipped fromPoint toPoint+          else do+            flippable <- isFlippableEdge mutable edge+            if flippable+              then do+                rewritten <- flipEdge mutable edge+                case rewritten of+                  Left obstruction -> pure (Left (CdtBuildError obstruction))+                  Right () -> do+                    addCounter operation CounterEdgeFlips 1+                    crossesAfterFlip <- mutableEdgeCrosses mutable fromPoint toPoint edge+                    if crossesAfterFlip+                      then do+                        enqueue capacity nextHead restCount edge+                        recover+                          capacity+                          (remaining - 1)+                          0+                          nextHead+                          (restCount + 1)+                          nextUnseenOriginalCount+                          (edge : flipped)+                          fromPoint+                          toPoint+                      else recover capacity (remaining - 1) 0 nextHead restCount nextUnseenOriginalCount (edge : flipped) fromPoint toPoint+              else do+                enqueue capacity nextHead restCount edge+                let !nextCount = restCount + 1+                    !nextStalled = stalled + 1+                if nextStalled >= nextCount+                  then+                    pure+                      ( Left+                          ( ConstraintRecoveryStripUnflippable+                              from+                              to+                              (DirectedEdgeId (fromIntegral edge))+                              nextCount+                          )+                      )+                  else recover capacity (remaining - 1) nextStalled nextHead nextCount nextUnseenOriginalCount flipped fromPoint toPoint++  enqueue !capacity !headIndex !count !edge =+    writeScratch operation (wrap capacity (headIndex + count)) edge++  advance :: Int -> Int -> Int+  advance !capacity !index+    | index + 1 == capacity = 0+    | otherwise = index + 1++  wrap :: Int -> Int -> Int+  wrap !capacity !index+    | index >= capacity = index - capacity+    | otherwise = index++mutableEdgeCrosses+  :: MutableDcel s vertex directed undirected face+  -> Point+  -> Point+  -> Int+  -> ST s Bool+mutableEdgeCrosses+  mutable+  (Point lineFromX lineFromY)+  (Point lineToX lineToY)+  edge = do+    edgeFromVertex <- readOrigin mutable edge+    edgeToVertex <- readOrigin mutable (edge `xor` 1)+    Point edgeFromX edgeFromY <- pointAt mutable edgeFromVertex+    Point edgeToX edgeToY <- pointAt mutable edgeToVertex+    let !edgeFromSide =+          orient2dCoordinates+            lineFromX lineFromY lineToX lineToY edgeFromX edgeFromY+        !edgeToSide =+          orient2dCoordinates+            lineFromX lineFromY lineToX lineToY edgeToX edgeToY+        !lineFromSide =+          orient2dCoordinates+            edgeFromX edgeFromY edgeToX edgeToY lineFromX lineFromY+        !lineToSide =+          orient2dCoordinates+            edgeFromX edgeFromY edgeToX edgeToY lineToX lineToY+    pure+      ( opposite edgeFromSide edgeToSide+          && opposite lineFromSide lineToSide+      )+ where+  opposite LT GT = True+  opposite GT LT = True+  opposite _ _ = False
+ src-build/Moonlight/Triangulation/Internal/Cdt/Region.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DataKinds #-}++-- | The two-sided reading of the constrained domain: which faces lie outside+-- the protected boundary and which lie within it.+module Moonlight.Triangulation.Internal.Cdt.Region+  ( outerRegionFaces+  , boundedRegionFaces+  ) where++import qualified Data.IntSet as IntSet+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.FloodFillIterator (facesAtEvenBarrierDepth)+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (innerFaces)+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types++outerRegionFaces+  :: Triangulation 'Constrained vertex directed undirected face+  -> [FaceId]+-- Crossing depth, not bare reachability. A face lies outside the constrained+-- domain when the fewest constraints separating it from the outer face is even,+-- so the hole of an annulus (two crossings) is outside exactly as its exterior+-- (none) is. Reachability alone is the depth-zero layer and calls that hole+-- domain, which would mesh it.+outerRegionFaces triangulation =+  facesAtEvenBarrierDepth triangulation (Dcel.isConstraintEdge triangulation)++boundedRegionFaces+  :: Triangulation 'Constrained vertex directed undirected face+  -> [FaceId]+boundedRegionFaces triangulation =+  [ face+  | face <- innerFaces triangulation+  , let FaceId raw = face+  , not (IntSet.member (fromIntegral raw) outside)+  ]+ where+  outside = IntSet.fromList [fromIntegral raw | FaceId raw <- outerRegionFaces triangulation]
+ src-build/Moonlight/Triangulation/Internal/Cdt/Segment.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | The singleton segment verbs: glue one segment or a polyline, and retire a+-- constraint, each inside one sealed transaction.+module Moonlight.Triangulation.Internal.Cdt.Segment+  ( addConstraintEdge+  , addConstraintEdges+  , applyConstraintToExistingEndpoints+  , applyAndPublishConstraint+  , publishConstraintResult+  , insertPolylineVertices+  , removeConstraintEdge+  , retireConstraintEdge+  ) where++import Control.Monad.ST (ST, runST)+import qualified Data.Vector as V+import Data.Primitive.PrimArray (indexPrimArray, sizeofPrimArray)+import Moonlight.Triangulation.BulkLoad (insertMany)+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Internal.Capacity (ensureCapacity)+import Moonlight.Triangulation.Internal.Cdt.Admission+  ( ConstraintAdmission (..)+  , constraintAdmission+  )+import Moonlight.Triangulation.Internal.Cdt.Batch (recoverConstraints)+import Moonlight.Triangulation.Internal.Cdt.Combinators+  ( asConstraintStep+  , bindMutable+  , mapLeft+  )+import Moonlight.Triangulation.Internal.Cdt.Recovery (applyMutableConstraint)+import Moonlight.Triangulation.Internal.Cdt.Site+  ( lookupExistingConstraintEndpoint+  , placeConstraintEndpoint+  )+import Moonlight.Triangulation.Internal.Cdt.Types+import Moonlight.Triangulation.Internal.DcelOperations+import Moonlight.Triangulation.Internal.Growable+  ( GrowableWord32+  , newGrowableWord32+  )+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , newOperationState+  )+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Math++-- | Site both endpoints and glue the segment between them, in one transaction.+-- A refused request publishes nothing, so the caller's triangulation still+-- stands and the endpoints it would have sited are not among its vertices.+addConstraintEdge+  :: HasPosition vertex+  => Triangulation 'Constrained vertex directed undirected face+  -> vertex+  -> vertex+  -> Either (CdtError) (ConstraintResult vertex directed undirected face)+addConstraintEdge triangulation fromVertex toVertex = do+  _ <- mapLeft CdtBuildError (validatePoint Nothing fromPoint)+  _ <- mapLeft CdtBuildError (validatePoint Nothing toPoint)+  result <-+    case+        ( lookupExistingConstraintEndpoint triangulation fromPoint+        , lookupExistingConstraintEndpoint triangulation toPoint+        ) of+      (Just from, Just to) ->+        case constraintAdmission triangulation from to of+          ConstraintBlocked blocking -> Left (ConstraintIntersection blocking)+          ConstraintAdmitted ->+            applyConstraintToExistingEndpoints+              triangulation+              from+              fromVertex+              to+              toVertex+      _ -> addConstraintWithEndpointPlacement+  pure result+ where+  !fromPoint = position fromVertex+  !toPoint = position toVertex+  -- Both endpoints may be new; neither may be. The reservation is for the peak.+  !capacity = Dcel.numVertices triangulation + 2++  addConstraintWithEndpointPlacement = do+    mapLeft CdtBuildError (ensureCapacity capacity)+    runST $ do+      mutable <- thawTriangulation capacity triangulation+      operation <- newOperationState (halfEdgeCapacity mutable)+      programWords <- newGrowableWord32 256+      asConstraintStep (placeConstraintEndpoint mutable operation Nothing fromPoint fromVertex)+        `bindMutable` \from ->+          asConstraintStep (placeConstraintEndpoint mutable operation Nothing toPoint toVertex)+            `bindMutable` \to ->+              applyAndPublishConstraint programWords mutable operation from to+-- | The common singleton case already owns both sites. Resolve them before+-- opening topology, then retain the original payload and counter semantics in+-- the transaction. The corridor worker is unchanged; only two redundant point+-- locations and two unused vertex-capacity reservations disappear.+applyConstraintToExistingEndpoints+  :: Triangulation 'Constrained vertex directed undirected face+  -> VertexId+  -> vertex+  -> VertexId+  -> vertex+  -> Either (CdtError) (ConstraintResult vertex directed undirected face)+applyConstraintToExistingEndpoints triangulation from@(VertexId rawFrom) fromPayload to@(VertexId rawTo) toPayload =+  runST $ do+    mutable <- thawTriangulation (Dcel.numVertices triangulation) triangulation+    operation <- newOperationState (halfEdgeCapacity mutable)+    programWords <- newGrowableWord32 256+    addCounter operation CounterInputPoints 2+    addCounter operation CounterExistingPoints 2+    addCounter operation CounterDuplicatePoints 2+    writeVertexData mutable (fromIntegral rawFrom) fromPayload+    writeVertexData mutable (fromIntegral rawTo) toPayload+    applyAndPublishConstraint programWords mutable operation from to++applyAndPublishConstraint+  :: GrowableWord32 s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> VertexId+  -> VertexId+  -> ST s (Either (CdtError) (ConstraintResult vertex directed undirected face))+applyAndPublishConstraint programWords mutable operation from to =+  applyMutableConstraint programWords mutable operation from to+    `bindMutable` \applied ->+      case applied of+        MutableConstraintRejected blocking ->+          pure (Left (ConstraintIntersection blocking))+        MutableConstraintAccepted request ->+          publishConstraintResult+            mutable+            (accumulatedRequestPath request)+            (accumulatedRequestAddedEdges request)+{-# INLINE applyAndPublishConstraint #-}++-- | Close the transaction on an accepted request. The accumulated path runs+-- newest-first, so it is reversed exactly once, here.+publishConstraintResult+  :: MutableDcel s vertex directed undirected face+  -> [DirectedEdgeId]+  -> Int+  -> ST s (Either (CdtError) (ConstraintResult vertex directed undirected face))+publishConstraintResult mutable reversedPath added = do+  frozenOutcome <- freezeTriangulation mutable+  pure $ case frozenOutcome of+    Left obstruction -> Left (CdtBuildError obstruction)+    Right frozen ->+      Right+        ConstraintResult+          { constraintTriangulation = frozen+          , constraintPath = V.fromList (reverse reversedPath)+          , constraintAddedEdges = added+          }++addConstraintEdges+  :: HasPosition vertex+  => Triangulation 'Constrained vertex directed undirected face+  -> V.Vector vertex+  -> Bool+  -> Either (CdtError) (Triangulation 'Constrained vertex directed undirected face)+addConstraintEdges triangulation polylineVertices closed+  | V.null polylineVertices = Right triangulation+  | otherwise = do+      (withVertices, handles) <- insertPolylineVertices triangulation polylineVertices+      let adjacent = V.zip handles (V.drop 1 handles)+          closing =+            if closed && V.length handles > 1+              then+                case (handles V.!? (V.length handles - 1), handles V.!? 0) of+                  (Just finalVertex, Just firstVertex) ->+                    V.singleton (finalVertex, firstVertex)+                  _ -> V.empty+              else V.empty+      batch <- recoverConstraints withVertices (adjacent V.++ closing)+      case V.foldl' firstBlocking Nothing (constraintBatchOutcomes batch) of+        Nothing -> Right (constraintBatchTriangulation batch)+        Just blocking -> Left (ConstraintIntersection blocking)+ where+  firstBlocking found@(Just _) _ = found+  firstBlocking Nothing outcome =+    case outcome of+      ConstraintAccepted _ _ -> Nothing+      ConstraintRejected blocking -> Just blocking++insertPolylineVertices+  :: HasPosition vertex+  => Triangulation 'Constrained vertex directed undirected face+  -> V.Vector vertex+  -> Either (CdtError) (Triangulation 'Constrained vertex directed undirected face, V.Vector VertexId)+insertPolylineVertices triangulation points = do+  result <- mapLeft CdtBuildError (insertMany triangulation points)+  let !mapping = buildInputVertices result+  pure (buildTriangulation result, V.generate (sizeofPrimArray mapping) (VertexId . indexPrimArray mapping))++removeConstraintEdge+  :: Triangulation 'Constrained vertex directed undirected face+  -> UndirectedEdgeId+  -> Either (CdtError) (Triangulation 'Constrained vertex directed undirected face)+removeConstraintEdge triangulation edge@(UndirectedEdgeId raw)+  | fromIntegral raw >= edgeCount =+      Left (ConstraintEdgeIndexOutOfRange edge edgeCount)+  -- An edge carrying no constraint has nothing to retire, and answering that+  -- without thawing is the difference between O(1) and a republished mesh.+  | not (Dcel.isConstraintEdge triangulation edge) = Right triangulation+  | otherwise = runST $ do+      mutable <- thawTriangulation (Dcel.numVertices triangulation) triangulation+      operation <- newOperationState (halfEdgeCapacity mutable)+      retireConstraintEdge mutable operation edge `bindMutable` \() ->+        fmap (mapLeft CdtBuildError) (freezeTriangulation mutable)+ where+  edgeCount = Dcel.numUndirectedEdges triangulation++-- | Retire one constraint inside the open transaction and restore the Delaunay+-- property across the edge it protected.+retireConstraintEdge+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> UndirectedEdgeId+  -> ST s (Either (CdtError) ())+retireConstraintEdge mutable operation edge@(UndirectedEdgeId raw) = do+  halfEdges <- directedEdgeCount mutable+  let !directed = fromIntegral raw * 2+  if directed >= halfEdges+    then pure (Left (ConstraintEdgeIndexOutOfRange edge (halfEdges `quot` 2)))+    else do+      constrained <- readConstraint mutable directed+      if not constrained+        then pure (Right ())+        else do+          _ <- clearConstraint mutable directed+          legalizeEdges mutable operation [directed]+          pure (Right ())
+ src-build/Moonlight/Triangulation/Internal/Cdt/Site.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Siting of constraint endpoints: resolving a point to an existing handle,+-- and materializing one inside an open transaction when it has none.+module Moonlight.Triangulation.Internal.Cdt.Site+  ( lookupExistingConstraintEndpoint+  , placeConstraintEndpoint+  ) where++import Control.Monad.ST (ST)+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Insertion (insertVertexAtPoint)+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  )+import Moonlight.Triangulation.Internal.PointIndex (lookupPointIndex)+import Moonlight.Triangulation.Internal.Probe (Probe (..))+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Math++lookupExistingConstraintEndpoint+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> Maybe VertexId+lookupExistingConstraintEndpoint triangulation point =+  VertexId . fromIntegral+    <$> lookupPointIndex+      (triPointX triangulation)+      (triPointY triangulation)+      (triPointIndex triangulation)+      point++-- | Materialize one point in the open transaction. A payload standing at an+-- occupied position keeps that handle and overwrites the payload, which is what+-- the persistent insertion verb settled on.+--+-- The coordinates are checked here rather than by the callers, because a split+-- point is computed rather than supplied: @lineIntersection@ refuses only a+-- zero denominator, and a denominator merely close to zero answers a coordinate+-- no arena should hold.+placeConstraintEndpoint+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Maybe Int+  -> Point+  -> vertex+  -> ST s (Either BuildError VertexId)+placeConstraintEndpoint mutable operation hint point payload =+  case validatePoint Nothing point of+    Left failure -> pure (Left failure)+    Right _ -> do+      addCounter operation CounterInputPoints 1+      outcome <- insertVertexAtPoint @'ProbeOff mutable operation hint point payload+      case outcome of+        Left failure -> pure (Left failure)+        Right (vertex, disposition) -> do+          case disposition of+            AlreadyPresent -> do+              writeVertexData mutable vertex payload+              addCounter operation CounterExistingPoints 1+              addCounter operation CounterDuplicatePoints 1+            Inserted -> addCounter operation CounterUniquePoints 1+          pure (Right (VertexId (fromIntegral vertex)))
+ src-build/Moonlight/Triangulation/Internal/Cdt/Split.hs view
@@ -0,0 +1,484 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | The splitting program: corridors that divide every constraint they cross,+-- driven across as few sealed transactions as the vertex reservation allows.+module Moonlight.Triangulation.Internal.Cdt.Split+  ( SplitChunkShape (..)+  , SplitReceipt (..)+  , SplitChunkOutcome (..)+  , SplitRequest (..)+  , SplitCursor (..)+  , SplitStep (..)+  , addConstraintAndSplit+  , addConstraintsAndSplit+  , splitCensus+  , driveConstraintSplits+  , runSplitChunk+  , splitConstraintCorridor+  , mutableEdgeWasSplit+  , mutableConstraintBetween+  , repairRoundedSplit+  , lineIntersection+  ) where++import Control.Monad.ST (ST, runST)+import Data.Bits (xor)+import qualified Data.Vector as V+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Internal.Capacity (ensureCapacity)+import Moonlight.Triangulation.Internal.Cdt.Combinators+  ( asConstraintStep+  , bindMutable+  , directedInt+  , mapLeft+  , vertexInt+  )+import Moonlight.Triangulation.Internal.Cdt.Corridor+  ( constraintWorkspaceFor+  , scanMutableConstraint+  )+import Moonlight.Triangulation.Internal.Cdt.Query+  ( findMutableEdge+  , getConflictingEdgesBetweenVertices+  , validateEndpoints+  )+import Moonlight.Triangulation.Internal.Cdt.Recovery+  ( applyMutableConstraint+  , recoverMutableRequest+  )+import Moonlight.Triangulation.Internal.Cdt.Segment (retireConstraintEdge)+import Moonlight.Triangulation.Internal.Cdt.Site (placeConstraintEndpoint)+import Moonlight.Triangulation.Internal.Cdt.Types+import Moonlight.Triangulation.Internal.Growable+  ( GrowableWord32+  , newGrowableWord32+  )+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( OperationState+  , newOperationState+  )+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Math++-- | The part of a splitting request that does not move: the payload maker, the+-- endpoints the failure report must name, the iteration budget, and the+-- transaction's vertex reservation, past which the corridor suspends rather+-- than writes.+data SplitRequest vertex = SplitRequest+  { splitRequestMakeVertex :: !(Point -> vertex)+  , splitRequestFrom :: !VertexId+  , splitRequestTo :: !VertexId+  , splitRequestBudget :: {-# UNPACK #-} !Int+  , splitRequestVertexBound :: {-# UNPACK #-} !Int+  }++-- | The part that does: how much budget is left, which vertex the unrecovered+-- remainder starts at, and the path and edge count accumulated behind it. The+-- path runs newest-first and is reversed once, at publication.+data SplitCursor = SplitCursor+  { splitCursorRemaining :: {-# UNPACK #-} !Int+  , splitCursorAt :: !VertexId+  , splitCursorPath :: ![DirectedEdgeId]+  , splitCursorAdded :: {-# UNPACK #-} !Int+  }++-- | How a corridor run ends inside its transaction: settled at the target, or+-- suspended mid-corridor because the next division would outgrow the vertex+-- reservation. A suspension is not a refusal; the driver publishes,+-- re-reserves against the published mesh, and resumes at the cursor.+data SplitStep+  = SplitSettled !SplitCursor+  | SplitSuspended !SplitCursor++-- | The singleton opens corridor-local copy-on-write pages; the batch pays one+-- dense copy up front and writes flat.+data SplitChunkShape = SparseSplitChunk | DenseSplitChunk++-- | What one settled request leaves behind.+data SplitReceipt = SplitReceipt+  { splitReceiptPath :: !(V.Vector DirectedEdgeId)+  , splitReceiptAdded :: {-# UNPACK #-} !Int+  }++data SplitChunkOutcome vertex directed undirected face = SplitChunkOutcome+  { splitChunkTriangulation :: !(Triangulation 'Constrained vertex directed undirected face)+  , splitChunkReceipts :: ![SplitReceipt]+  , splitChunkSuspended :: !(Maybe SplitCursor)+  }++-- | Glue the requested segment, dividing every constraint it crosses at the+-- crossing point rather than refusing it. One transaction carries the whole+-- corridor: a singleton is a batch of one under the shared driver.+addConstraintAndSplit+  :: (Point -> vertex)+  -> Triangulation 'Constrained vertex directed undirected face+  -> VertexId+  -> VertexId+  -> Either (CdtError) (ConstraintResult vertex directed undirected face)+addConstraintAndSplit makeVertex triangulation from to = do+  validateEndpoints triangulation from to+  if from == to+    then pure (ConstraintResult triangulation V.empty 0)+    else do+      (published, receipts) <-+        driveConstraintSplits SparseSplitChunk makeVertex triangulation (V.singleton (from, to))+      pure+        ( case receipts V.!? 0 of+            Just receipt ->+              ConstraintResult+                { constraintTriangulation = published+                , constraintPath = splitReceiptPath receipt+                , constraintAddedEdges = splitReceiptAdded receipt+                }+            Nothing -> ConstraintResult published V.empty 0+        )++-- | Divide every requested segment inside as few transactions as the vertex+-- reservation allows: usually one, which is the referent semantics for a+-- splitting batch. Nothing is republished between corridors unless a corridor+-- crosses constraints created by an earlier request in the same batch --+-- growth no census against the base can see. In that one case the corridor+-- suspends, the chunk publishes, and the driver re-reserves against the+-- published mesh and resumes at the suspended cursor.+addConstraintsAndSplit+  :: (Point -> vertex)+  -> Triangulation 'Constrained vertex directed undirected face+  -> V.Vector (VertexId, VertexId)+  -> Either (CdtError) (ConstraintSplitBatchResult vertex directed undirected face)+addConstraintsAndSplit makeVertex triangulation requests = do+  (published, receipts) <- driveConstraintSplits DenseSplitChunk makeVertex triangulation requests+  pure+    ConstraintSplitBatchResult+      { splitBatchTriangulation = published+      , splitBatchPaths = V.map splitReceiptPath receipts+      , splitBatchAddedEdges = V.sum (V.map splitReceiptAdded receipts)+      }++-- | The obstruction census for one request against a published mesh: how many+-- constrained crossings its corridor holds, and the first of them. The first+-- crossing is a valid local section of the next transaction before any rewrite+-- occurs, so a chunk's first request carries it across the thaw boundary+-- instead of immediately rediscovering it; every later request rescans,+-- because earlier corridors may have rewritten the topology the witness names.+splitCensus+  :: Triangulation 'Constrained vertex directed undirected face+  -> (VertexId, VertexId)+  -> (Int, Maybe DirectedEdgeId)+splitCensus triangulation (from, to)+  | from == to = (0, Nothing)+  | otherwise =+      foldl'+        countCrossing+        (0, Nothing)+        (getConflictingEdgesBetweenVertices triangulation from to)+ where+  countCrossing :: (Int, Maybe DirectedEdgeId) -> DirectedEdgeId -> (Int, Maybe DirectedEdgeId)+  countCrossing (!count, firstCrossing) crossing =+    ( count + 1+    , case firstCrossing of+        Just first -> Just first+        Nothing -> Just crossing+    )++-- | Interpret splitting requests in order across as few sealed transactions as+-- possible. Each chunk reserves against the exact obstruction census of every+-- remaining request, so a chunk always settles at least its first request:+-- that census ran against the very mesh the chunk thawed and is exact before+-- any in-session rewrite. Termination follows.+driveConstraintSplits+  :: SplitChunkShape+  -> (Point -> vertex)+  -> Triangulation 'Constrained vertex directed undirected face+  -> V.Vector (VertexId, VertexId)+  -> Either+      (CdtError)+      ( Triangulation 'Constrained vertex directed undirected face+      , V.Vector SplitReceipt+      )+driveConstraintSplits shape makeVertex base requests = do+  V.mapM_ (uncurry (validateEndpoints base)) requests+  advance base 0 [] Nothing+ where+  advance triangulation start settled resumed+    | start >= V.length requests =+        Right (triangulation, V.fromList (reverse settled))+    | otherwise = do+        let remaining = V.drop start requests+            firstRound = start == 0 && case resumed of+              Nothing -> True+              Just _ -> False+            -- The opening chunk reserves optimistically -- one crossing per+            -- request -- rather than walking every corridor for an exact+            -- census before any work begins. A request that outgrows the+            -- reservation suspends mid-corridor with its partial work kept,+            -- and the next round censuses exactly against the published mesh,+            -- so heavy batches pay at most one speculative chunk.+            censuses+              | firstRound = V.replicate (V.length remaining) (1, Nothing)+              | otherwise = V.map (splitCensus triangulation) remaining+            !reservedSites = V.sum (V.map fst censuses)+            !capacity = Dcel.numVertices triangulation + 2 * reservedSites + 8+            -- The walk budget bounds divisions per request; constraints born+            -- inside the chunk are covered by the reservation term.+            !budget =+              2 * (Dcel.numConstraints triangulation + 2 * reservedSites + V.length remaining)+                + Dcel.numUndirectedEdges triangulation+                + 8+        mapLeft CdtBuildError (ensureCapacity capacity)+        outcome <- runST $ do+          mutable <- case shape of+            SparseSplitChunk -> thawTriangulation capacity triangulation+            DenseSplitChunk -> thawTriangulationDense capacity triangulation+          operation <- newOperationState (halfEdgeCapacity mutable)+          programWords <- newGrowableWord32 32+          runSplitChunk makeVertex mutable operation programWords remaining censuses capacity budget resumed+        case outcome of+          SplitChunkOutcome published receipts suspended ->+            advance published (start + length receipts) (receipts ++ settled) suspended++-- | One sealed transaction over a prefix of the remaining requests. Receipts+-- run newest-first; a suspension carries no receipt, so the settled count is+-- exactly the receipt count.+runSplitChunk+  :: (Point -> vertex)+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> GrowableWord32 s+  -> V.Vector (VertexId, VertexId)+  -> V.Vector (Int, Maybe DirectedEdgeId)+  -> Int+  -> Int+  -> Maybe SplitCursor+  -> ST s (Either (CdtError) (SplitChunkOutcome vertex directed undirected face))+runSplitChunk makeVertex mutable operation programWords requests censuses capacity budget resumed =+  go 0 [] resumed+ where+  go offset receipts pending+    | offset >= V.length requests = seal receipts Nothing+    | otherwise =+        let (from, to) = requests V.! offset+        in case pending of+             Nothing+               | from == to ->+                   go (offset + 1) (SplitReceipt V.empty 0 : receipts) Nothing+             _ ->+               let witness = if offset == 0 then snd (censuses V.! 0) else Nothing+                   cursor = case pending of+                     Just resumedCursor -> resumedCursor+                     Nothing -> SplitCursor budget from [] 0+                   request =+                     SplitRequest+                       { splitRequestMakeVertex = makeVertex+                       , splitRequestFrom = from+                       , splitRequestTo = to+                       , splitRequestBudget = budget+                       , splitRequestVertexBound = capacity+                       }+               in splitConstraintCorridor request programWords mutable operation witness cursor+                    `bindMutable` \step ->+                      case step of+                        SplitSettled settledCursor ->+                          go (offset + 1) (receiptOf settledCursor : receipts) Nothing+                        SplitSuspended suspendedCursor ->+                          seal receipts (Just suspendedCursor)++  receiptOf cursor =+    SplitReceipt+      { splitReceiptPath = V.fromList (reverse (splitCursorPath cursor))+      , splitReceiptAdded = splitCursorAdded cursor+      }++  seal receipts suspended = do+    frozenOutcome <- freezeTriangulation mutable+    pure $ case frozenOutcome of+      Left obstruction -> Left (CdtBuildError obstruction)+      Right frozen -> Right (SplitChunkOutcome frozen receipts suspended)++splitConstraintCorridor+  :: SplitRequest vertex+  -> GrowableWord32 s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Maybe DirectedEdgeId+  -> SplitCursor+  -> ST s (Either (CdtError) SplitStep)+splitConstraintCorridor request programWords mutable operation initialCrossing initialCursor =+  case initialCrossing of+    Just crossing -> divide initialCursor crossing+    Nothing -> descend initialCursor+ where+  !target = splitRequestTo request++  descend cursor+    | splitCursorRemaining cursor <= 0 =+        pure+          ( Left+              ( ConstraintSplitBudgetExhausted+                  (splitRequestFrom request)+                  target+                  (splitRequestBudget request)+              )+          )+    | otherwise = do+        workspace <- constraintWorkspaceFor programWords mutable+        scanMutableConstraint workspace mutable (splitCursorAt cursor) target+          `bindMutable` \scanned ->+            case scanned of+              MutableConstraintScanAdmitted program ->+                recoverMutableRequest workspace mutable operation program+                  `bindMutable` \final ->+                    pure+                      ( Right+                          ( SplitSettled+                              (advanceCursor cursor (splitCursorRemaining cursor) target final)+                          )+                      )+              MutableConstraintScanBlocked crossing -> divide cursor crossing++  divide cursor crossing = do+    occupied <- pointCount mutable+    if occupied + 2 > splitRequestVertexBound request+      then pure (Right (SplitSuspended cursor))+      else divideWithin cursor crossing++  divideWithin cursor crossing = do+    let !crossingEdge = directedInt crossing+        !oldConstraint = asUndirected crossing+    segmentFrom <- pointAt mutable (vertexInt (splitCursorAt cursor))+    segmentTo <- pointAt mutable (vertexInt target)+    oldFrom <- readOrigin mutable crossingEdge+    oldTo <- readOrigin mutable (crossingEdge `xor` 1)+    edgeFrom <- pointAt mutable oldFrom+    edgeTo <- pointAt mutable oldTo+    -- The split point lies on the crossing edge, so both its incident faces+    -- already contain it and the exact walk settles on its first probe. Without+    -- this the locate is unhinted, and an unhinted locate descends vertex by+    -- vertex from the arena's first face -- a distance that grows with the mesh+    -- while the corridor it is splitting stays a fixed few faces wide. A hull+    -- edge carries the outer face on one side, which the locator would refuse.+    incidentFace <- readFace mutable crossingEdge+    twinFace <- readFace mutable (crossingEdge `xor` 1)+    let !splitHint = Just (if incidentFace > 0 then incidentFace else twinFace)+    let !oldEndpoints =+          ( VertexId (fromIntegral oldFrom)+          , VertexId (fromIntegral oldTo)+          )+    case lineIntersection crossing segmentFrom segmentTo edgeFrom edgeTo of+      Left indeterminate -> pure (Left indeterminate)+      Right splitPoint ->+        -- The split lands where the intersection says, not where a round trip+        -- through 'makeVertex' happens to put it.+        asConstraintStep+          ( placeConstraintEndpoint+              mutable+              operation+              splitHint+              splitPoint+              (splitRequestMakeVertex request splitPoint)+          )+          `bindMutable` \splitVertex ->+            repairIfRounded oldConstraint oldEndpoints splitVertex `bindMutable` \() ->+              applyMutableConstraint programWords mutable operation (splitCursorAt cursor) splitVertex+                `bindMutable` \prefix ->+                  case prefix of+                    MutableConstraintRejected blocking ->+                      pure (Left (ConstraintIntersection blocking))+                    MutableConstraintAccepted segment ->+                      descend+                        (advanceCursor cursor (splitCursorRemaining cursor - 1) splitVertex segment)++  repairIfRounded oldConstraint oldEndpoints splitVertex = do+    divided <- mutableEdgeWasSplit mutable oldConstraint oldEndpoints splitVertex+    if divided+      then pure (Right ())+      else repairRoundedSplit programWords mutable operation oldConstraint oldEndpoints splitVertex++  advanceCursor cursor remaining reached segment =+    cursor+      { splitCursorRemaining = remaining+      , splitCursorAt = reached+      , splitCursorPath = accumulatedRequestPath segment ++ splitCursorPath cursor+      , splitCursorAdded = splitCursorAdded cursor + accumulatedRequestAddedEdges segment+      }++-- | Whether the inserted vertex actually divided the constraint it was placed+-- on. It did if that constraint is gone — the split retired the identity — or+-- if both halves now carry one. Rounding can place the vertex somewhere that+-- leaves the old constraint standing and neither half glued.+mutableEdgeWasSplit+  :: MutableDcel s vertex directed undirected face+  -> UndirectedEdgeId+  -> (VertexId, VertexId)+  -> VertexId+  -> ST s Bool+mutableEdgeWasSplit mutable (UndirectedEdgeId raw) (from, to) splitVertex = do+  halfEdges <- directedEdgeCount mutable+  let !directed = fromIntegral raw * 2+  stillConstrained <-+    if directed >= halfEdges+      then pure False+      else readConstraint mutable directed+  if not stillConstrained+    then pure True+    else do+      leading <- mutableConstraintBetween mutable from splitVertex+      if leading+        then mutableConstraintBetween mutable splitVertex to+        else pure False++mutableConstraintBetween+  :: MutableDcel s vertex directed undirected face+  -> VertexId+  -> VertexId+  -> ST s Bool+mutableConstraintBetween mutable from to = do+  found <- findMutableEdge mutable (vertexInt from) (vertexInt to)+  case found of+    Nothing -> pure False+    Just edge -> readConstraint mutable edge++-- | The split point rounded onto neither half of the constraint it was meant to+-- divide. Retire the stale identity and glue both halves against the vertex+-- that was actually sited. What this recovers is repair rather than the+-- requested segment, so it contributes nothing to the request's path.+repairRoundedSplit+  :: GrowableWord32 s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> UndirectedEdgeId+  -> (VertexId, VertexId)+  -> VertexId+  -> ST s (Either (CdtError) ())+repairRoundedSplit programWords mutable operation oldEdge (from, to) splitVertex =+  retireConstraintEdge mutable operation oldEdge `bindMutable` \() ->+    glue from splitVertex `bindMutable` \() -> glue splitVertex to+ where+  glue start end =+    applyMutableConstraint programWords mutable operation start end `bindMutable` \recovered ->+      pure $ case recovered of+        MutableConstraintRejected blocking -> Left (ConstraintIntersection blocking)+        MutableConstraintAccepted _ -> Right ()++lineIntersection+  :: DirectedEdgeId+  -> Point+  -> Point+  -> Point+  -> Point+  -> Either (CdtError) (Point)+lineIntersection crossing (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy)+  | denominator == 0 =+      Left (ConstraintSplitIntersectionIndeterminate crossing)+  | otherwise =+      Right (canonicalPoint (Point (ax + t * rx) (ay + t * ry)))+ where+  rx = bx - ax+  ry = by - ay+  sx = dx - cx+  sy = dy - cy+  denominator = rx * sy - ry * sx+  t = ((cx - ax) * sy - (cy - ay) * sx) / denominator
+ src-build/Moonlight/Triangulation/Internal/Cdt/Types.hs view
@@ -0,0 +1,363 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | The shared vocabulary of the constrained layer: its refusals, its published+-- results, and the transaction-local state its interpreters carry.+module Moonlight.Triangulation.Internal.Cdt.Types+  ( CdtError (..)+  , CanonicalSegment (..)+  , ConstraintConflict (..)+  , ConstrainedUnionError (..)+  , ConstrainedSeamSource (..)+  , ConstrainedSeamFaceEvidence (..)+  , ConstrainedSeamConstraintEvidence (..)+  , ConstrainedSeamResult (..)+  , CorridorObstruction (..)+  , ConstraintResult (..)+  , ConstraintOutcome (..)+  , ConstraintBatchStats (..)+  , ConstraintBatchResult (..)+  , ConstrainedExtensionResult (..)+  , ConstraintSplitBatchResult (..)+  , ConstraintBatchAccumulator (..)+  , ConstraintRequestAccumulator (..)+  , ConstraintWorkspace (..)+  , MutableConstraintProgram (..)+  , MutableConstraintOutcome (..)+  , MutableProgramCursor (..)+  , MutablePlanWalk (..)+  , MutableConstraintScan (..)+  , ConstraintProgramAccumulator (..)+  , CdtBuildResult (..)+  ) where++import Control.DeepSeq (NFData)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Vector as V+import Data.Primitive.PrimArray (PrimArray)+import Data.Word (Word32)+import Moonlight.Triangulation.Handles.HandleDefs+  ( DirectedEdgeId+  , FaceId+  , UndirectedEdgeId+  , VertexId+  )+import Moonlight.Triangulation.Internal.Growable (GrowableWord32)+import Moonlight.Triangulation.Internal.Representation (Triangulation)+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.IntersectionIterator (Intersection)+import GHC.Generics (Generic)++-- | Typed refusal surface for constrained construction and corridor recovery.+data CdtError+  = CdtBuildError !BuildError+  | InvalidConstraintVertex !VertexId+  | ConstraintIntersection !UndirectedEdgeId+  | ConstraintInputConflicts !(V.Vector (Int, Int))+  | ConstraintCorridorObstructed !CorridorObstruction+  | ConstraintBatchCardinalityMismatch+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+  | ConstraintEndpointIndexOutOfRange+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+  | ConstraintSplitBudgetExhausted+      !VertexId+      !VertexId+      {-# UNPACK #-} !Int+  | ConstraintSplitIntersectionIndeterminate+      !DirectedEdgeId+  | ConstraintEdgeIndexOutOfRange+      !UndirectedEdgeId+      {-# UNPACK #-} !Int+  | ConstraintRecoverySafetyBudgetExhausted+      !VertexId+      !VertexId+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+  | ConstraintRecoveryStripExhausted+      !VertexId+      !VertexId+      {-# UNPACK #-} !Int+  | ConstraintRecoveryStripUnflippable+      !VertexId+      !VertexId+      !DirectedEdgeId+      {-# UNPACK #-} !Int+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Geometric identity of one constraint segment. The constructor is private:+-- endpoints are always canonical points in ascending order, so direction and+-- edge numbering cannot leak into union witnesses.+data CanonicalSegment = CanonicalSegment+  { -- | Lesser endpoint under the point ordering.+    segmentStart :: !(Point)+  , -- | Greater endpoint under the point ordering.+    segmentEnd :: !(Point)+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A pair of properly crossing constraints, ordered independently of operand+-- and traversal order.+data ConstraintConflict = ConstraintConflict+  { -- | Lesser segment under the canonical segment ordering.+    conflictFirstSegment :: !(CanonicalSegment)+  , -- | Greater segment under the canonical segment ordering.+    conflictSecondSegment :: !(CanonicalSegment)+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Complete obstruction surface for atomic constrained union.+data ConstrainedUnionError+  = ConstraintUnionConflicts !(NonEmpty (ConstraintConflict))+  | ConstraintUnionConstructionFailed !(CdtError)+  | ConstraintUnionSiteMissing !(Point)+  | ConstraintUnionNotSeparated+  | ConstraintUnionSourceFaceNotTriangular+      !ConstrainedSeamSource+      !FaceId+      {-# UNPACK #-} !Int+  | ConstraintUnionTargetFaceNotTriangular+      !FaceId+      {-# UNPACK #-} !Int+  | ConstraintUnionTargetFaceAmbiguous !FaceId !FaceId+  | ConstraintUnionSourceFaceNotPreserved+      !ConstrainedSeamSource+      !FaceId+  | ConstraintUnionSourceConstraintNotPreserved+      !ConstrainedSeamSource+      !(CanonicalSegment)+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Operand identity in a separated constrained seam. This belongs in the+-- obstruction and receipt vocabulary rather than being encoded as a Boolean;+-- callers must handle both source sections explicitly.+data ConstrainedSeamSource+  = ConstrainedSeamLeftSource+  | ConstrainedSeamRightSource+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Exact proof that one active source face survives as one target face. The+-- three points are stored in ascending order, so the witness is independent+-- of local face rotation and handle numbering.+data ConstrainedSeamFaceEvidence = ConstrainedSeamFaceEvidence+  { constrainedSeamSourceFace :: !FaceId+  , constrainedSeamTargetFace :: !FaceId+  , constrainedSeamFaceFirstPoint :: !(Point)+  , constrainedSeamFaceSecondPoint :: !(Point)+  , constrainedSeamFaceThirdPoint :: !(Point)+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Exact transport of one source constraint segment. 'Nothing' means its+-- copied constraint edge already represented the segment after zippering;+-- 'Just' records the corridor outcome when recovery was required.+data ConstrainedSeamConstraintEvidence = ConstrainedSeamConstraintEvidence+  { constrainedSeamConstraintSegment :: !(CanonicalSegment)+  , constrainedSeamConstraintRecovery :: !(Maybe ConstraintOutcome)+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Atomic publication of a source-preserving constrained seam and the proof+-- needed to transport solved face-indexed data. The receipt is derived only+-- after canonical publication and exact source restriction checks succeed.+data ConstrainedSeamResult vertex = ConstrainedSeamResult+  { constrainedSeamResultTriangulation+      :: !(Triangulation 'Constrained vertex () () ())+  , constrainedSeamLeftFaceEvidence+      :: !(V.Vector (ConstrainedSeamFaceEvidence))+  , constrainedSeamRightFaceEvidence+      :: !(V.Vector (ConstrainedSeamFaceEvidence))+  , constrainedSeamNewFaces :: !(V.Vector FaceId)+  , constrainedSeamLeftConstraintEvidence+      :: !(V.Vector (ConstrainedSeamConstraintEvidence))+  , constrainedSeamRightConstraintEvidence+      :: !(V.Vector (ConstrainedSeamConstraintEvidence))+  , constrainedSeamConstraintStats :: !ConstraintBatchStats+  , constrainedSeamBuildStats :: !BuildStats+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++deriving stock instance Eq vertex => Eq (ConstrainedSeamResult vertex)+deriving stock instance Show vertex => Show (ConstrainedSeamResult vertex)++-- | Structural witness that corridor recovery could not complete.+data CorridorObstruction+  = CorridorWalkDidNotTerminate {-# UNPACK #-} !Int+  | CorridorBoundaryMissing !VertexId !VertexId+  | CorridorProgramMalformed {-# UNPACK #-} !Int+  | CorridorTargetMissing !VertexId !VertexId+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++data ConstraintResult vertex directed undirected face = ConstraintResult+  { constraintTriangulation :: !(Triangulation 'Constrained vertex directed undirected face)+  , constraintPath :: !(V.Vector DirectedEdgeId)+  , constraintAddedEdges :: {-# UNPACK #-} !Int+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++deriving stock instance+  (Eq vertex, Eq directed, Eq undirected, Eq face)+  => Eq (ConstraintResult vertex directed undirected face)+deriving stock instance+  (Show vertex, Show directed, Show undirected, Show face)+  => Show (ConstraintResult vertex directed undirected face)++data ConstraintOutcome+  = ConstraintAccepted+      !(V.Vector DirectedEdgeId)+      {-# UNPACK #-} !Int+  | ConstraintRejected+      !UndirectedEdgeId+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++data ConstraintBatchStats = ConstraintBatchStats+  { constraintBatchRequests :: {-# UNPACK #-} !Int+  , constraintBatchAccepted :: {-# UNPACK #-} !Int+  , constraintBatchRejected :: {-# UNPACK #-} !Int+  , constraintBatchCorridors :: {-# UNPACK #-} !Int+  , constraintBatchReusedFaces :: {-# UNPACK #-} !Int+  , constraintBatchCrossedEdges :: {-# UNPACK #-} !Int+  }+  deriving stock (Eq, Show, Read, Generic)+  deriving anyclass (NFData)++data ConstraintBatchResult vertex directed undirected face = ConstraintBatchResult+  { constraintBatchTriangulation :: !(Triangulation 'Constrained vertex directed undirected face)+  , constraintBatchOutcomes :: !(V.Vector ConstraintOutcome)+  , constraintBatchStats :: !ConstraintBatchStats+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++deriving stock instance+  (Eq vertex, Eq directed, Eq undirected, Eq face)+  => Eq (ConstraintBatchResult vertex directed undirected face)+deriving stock instance+  (Show vertex, Show directed, Show undirected, Show face)+  => Show (ConstraintBatchResult vertex directed undirected face)++-- | Receipt of one asymmetric constrained extension. The triangulation and+-- all telemetry arise from the same sealed transaction: base sites were+-- resident, incoming sites were inserted, and only incoming constraints were+-- interpreted. A later refinement is deliberately a separate operation over+-- this immutable result, not a hidden continuation of this transaction.+data ConstrainedExtensionResult vertex directed undirected face = ConstrainedExtensionResult+  { constrainedExtensionTriangulation :: !(Triangulation 'Constrained vertex directed undirected face)+  , constrainedExtensionConstraintOutcomes :: !(V.Vector ConstraintOutcome)+  , constrainedExtensionConstraintStats :: !ConstraintBatchStats+  , constrainedExtensionBuildStats :: !BuildStats+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++deriving stock instance+  (Eq vertex, Eq directed, Eq undirected, Eq face)+  => Eq (ConstrainedExtensionResult vertex directed undirected face)+deriving stock instance+  (Show vertex, Show directed, Show undirected, Show face)+  => Show (ConstrainedExtensionResult vertex directed undirected face)++-- | One published mesh carrying every requested division. The paths are+-- per-request receipts in traversal order; a later request may have rewritten+-- topology an earlier path names, which is the same as-traversed reading the+-- singleton path already carries.+data ConstraintSplitBatchResult vertex directed undirected face = ConstraintSplitBatchResult+  { splitBatchTriangulation :: !(Triangulation 'Constrained vertex directed undirected face)+  , splitBatchPaths :: !(V.Vector (V.Vector DirectedEdgeId))+  , splitBatchAddedEdges :: {-# UNPACK #-} !Int+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++deriving stock instance+  (Eq vertex, Eq directed, Eq undirected, Eq face)+  => Eq (ConstraintSplitBatchResult vertex directed undirected face)+deriving stock instance+  (Show vertex, Show directed, Show undirected, Show face)+  => Show (ConstraintSplitBatchResult vertex directed undirected face)++data ConstraintBatchAccumulator = ConstraintBatchAccumulator+  { accumulatedConstraintOutcomes :: ![ConstraintOutcome]+  , accumulatedConstraintStats :: !ConstraintBatchStats+  }++data ConstraintRequestAccumulator = ConstraintRequestAccumulator+  { accumulatedRequestPath :: ![DirectedEdgeId]+  , accumulatedRequestAddedEdges :: {-# UNPACK #-} !Int+  , accumulatedRequestCorridors :: {-# UNPACK #-} !Int+  , accumulatedRequestReusedFaces :: {-# UNPACK #-} !Int+  , accumulatedRequestCrossedEdges :: {-# UNPACK #-} !Int+  }++data ConstraintWorkspace s = ConstraintWorkspace+  { constraintProgramWords :: !(GrowableWord32 s)+  , constraintWalkBudget :: {-# UNPACK #-} !Int+  }++data MutableConstraintProgram = MutableConstraintProgram+  { mutableProgramWordCount :: {-# UNPACK #-} !Int+  , mutableProgramPieceCount :: {-# UNPACK #-} !Int+  }++-- | What one request did to the thawed mesh. A rejection is a value: the batch+-- interpreter records it and carries on, the singleton verbs abandon the+-- transaction on it, and both readings are lawful because an accepted request+-- may lawfully obstruct a later one.+data MutableConstraintOutcome+  = MutableConstraintRejected !UndirectedEdgeId+  | MutableConstraintAccepted !ConstraintRequestAccumulator++data MutableProgramCursor = MutableProgramCursor+  { mutableCursorAt :: !VertexId+  , mutableCursorHeader :: {-# UNPACK #-} !Int+  , mutableCursorWriteAt :: {-# UNPACK #-} !Int+  , mutableCursorConflictCount :: {-# UNPACK #-} !Int+  , mutableCursorPieceCount :: {-# UNPACK #-} !Int+  , mutableCursorAfterOverlap :: !Bool+  }++data MutablePlanWalk+  = MutablePlanActive !Intersection !MutableProgramCursor+  | MutablePlanComplete !MutableConstraintProgram+  | MutablePlanBlocked !DirectedEdgeId+  | MutablePlanFailed !CorridorObstruction++data MutableConstraintScan+  = MutableConstraintScanBlocked !DirectedEdgeId+  | MutableConstraintScanAdmitted !MutableConstraintProgram++data ConstraintProgramAccumulator = ConstraintProgramAccumulator+  { accumulatedProgramCursor :: {-# UNPACK #-} !Int+  , accumulatedProgramRequest :: !ConstraintRequestAccumulator+  }++data CdtBuildResult vertex directed undirected face = CdtBuildResult+  { cdtBuildTriangulation :: !(Triangulation 'Constrained vertex directed undirected face)+  , cdtBuildInputVertices :: !(PrimArray Word32)+  , cdtBuildStats :: !BuildStats+  , cdtRejectedConstraints :: !(V.Vector (Int, Int))+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++deriving stock instance+  (Eq vertex, Eq directed, Eq undirected, Eq face)+  => Eq (CdtBuildResult vertex directed undirected face)+deriving stock instance+  (Show vertex, Show directed, Show undirected, Show face)+  => Show (CdtBuildResult vertex directed undirected face)
+ src-build/Moonlight/Triangulation/Internal/Cdt/Union.hs view
@@ -0,0 +1,540 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Canonical constraint segments and the atomic partial union of two+-- constrained meshes, retaining or combining their site annotations.+module Moonlight.Triangulation.Internal.Cdt.Union+  ( canonicalSegment+  , constraintSegments+  , unionConstrainedWith+  , unionConstrained+  , joinSeparatedConstrainedWith+  , extendConstrainedWith+  , segmentRequest+  , firstRejected+  , completeConstraintConflicts+  , orderedConflict+  , crossingIsRepresented+  ) where++import Control.Monad (foldM)+import Control.Monad.ST (ST)+import Data.Either (isRight)+import Data.List (sort)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Vector as V+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.IntersectionIterator (foldCorridorBetweenPoints)+import Moonlight.Triangulation.Internal.Canonical (canonicalize)+import Moonlight.Triangulation.Insertion (insertPointCombining)+import Moonlight.Triangulation.Internal.Cdt.Batch+  ( interpretConstraintRequests+  , recoverConstraints+  )+import Moonlight.Triangulation.Internal.Cdt.Build (fromDelaunay)+import Moonlight.Triangulation.Internal.Cdt.Combinators (foldWhileM, mapLeft)+import Moonlight.Triangulation.Internal.Cdt.Query (constraintEdges)+import Moonlight.Triangulation.Internal.Cdt.Types+import Moonlight.Triangulation.Internal.Join.Rebuild (rebuildCanonicalSiteSet)+import Moonlight.Triangulation.Internal.Join.Seam+  ( executeConstrainedSeam+  , planSeam+  , seamExecutionBuildStats+  , seamExecutionTriangulation+  )+import Moonlight.Triangulation.Internal.Join.SiteSet+  ( SiteSet+  , siteSetAssocs+  , siteSetFromTriangulation+  , siteSetPoints+  , siteSetSize+  , siteSetUnionWith+  )+import Moonlight.Triangulation.Internal.Paged (TransactionShape (DenseTransaction, LocalTransaction))+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Mutable (MutableDcel)+import Moonlight.Triangulation.Internal.OperationState (OperationState)+import Moonlight.Triangulation.Internal.Transaction (runTransaction)+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Math++canonicalSegment :: Point -> Point -> CanonicalSegment+canonicalSegment from to+  | from <= to = CanonicalSegment from to+  | otherwise = CanonicalSegment to from+{-# INLINE canonicalSegment #-}++-- | Geometry of the constraint section, deduplicated and canonically ordered.+constraintSegments+  :: Triangulation 'Constrained vertex directed undirected face+  -> V.Vector (CanonicalSegment)+constraintSegments triangulation =+  V.fromList+    ( Set.toAscList+        ( Set.fromList+            [ canonicalSegment+                (Dcel.vertexPoint triangulation from)+                (Dcel.vertexPoint triangulation to)+            | edge <- constraintEdges triangulation+            , let (from, to) = Dcel.undirectedEndpoints triangulation edge+            ]+        )+    )++-- | Atomic partial union of constrained meshes. Coincident sites combine+-- their annotations before construction. Complete canonical conflict+-- witnesses descend first; a successful branch then reaches the existing+-- batch corridor interpreter exactly once.+unionConstrainedWith+  :: (annotation -> annotation -> annotation)+  -> Triangulation 'Constrained annotation () () ()+  -> Triangulation 'Constrained annotation () () ()+  -> Either+      (ConstrainedUnionError)+      (Triangulation 'Constrained annotation () () ())+unionConstrainedWith combine left right =+  case NonEmpty.nonEmpty (Set.toAscList conflicts) of+    Just witnesses -> Left (ConstraintUnionConflicts witnesses)+    Nothing -> do+      unconstrained <-+        mapLeft+          (ConstraintUnionConstructionFailed . CdtBuildError)+          (rebuildCanonicalSiteSet unionSites)+      requests <- traverse (segmentRequest unconstrained) (V.toList segments)+      recovered <-+        mapLeft ConstraintUnionConstructionFailed+          (recoverConstraints (fromDelaunay unconstrained) (V.fromList requests))+      case firstRejected (constraintBatchOutcomes recovered) of+        Just blocking ->+          Left+            ( ConstraintUnionConstructionFailed+                (ConstraintIntersection blocking)+            )+        Nothing ->+          mapLeft+            (ConstraintUnionConstructionFailed . CdtBuildError)+            (canonicalize (constraintBatchTriangulation recovered))+ where+  leftSites = siteSetFromTriangulation left+  rightSites = siteSetFromTriangulation right+  unionSites = siteSetUnionWith combine leftSites rightSites+  segments =+    V.fromList+      ( Set.toAscList+          ( Set.union+              (Set.fromList (V.toList (constraintSegments left)))+              (Set.fromList (V.toList (constraintSegments right)))+          )+      )+  conflicts = completeConstraintConflicts unionSites segments+{-# INLINE unionConstrainedWith #-}++-- | Atomic partial union specialized to geometry-only constrained meshes.+unionConstrained+  :: Triangulation 'Constrained () () () ()+  -> Triangulation 'Constrained () () () ()+  -> Either+      (ConstrainedUnionError)+      (Triangulation 'Constrained () () () ())+unionConstrained = unionConstrainedWith (\_ _ -> ())+{-# INLINE unionConstrained #-}++-- | Join two strictly separated constrained triangulations by copying both+-- source meshes and zippering only their common tangent corridor. The source+-- constraint planes are present during legalization, so contour edges are+-- immutable barriers rather than edges recovery tries to resurrect after a+-- solved face has already disappeared.+--+-- The annotation combiner is intentionally not evaluated: strict x-separation+-- proves that the two site sets have no coincident point. It remains in the+-- signature so this operation composes at the same annotation boundary as the+-- other constrained joins without inventing a geometry-only facade.+joinSeparatedConstrainedWith+  :: (annotation -> annotation -> annotation)+  -> Triangulation 'Constrained annotation () () ()+  -> Triangulation 'Constrained annotation () () ()+  -> Either+      (ConstrainedUnionError)+      (ConstrainedSeamResult annotation)+joinSeparatedConstrainedWith _combine left right = do+  seamPlan <- maybe (Left ConstraintUnionNotSeparated) Right (planSeam left right)+  seamExecution <-+    mapLeft+      (ConstraintUnionConstructionFailed . CdtBuildError)+      (executeConstrainedSeam seamPlan left right)+  let copied = seamExecutionTriangulation seamExecution+      leftSegments = constraintSegments left+      rightSegments = constraintSegments right+      copiedSegments = Set.fromList (V.toList (constraintSegments copied))+      missingSegments =+        V.filter (`Set.notMember` copiedSegments) (leftSegments V.++ rightSegments)+  requests <- traverse (segmentRequest copied) (V.toList missingSegments)+  recovered <-+    mapLeft ConstraintUnionConstructionFailed+      (recoverConstraints copied (V.fromList requests))+  case firstRejected (constraintBatchOutcomes recovered) of+    Just blocking ->+      Left+        ( ConstraintUnionConstructionFailed+            (ConstraintIntersection blocking)+        )+    Nothing -> do+      published <-+        mapLeft+          (ConstraintUnionConstructionFailed . CdtBuildError)+          (canonicalize (constraintBatchTriangulation recovered))+      targetFaces <- targetFaceIndex published+      leftFaces <-+        sourceFaceEvidence+          ConstrainedSeamLeftSource+          left+          targetFaces+      rightFaces <-+        sourceFaceEvidence+          ConstrainedSeamRightSource+          right+          targetFaces+      let preservedTargets =+            Set.fromList+              ( fmap constrainedSeamTargetFace (V.toList leftFaces)+                  <> fmap constrainedSeamTargetFace (V.toList rightFaces)+              )+          newFaces =+            V.fromList+              ( filter+                  (`Set.notMember` preservedTargets)+                  (innerFaceIds published)+              )+          recoveredOutcomes =+            Map.fromList+              (V.toList (V.zip missingSegments (constraintBatchOutcomes recovered)))+          finalSegments = Set.fromList (V.toList (constraintSegments published))+      leftConstraintEvidence <-+        sourceConstraintEvidence+          ConstrainedSeamLeftSource+          finalSegments+          recoveredOutcomes+          leftSegments+      rightConstraintEvidence <-+        sourceConstraintEvidence+          ConstrainedSeamRightSource+          finalSegments+          recoveredOutcomes+          rightSegments+      pure+        ConstrainedSeamResult+          { constrainedSeamResultTriangulation = published+          , constrainedSeamLeftFaceEvidence = leftFaces+          , constrainedSeamRightFaceEvidence = rightFaces+          , constrainedSeamNewFaces = newFaces+          , constrainedSeamLeftConstraintEvidence = leftConstraintEvidence+          , constrainedSeamRightConstraintEvidence = rightConstraintEvidence+          , constrainedSeamConstraintStats = constraintBatchStats recovered+          , constrainedSeamBuildStats = seamExecutionBuildStats seamExecution+          }++data CanonicalFaceKey = CanonicalFaceKey+  !(Point)+  !(Point)+  !(Point)+  deriving stock (Eq, Ord)++targetFaceIndex+  :: Triangulation mode vertex directed undirected face+  -> Either+      (ConstrainedUnionError)+      (Map.Map CanonicalFaceKey FaceId)+targetFaceIndex triangulation =+  foldM insertTarget Map.empty (innerFaceIds triangulation)+ where+  insertTarget+    :: Map.Map CanonicalFaceKey FaceId+    -> FaceId+    -> Either (ConstrainedUnionError) (Map.Map CanonicalFaceKey FaceId)+  insertTarget index face = do+    key <- targetFaceKey triangulation face+    case Map.lookup key index of+      Just existing -> Left (ConstraintUnionTargetFaceAmbiguous existing face)+      Nothing -> Right (Map.insert key face index)++sourceFaceEvidence+  :: ConstrainedSeamSource+  -> Triangulation mode vertex directed undirected face+  -> Map.Map CanonicalFaceKey FaceId+  -> Either+      (ConstrainedUnionError)+      (V.Vector (ConstrainedSeamFaceEvidence))+sourceFaceEvidence source triangulation targetFaces =+  V.fromList <$> traverse evidenceFor (innerFaceIds triangulation)+ where+  evidenceFor sourceFace = do+    key@(CanonicalFaceKey first second third) <-+      sourceFaceKey source triangulation sourceFace+    targetFace <-+      maybe+        (Left (ConstraintUnionSourceFaceNotPreserved source sourceFace))+        Right+        (Map.lookup key targetFaces)+    pure+      ConstrainedSeamFaceEvidence+        { constrainedSeamSourceFace = sourceFace+        , constrainedSeamTargetFace = targetFace+        , constrainedSeamFaceFirstPoint = first+        , constrainedSeamFaceSecondPoint = second+        , constrainedSeamFaceThirdPoint = third+        }++sourceConstraintEvidence+  :: ConstrainedSeamSource+  -> Set.Set (CanonicalSegment)+  -> Map.Map (CanonicalSegment) ConstraintOutcome+  -> V.Vector (CanonicalSegment)+  -> Either+      (ConstrainedUnionError)+      (V.Vector (ConstrainedSeamConstraintEvidence))+sourceConstraintEvidence source finalSegments recovered =+  traverse+    (\segment ->+       if Set.member segment finalSegments+         then+           Right+             ConstrainedSeamConstraintEvidence+               { constrainedSeamConstraintSegment = segment+               , constrainedSeamConstraintRecovery = Map.lookup segment recovered+               }+         else Left (ConstraintUnionSourceConstraintNotPreserved source segment)+    )++sourceFaceKey+  :: ConstrainedSeamSource+  -> Triangulation mode vertex directed undirected face+  -> FaceId+  -> Either (ConstrainedUnionError) CanonicalFaceKey+sourceFaceKey source triangulation face =+  case sort (fmap (Dcel.vertexPoint triangulation) (Dcel.faceVertices triangulation face)) of+    [first, second, third] -> Right (CanonicalFaceKey first second third)+    points ->+      Left+        ( ConstraintUnionSourceFaceNotTriangular+            source+            face+            (length points)+        )++targetFaceKey+  :: Triangulation mode vertex directed undirected face+  -> FaceId+  -> Either (ConstrainedUnionError) CanonicalFaceKey+targetFaceKey triangulation face =+  case sort (fmap (Dcel.vertexPoint triangulation) (Dcel.faceVertices triangulation face)) of+    [first, second, third] -> Right (CanonicalFaceKey first second third)+    points -> Left (ConstraintUnionTargetFaceNotTriangular face (length points))++innerFaceIds+  :: Triangulation mode vertex directed undirected face+  -> [FaceId]+innerFaceIds triangulation =+  fmap (FaceId . fromIntegral) [1 .. Dcel.numFaces triangulation - 1]++-- | Extend one already-resident constrained triangulation with one new+-- constrained section. This is intentionally asymmetric: the base mesh is+-- thawed once, extension sites are inserted into it, and only the extension's+-- constraint section is replayed. Unlike 'unionConstrainedWith', it neither+-- rebuilds a canonical site set nor replays base constraints, because both+-- would erase the physical distinction between solved base and new work.+--+-- Incoming constraint recovery is itself the spatial conflict authority. It+-- walks only the incoming corridors against the resident base and returns a+-- typed intersection obstruction. Re-running the canonical all-pairs union+-- preflight here would make a tiny extension quadratic in the base. Any+-- structural or recovery obstruction abandons the transaction before a+-- partially extended mesh can be published.+extendConstrainedWith+  :: (annotation -> annotation -> annotation)+  -> Triangulation 'Constrained annotation () () ()+  -> Triangulation 'Constrained annotation () () ()+  -> Either+      (ConstrainedUnionError)+      (ConstrainedExtensionResult annotation () () ())+extendConstrainedWith combine base extension = do+    (completed, extended, buildStats) <-+      runTransaction+        (ConstraintUnionConstructionFailed . CdtBuildError)+        transactionShape+        base+        (siteSetSize extensionSites)+        (insertAndRecoverExtension combine extensionSites extensionSegments)+    pure+      ConstrainedExtensionResult+        { constrainedExtensionTriangulation = extended+        , constrainedExtensionConstraintOutcomes = accumulatorOutcomes completed+        , constrainedExtensionConstraintStats = accumulatedConstraintStats completed+        , constrainedExtensionBuildStats = buildStats+        }+ where+  extensionSites = siteSetFromTriangulation extension+  extensionSegments = constraintSegments extension+  transactionShape =+    case V.uncons extensionSegments of+      Just (segment, remaining)+        | Dcel.numVertices base >= 200000+        , siteSetSize extensionSites <= 128+        , V.null remaining+        , residentCorridorIsEmpty segment -> LocalTransaction+      _ -> DenseTransaction+  residentCorridorIsEmpty segment =+    case (mkQueryPoint (segmentStart segment), mkQueryPoint (segmentEnd segment)) of+      (Right from, Right to) ->+        foldCorridorBetweenPoints base from to (\_ _ -> Left ()) () == Just (Right ())+      _ -> False+{-# INLINE extendConstrainedWith #-}++insertAndRecoverExtension+  :: (annotation -> annotation -> annotation)+  -> SiteSet annotation+  -> V.Vector (CanonicalSegment)+  -> MutableDcel s annotation () () ()+  -> OperationState s+  -> ST s (Either (ConstrainedUnionError) ConstraintBatchAccumulator)+insertAndRecoverExtension combine extensionSites extensionSegments mutable operation = do+  placed <- insertExtensionSites combine extensionSites mutable operation+  case placed of+    Left obstruction -> pure (Left obstruction)+    Right handles ->+      case traverse (segmentRequestFromHandles handles) (V.toList extensionSegments) of+        Left obstruction -> pure (Left obstruction)+        Right requests -> do+          interpreted <-+            fmap+              (mapLeft ConstraintUnionConstructionFailed)+              (interpretConstraintRequests (V.fromList requests) mutable operation)+          case interpreted of+            Left obstruction -> pure (Left obstruction)+            Right completed ->+              case firstRejected (accumulatorOutcomes completed) of+                Just blocking ->+                  pure+                    ( Left+                        ( ConstraintUnionConstructionFailed+                            (ConstraintIntersection blocking)+                        )+                    )+                Nothing -> pure (Right completed)++insertExtensionSites+  :: forall s annotation+   . (annotation -> annotation -> annotation)+  -> SiteSet annotation+  -> MutableDcel s annotation () () ()+  -> OperationState s+  -> ST s (Either (ConstrainedUnionError) (Map.Map (Point) VertexId))+insertExtensionSites combine extensionSites mutable operation =+  fmap+    (fmap (Map.fromDistinctAscList . reverse))+    ( foldWhileM+        isRight+        insertOne+        (Right [])+        (siteSetAssocs extensionSites)+    )+ where+  insertOne+    :: Either (ConstrainedUnionError) [(Point, VertexId)]+    -> (Point, annotation)+    -> ST s (Either (ConstrainedUnionError) [(Point, VertexId)])+  insertOne rejected@(Left _) _ = pure rejected+  insertOne (Right accumulated) (point, annotation) =+    fmap+      ( mapLeft (ConstraintUnionConstructionFailed . CdtBuildError)+          . fmap+            (\(vertex, _) -> (point, VertexId (fromIntegral vertex)) : accumulated)+      )+      (insertPointCombining combine Nothing mutable operation point annotation)++accumulatorOutcomes :: ConstraintBatchAccumulator -> V.Vector ConstraintOutcome+accumulatorOutcomes = V.fromList . reverse . accumulatedConstraintOutcomes+{-# INLINE accumulatorOutcomes #-}++segmentRequest+  :: Triangulation mode annotation () () ()+  -> CanonicalSegment+  -> Either (ConstrainedUnionError) (VertexId, VertexId)+segmentRequest triangulation segment =+  segmentRequestFromHandles handles segment+ where+  handles =+    Map.fromList+      [ ( Dcel.vertexPoint triangulation vertex+        , vertex+        )+      | raw <- [0 .. Dcel.numVertices triangulation - 1]+      , let vertex = VertexId (fromIntegral raw)+      ]++segmentRequestFromHandles+  :: Map.Map (Point) VertexId+  -> CanonicalSegment+  -> Either (ConstrainedUnionError) (VertexId, VertexId)+segmentRequestFromHandles handles segment =+  case+      ( Map.lookup (segmentStart segment) handles+      , Map.lookup (segmentEnd segment) handles+      ) of+    (Just from, Just to) -> Right (from, to)+    (Nothing, _) -> Left (ConstraintUnionSiteMissing (segmentStart segment))+    (_, Nothing) -> Left (ConstraintUnionSiteMissing (segmentEnd segment))++firstRejected :: V.Vector ConstraintOutcome -> Maybe UndirectedEdgeId+firstRejected =+  V.foldr+    (\outcome later ->+       case outcome of+         ConstraintAccepted _ _ -> later+         ConstraintRejected blocking -> Just blocking+    )+    Nothing++completeConstraintConflicts+  :: SiteSet annotation+  -> V.Vector (CanonicalSegment)+  -> Set.Set (ConstraintConflict)+completeConstraintConflicts unionSites segments =+  Set.fromList+    [ orderedConflict leftSegment rightSegment+    | leftIndex <- [0 .. V.length segments - 1]+    , rightIndex <- [leftIndex + 1 .. V.length segments - 1]+    , let leftSegment = segments V.! leftIndex+    , let rightSegment = segments V.! rightIndex+    , segmentsProperlyCross+        (segmentStart leftSegment)+        (segmentEnd leftSegment)+        (segmentStart rightSegment)+        (segmentEnd rightSegment)+    , not (crossingIsRepresented unionSites leftSegment rightSegment)+    ]++orderedConflict+  :: CanonicalSegment+  -> CanonicalSegment+  -> ConstraintConflict+orderedConflict left right+  | left <= right = ConstraintConflict left right+  | otherwise = ConstraintConflict right left++crossingIsRepresented+  :: SiteSet annotation+  -> CanonicalSegment+  -> CanonicalSegment+  -> Bool+crossingIsRepresented sites first second =+  V.any+    (\point ->+       onClosedSegment (segmentStart first) (segmentEnd first) point+         && onClosedSegment (segmentStart second) (segmentEnd second) point+    )+    (siteSetPoints sites)
+ src-build/Moonlight/Triangulation/Internal/CircleSweep.hs view
@@ -0,0 +1,642 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeApplications #-}++module Moonlight.Triangulation.Internal.CircleSweep+  ( circleSweepInsert+  ) where++import Control.Monad (forM_, when)+import Control.Monad.ST (ST)+import Data.Bits (xor)+import Data.STRef+  ( STRef+  , newSTRef+  , readSTRef+  , writeSTRef+  )+import qualified Data.Vector.Algorithms.Intro as Intro+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32)+import Moonlight.Triangulation.Handles.HandleDefs (DirectedEdgeId (..))+import Moonlight.Triangulation.Insertion (insertExistingVertex)+import Moonlight.Triangulation.Internal.DcelOperations+  ( closeOuterTurn+  , drainLegalization+  , fixHullConvexity+  , insertOutsideHullBetween+  , LegalizationLaw (..)+  , noStarVertex+  , seedGenericEdges+  )+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , maxCounter+  , readScratch+  , writeScratch+  )+import Moonlight.Triangulation.Internal.Probe (Probe (..))+import Moonlight.Triangulation.Scalar (orient2dCoordinates)+import Moonlight.Triangulation.Types (BuildError (..))++-- | The hull is an angular index over the DCEL outer-face cycle. The cycle+-- itself already owns hull adjacency, so left and right walking is+-- 'readPrevious'/'readNext' on the live mesh and this record only caches what+-- topology cannot state: the pseudo-angle of each outer edge's origin and the+-- bucket anchors accelerating the predecessor search. An outer edge's key is+-- its origin's @(angle, x, y)@ with the edge id as the final tie-break; the+-- angle lives in 'hullAngleByEdge' and the coordinates are re-read from the+-- immutable origin only when two cached angles compare exactly equal. Slots+-- of edges that have left the outer cycle are never read again, so the cache+-- needs no invalidation, and there is no second ring beside the authoritative+-- one.+data Hull s = Hull+  { hullCenterX :: {-# UNPACK #-} !Double+  , hullCenterY :: {-# UNPACK #-} !Double+  , hullBucketCapacity :: {-# UNPACK #-} !Int+  , hullAngleByEdge :: !(MUV.MVector s Double)+  , hullActiveCount :: !(MUV.MVector s Int)+  , hullBuckets :: !(STRef s (MUV.MVector s Word32))+  }++readActiveCount :: Hull s -> ST s Int+readActiveCount hull = MUV.unsafeRead (hullActiveCount hull) 0+{-# INLINE readActiveCount #-}++writeActiveCount :: Hull s -> Int -> ST s ()+writeActiveCount hull = MUV.unsafeWrite (hullActiveCount hull) 0+{-# INLINE writeActiveCount #-}++noOuterEdge :: Word32+noOuterEdge = maxBound++-- | Circle sweep over one mutable DCEL, consuming one packed radial arena of+-- @(squaredDistance, x, y, vertex)@ records. The arena is sorted in place and+-- then read directly — no decorated freeze, no undecoration pass. Insertions+-- initially close only acute hull turns. One terminal Graham pass restores+-- full convexity, so construction does not repeatedly pay for global+-- convexity that no intermediate observer can see.+circleSweepInsert+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> MUV.MVector s (Double, Double, Double, Word32)+  -> ST s (Either BuildError Int)+circleSweepInsert mutable operation arena+  | MUV.length arena == 0 = pure (Right 0)+  | otherwise = do+      Intro.sort arena+      let !ordered = MUV.length arena+      seed <- insertSeed 0+      case seed of+        Left failure -> pure (Left failure)+        Right seedCount -> do+          faces <- faceCount mutable+          if faces <= 1 || seedCount >= ordered+            then pure (Right seedCount)+            else do+              (centerX, centerY) <- seedCentre mutable+              builtHull <- buildHull mutable operation centerX centerY+              case builtHull of+                Left failure -> pure (Left failure)+                Right hull -> do+                  skipped <- MUV.new (ordered - seedCount)+                  inserted <- insertRemaining hull ordered seedCount skipped 0 0 0 0+                  case inserted of+                    Left failure -> pure (Left failure)+                    Right (!skippedCount, !fastCount, !flips, !maxDepth) -> do+                      -- The sweep counts its own hull insertions; its drains+                      -- hand their flip and depth tallies up once.+                      addCounter operation CounterHullInsertions fastCount+                      -- The angular candidate leaves a point to the fallback+                      -- whenever it lands right of, or on, the hull edge its+                      -- own angle selected — spade's+                      -- `is_on_right_side_or_on_line` branch, which spade's own+                      -- source calls "very slow". Both counts ride out in+                      -- BuildStats so the split is comparable across the two+                      -- implementations and satisfies+                      -- seed + fast + skipped = unique.+                      --+                      -- CounterSweepFastPoints is NOT CounterHullInsertions+                      -- renamed: the latter is also charged by+                      -- insertOutsideHull, so it counts hull-adjacent+                      -- insertions from either path and dominates this one+                      -- whenever a skipped point lands outside the hull. The+                      -- two coincide only while skipped is zero, and charging+                      -- them independently is what makes the identity a check+                      -- rather than a restatement.+                      addCounter operation CounterSweepFastPoints fastCount+                      addCounter operation CounterSweepSkippedPoints skippedCount+                      addCounter operation CounterEdgeFlips flips+                      maxCounter operation CounterLegalizationMaxStack maxDepth+                      repaired <- fixHullConvexity @'ProbeOff mutable operation+                      case repaired of+                        Left failure -> pure (Left failure)+                        Right (!_closures, !terminalFlips, !terminalMaxDepth) -> do+                          addCounter operation CounterEdgeFlips terminalFlips+                          maxCounter operation CounterLegalizationMaxStack terminalMaxDepth+                          insertedSkipped <- insertSkipped skipped skippedCount 0+                          pure (seedCount <$ insertedSkipped)+ where+  insertSeed !index+    | index >= MUV.length arena = pure (Right index)+    | otherwise = do+        (_, _, _, raw) <- MUV.unsafeRead arena index+        result <- insertExistingVertex @'ProbeOff mutable operation (fromIntegral raw)+        case result of+          Left failure -> pure (Left failure)+          Right () -> do+            faces <- faceCount mutable+            if faces > 1+              then pure (Right (index + 1))+              else insertSeed (index + 1)++  insertRemaining !hull !ordered !index !skipped !skippedCount !fastCount !flips !maxDepth+    | index >= ordered = pure (Right (skippedCount, fastCount, flips, maxDepth))+    | otherwise = do+        (_, queryXWide, queryYWide, raw) <- MUV.unsafeRead arena index+        let !vertex = fromIntegral raw+        queryX <- readPointX mutable vertex+        queryY <- readPointY mutable vertex+        let !queryAngle =+              pseudoAngle (hullCenterX hull) (hullCenterY hull) queryXWide queryYWide+        edge <- hullCandidate mutable hull queryAngle queryXWide queryYWide+        fromVertex <- readOrigin mutable edge+        toVertex <- readOrigin mutable (edge `xor` 1)+        fromX <- readPointX mutable fromVertex+        fromY <- readPointY mutable fromVertex+        toX <- readPointX mutable toVertex+        toY <- readPointY mutable toVertex+        if orient2dCoordinates fromX fromY toX toY queryX queryY == GT+          then do+            deferred <- insertDeferred mutable operation hull edge vertex queryAngle+            case deferred of+              Left failure -> pure (Left failure)+              Right (!_newClosures, !newFlips, !newMaxDepth) ->+                insertRemaining+                  hull+                  ordered+                  (index + 1)+                  skipped+                  skippedCount+                  (fastCount + 1)+                  (flips + newFlips)+                  (max maxDepth newMaxDepth)+          else do+            MUV.unsafeWrite skipped skippedCount raw+            insertRemaining hull ordered (index + 1) skipped (skippedCount + 1) fastCount flips maxDepth++  insertSkipped skipped !count = go+   where+    go !index+      | index >= count = pure (Right ())+      | otherwise = do+          vertex <- fromIntegral <$> MUV.unsafeRead skipped index+          inserted <- insertExistingVertex @'ProbeOff mutable operation vertex+          case inserted of+            Left failure -> pure (Left failure)+            Right () -> go (index + 1)++-- | The hull centre: the centroid of the first inner face, in the widened+-- comparison format, computed exactly as @centroid@ states it.+seedCentre+  :: MutableDcel s vertex directed undirected face+  -> ST s (Double, Double)+seedCentre mutable = do+  (e0, e1, e2) <- faceEdges mutable 1+  o0 <- readOrigin mutable e0+  o1 <- readOrigin mutable e1+  o2 <- readOrigin mutable e2+  x0 <- readPointX mutable o0+  y0 <- readPointY mutable o0+  x1 <- readPointX mutable o1+  y1 <- readPointY mutable o1+  x2 <- readPointX mutable o2+  y2 <- readPointY mutable o2+  pure (x0 + (x1 - x0) / 3 + (x2 - x0) / 3, y0 + (y1 - y0) / 3 + (y2 - y0) / 3)++-- | Index the authoritative outer cycle. The seed fan is star-shaped around+-- the first face's centroid — a collinear chain closed by its apex — so the+-- cycle is already the angular order the predecessor search assumes; what+-- remains is caching each edge's angle and anchoring the buckets.+buildHull+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Double+  -> Double+  -> ST s (Either BuildError (Hull s))+buildHull mutable operation centerX centerY = do+  countResult <- collectOuterEdges mutable operation+  case countResult of+    Left failure -> pure (Left failure)+    Right count+      | count <= 0 -> pure (Left CircleSweepHullEmpty)+      | otherwise -> do+          let !capacity = max (count + 4) (pointCapacity mutable + 8)+          hullAngleByEdge <- MUV.new (halfEdgeCapacity mutable)+          hullActiveCount <- MUV.replicate 1 count+          initialBuckets <- MUV.replicate (initialBucketCount count capacity) noOuterEdge+          hullBuckets <- newSTRef initialBuckets+          let hull =+                Hull+                  { hullCenterX = centerX+                  , hullCenterY = centerY+                  , hullBucketCapacity = capacity+                  , hullAngleByEdge+                  , hullActiveCount+                  , hullBuckets+                  }+          forM_ [0 .. count - 1] $ \index -> do+            edge <- readScratch operation index+            origin <- readOrigin mutable edge+            x <- readPointX mutable origin+            y <- readPointY mutable origin+            MUV.unsafeWrite hullAngleByEdge edge (pseudoAngle centerX centerY x y)+            installBucketMaximum mutable hull edge+          pure (Right hull)++collectOuterEdges+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> ST s (Either BuildError Int)+collectOuterEdges mutable operation = do+  start <- readFaceEdge mutable 0+  if start < 0+    then pure (Right 0)+    else do+      bound <- directedEdgeCount mutable+      go (bound + 1) start start False 0+ where+  go !remaining !start !edge !seen !count+    | remaining <= 0 =+        pure+          ( Left+              ( OuterCycleDidNotTerminate+                  (DirectedEdgeId (fromIntegral start))+                  (DirectedEdgeId (fromIntegral edge))+                  count+              )+          )+    | seen && edge == start = pure (Right count)+    | otherwise = do+        writeScratch operation count edge+        following <- readNext mutable edge+        go (remaining - 1) start following True (count + 1)++initialBucketCount :: Int -> Int -> Int+initialBucketCount active capacity =+  min capacity (nextPowerOfTwo (max 8 ((active + 7) `quot` 8)))++nextPowerOfTwo :: Int -> Int+nextPowerOfTwo requested = go 1+ where+  target = max 1 requested+  go !value+    | value >= target = value+    | value > maxBound `quot` 2 = maxBound+    | otherwise = go (value * 2)++readAngle :: Hull s -> Int -> ST s Double+readAngle hull edge = MUV.unsafeRead (hullAngleByEdge hull) edge+{-# INLINE readAngle #-}++rebuildBuckets :: MutableDcel s vertex directed undirected face -> Hull s -> Int -> ST s ()+rebuildBuckets mutable hull requested = do+  let !count = max 1 (min (hullBucketCapacity hull) requested)+  buckets <- MUV.replicate count noOuterEdge+  writeSTRef (hullBuckets hull) buckets+  active <- readActiveCount hull+  start <- readFaceEdge mutable 0+  let go !remaining !edge+        | remaining <= 0 = pure ()+        | otherwise = do+            installBucketMaximum mutable hull edge+            following <- readNext mutable edge+            go (remaining - 1) following+  when (active > 0 && start >= 0) (go active start)++maybeGrowBuckets :: MutableDcel s vertex directed undirected face -> Hull s -> ST s ()+maybeGrowBuckets mutable hull = do+  active <- readActiveCount hull+  buckets <- readSTRef (hullBuckets hull)+  let !current = MUV.length buckets+  when (active > 8 * current && current < hullBucketCapacity hull) $+    rebuildBuckets mutable hull (min (hullBucketCapacity hull) (2 * current))++bucketFor :: Int -> Double -> Int+bucketFor count angle =+  min (count - 1) (max 0 (floor (angle * fromIntegral count * 0.25)))+{-# INLINE bucketFor #-}++-- | Compare two outer edges by their origins' keys: cached angle first, then+-- the immutable origin coordinates, then the edge id. The coordinate reads+-- only happen on an exact angle tie, which is the same-ray case and no other.+compareEdgeKeys+  :: MutableDcel s vertex directed undirected face+  -> Hull s+  -> Int+  -> Int+  -> ST s Ordering+compareEdgeKeys mutable hull left right = do+  leftAngle <- readAngle hull left+  rightAngle <- readAngle hull right+  case compare leftAngle rightAngle of+    LT -> pure LT+    GT -> pure GT+    EQ -> do+      leftOrigin <- readOrigin mutable left+      rightOrigin <- readOrigin mutable right+      leftX <- readPointX mutable leftOrigin+      rightX <- readPointX mutable rightOrigin+      case compare leftX rightX of+        LT -> pure LT+        GT -> pure GT+        EQ -> do+          leftY <- readPointY mutable leftOrigin+          rightY <- readPointY mutable rightOrigin+          case compare leftY rightY of+            LT -> pure LT+            GT -> pure GT+            EQ -> pure (compare left right)++-- | Whether an outer edge's key orders at or before the stated query key,+-- settled field by field without materializing either key.+edgeAtMost+  :: MutableDcel s vertex directed undirected face+  -> Hull s+  -> Int+  -> Double+  -> Double+  -> Double+  -> Int+  -> ST s Bool+edgeAtMost mutable hull edge queryAngle queryX queryY tie = do+  angle <- readAngle hull edge+  case compare angle queryAngle of+    LT -> pure True+    GT -> pure False+    EQ -> do+      origin <- readOrigin mutable edge+      x <- readPointX mutable origin+      case compare x queryX of+        LT -> pure True+        GT -> pure False+        EQ -> do+          y <- readPointY mutable origin+          case compare y queryY of+            LT -> pure True+            GT -> pure False+            EQ -> pure (edge <= tie)++installBucketMaximum :: MutableDcel s vertex directed undirected face -> Hull s -> Int -> ST s ()+installBucketMaximum mutable hull edge = do+  buckets <- readSTRef (hullBuckets hull)+  angle <- readAngle hull edge+  let !bucket = bucketFor (MUV.length buckets) angle+  currentRaw <- MUV.unsafeRead buckets bucket+  if currentRaw == noOuterEdge+    then MUV.unsafeWrite buckets bucket (fromIntegral edge)+    else do+      verdict <- compareEdgeKeys mutable hull edge (fromIntegral currentRaw)+      when (verdict == GT) (MUV.unsafeWrite buckets bucket (fromIntegral edge))++-- | Drop @edge@ from the bucket index. When it was its bucket's maximum, the+-- cyclic predecessor @left@ stands in provided it still belongs to the same+-- bucket — exact, because a bucket's edges form one contiguous arc of the+-- angular order. The caller states @left@ explicitly: the mesh has already+-- been mutated by the time the index is updated, so the retired edge no+-- longer knows its own neighbour.+removeBucketMaximum :: Hull s -> Int -> Int -> ST s ()+removeBucketMaximum hull edge left = do+  buckets <- readSTRef (hullBuckets hull)+  angle <- readAngle hull edge+  let !bucket = bucketFor (MUV.length buckets) angle+  current <- MUV.unsafeRead buckets bucket+  when (current == fromIntegral edge) $ do+    leftAngle <- readAngle hull left+    if left /= edge && bucketFor (MUV.length buckets) leftAngle == bucket+      then MUV.unsafeWrite buckets bucket (fromIntegral left)+      else MUV.unsafeWrite buckets bucket noOuterEdge++retireEdge :: Hull s -> Int -> Int -> ST s ()+retireEdge hull edge left = do+  removeBucketMaximum hull edge left+  active <- readActiveCount hull+  writeActiveCount hull (active - 1)+{-# INLINE retireEdge #-}++activateEdge :: MutableDcel s vertex directed undirected face -> Hull s -> Int -> ST s ()+activateEdge mutable hull edge = do+  active <- readActiveCount hull+  writeActiveCount hull (active + 1)+  installBucketMaximum mutable hull edge+  maybeGrowBuckets mutable hull++-- | The outer edge whose key is the greatest key at or below the query: the+-- visible candidate the sweep inserts against. Bucket anchors land the walk+-- near the answer and the live outer cycle carries it the rest of the way.+hullCandidate+  :: MutableDcel s vertex directed undirected face+  -> Hull s+  -> Double+  -> Double+  -> Double+  -> ST s Int+hullCandidate mutable hull queryAngle queryX queryY = do+  buckets <- readSTRef (hullBuckets hull)+  let !count = MUV.length buckets+      !bucket = bucketFor count queryAngle+  raw <- MUV.unsafeRead buckets bucket+  if raw == noOuterEdge+    then previousNonEmpty buckets (if bucket == 0 then count - 1 else bucket - 1) count+    else adjustWithinBucket buckets bucket (fromIntegral raw)+ where+  previousNonEmpty buckets !bucket !remaining+    | remaining <= 0 = readFaceEdge mutable 0+    | otherwise = do+        raw <- MUV.unsafeRead buckets bucket+        if raw /= noOuterEdge+          then pure (fromIntegral raw)+          else previousNonEmpty buckets (if bucket == 0 then MUV.length buckets - 1 else bucket - 1) (remaining - 1)++  adjustWithinBucket buckets !bucket !initial = do+    active <- readActiveCount hull+    go active initial+   where+    go !remaining !edge+      | remaining <= 0 = pure initial+      | otherwise = do+          atMost <- edgeAtMost mutable hull edge queryAngle queryX queryY maxBound+          if atMost+            then pure edge+            else do+              left <- readPrevious mutable edge+              leftAngle <- readAngle hull left+              if bucketFor (MUV.length buckets) leftAngle /= bucket+                then pure left+                else go (remaining - 1) left++insertDeferred+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Hull s+  -> Int+  -> Int+  -> Double+  -> ST s (Either BuildError (Int, Int, Int))+insertDeferred mutable operation hull replacedEdge vertex insertedAngle = do+  inserted <- insertOutsideHullBetween @'ProbeOff mutable operation replacedEdge replacedEdge vertex+  case inserted of+    Left failure -> pure (Left failure)+    Right (firstEdge, lastEdge) -> insertDeferredBetween firstEdge lastEdge+ where+  insertDeferredBetween firstEdge lastEdge = do+    -- The patch proves the new keys algebraically, so no key is rediscovered+    -- from the mesh: replacing outer edge a->b with a->v, v->b keeps the+    -- replaced edge's origin for the first spoke (its cached angle carries+    -- over) and starts the last spoke at the inserted vertex, whose angle is the+    -- one the candidate search was already given. The tie-break is each fresh+    -- edge id itself.+    replacedAngle <- readAngle hull replacedEdge+    leftOfReplaced <- readPrevious mutable firstEdge+    retireEdge hull replacedEdge leftOfReplaced+    -- Both spokes join the outer cycle before either is indexed, and a bucket+    -- rebuild during activation walks the live cycle: both angle slots must be+    -- initialized before the first activation can read them.+    MUV.unsafeWrite (hullAngleByEdge hull) firstEdge replacedAngle+    MUV.unsafeWrite (hullAngleByEdge hull) lastEdge insertedAngle+    activateEdge mutable hull firstEdge+    activateEdge mutable hull lastEdge+    -- Every turn this insertion closes legalizes together in one epoch. Closure+    -- never deletes an edge and never touches the outer cycle, so which turns+    -- close does not depend on when the interior is repaired; the fan above+    -- keeps its own drain because its candidates are oriented against the+    -- inserted vertex, and that star must still be intact when they are tested.+    leftOutcome <- closeLeft firstEdge 0 0+    case leftOutcome of+      Left obstruction -> pure (Left obstruction)+      Right (_left, closuresLeft, topLeft) -> do+        rightOutcome <- closeRight lastEdge 0 topLeft+        case rightOutcome of+          Left obstruction -> pure (Left obstruction)+          Right (_right, closuresRight, topAll) -> do+            (flips, maxDepth) <- drainLegalization @'ProbeOff mutable operation topAll noStarVertex ValidMesh+            pure (Right (closuresLeft + closuresRight, flips, maxDepth))++  closeLeft !current !closures !top = do+    left <- readPrevious mutable current+    close <- shouldCloseTurn mutable hull insertedAngle left current+    if not close+      then pure (Right (current, closures, top))+      else do+        leftAngle <- readAngle hull left+        closed <- closeOuterTurn mutable left+        case closed of+          Left obstruction -> pure (Left obstruction)+          Right replacement -> do+            -- Closing consecutive a->b, b->c into a->c keeps the first edge's+            -- origin, so the replacement inherits its angle; the tie is the fresh+            -- edge id. Both retired edges answer to the same left neighbour, the+            -- edge now preceding the replacement on the outer cycle. Seeding+            -- happens here, after the replacement's links exist.+            leftOfReplacement <- readPrevious mutable replacement+            retireEdge hull left leftOfReplacement+            retireEdge hull current leftOfReplacement+            MUV.unsafeWrite (hullAngleByEdge hull) replacement leftAngle+            activateEdge mutable hull replacement+            nextTop <- seedGenericEdges operation top [left, current]+            closeLeft replacement (closures + 1) nextTop++  closeRight !current !closures !top = do+    right <- readNext mutable current+    close <- shouldCloseTurn mutable hull insertedAngle current right+    if not close+      then pure (Right (current, closures, top))+      else do+        currentAngle <- readAngle hull current+        closed <- closeOuterTurn mutable current+        case closed of+          Left obstruction -> pure (Left obstruction)+          Right replacement -> do+            leftOfReplacement <- readPrevious mutable replacement+            retireEdge hull current leftOfReplacement+            retireEdge hull right leftOfReplacement+            MUV.unsafeWrite (hullAngleByEdge hull) replacement currentAngle+            activateEdge mutable hull replacement+            nextTop <- seedGenericEdges operation top [current, right]+            closeRight replacement (closures + 1) nextTop+{-# INLINE insertDeferred #-}++shouldCloseTurn+  :: MutableDcel s vertex directed undirected face+  -> Hull s+  -> Double+  -> Int+  -> Int+  -> ST s Bool+shouldCloseTurn mutable hull insertedAngle first second = do+  following <- readNext mutable first+  if following /= second+    then pure False+    else do+      fromVertex <- readOrigin mutable first+      middleVertex <- readOrigin mutable (first `xor` 1)+      targetVertex <- readOrigin mutable (second `xor` 1)+      fromX <- readPointX mutable fromVertex+      fromY <- readPointY mutable fromVertex+      middleX <- readPointX mutable middleVertex+      middleY <- readPointY mutable middleVertex+      targetX <- readPointX mutable targetVertex+      targetY <- readPointY mutable targetVertex+      if orient2dWide fromX fromY middleX middleY targetX targetY /= GT+        then pure False+        else do+          -- The second edge begins at the middle vertex and stands on the outer+          -- cycle, so its cached key already is that vertex's pseudo-angle;+          -- same-ray is a slot read rather than a second angle.+          middleAngle <- readAngle hull second+          pure+            ( middleAngle == insertedAngle+                || acuteAtMiddle fromX fromY middleX middleY targetX targetY+            )+{-# INLINE shouldCloseTurn #-}++-- The deferred turn test deliberately runs the widened Binary64 predicate+-- rather than the exact binary64 one; only the terminal Graham pass owns exact+-- convexity. This is the class's Double instance called by name, which is+-- what the boxed 'orient2d' on widened points resolved to.+orient2dWide :: Double -> Double -> Double -> Double -> Double -> Double -> Ordering+orient2dWide = orient2dCoordinates+{-# INLINE orient2dWide #-}++-- Spade's deferred-convexity rule is local: close the turn when the angle at+-- the shared hull vertex is strictly below 90 degrees. Requiring the entire+-- triangle to be acute leaves avoidable star-hull work for the terminal pass.+acuteAtMiddle :: Double -> Double -> Double -> Double -> Double -> Double -> Bool+acuteAtMiddle ax ay bx by cx cy =+  let !ux = ax - bx+      !uy = ay - by+      !vx = cx - bx+      !vy = cy - by+      !dot = ux * vx + uy * vy+      !scale = max 1 (ux * ux + uy * uy + vx * vx + vy * vy)+   in dot > 64 * encodeFloat 1 (-52) * scale+{-# INLINE acuteAtMiddle #-}++-- Clockwise pseudo-angle in [0,4), matching the orientation of the outer-face+-- cycle.+pseudoAngle :: Double -> Double -> Double -> Double -> Double+pseudoAngle centerX centerY x y+  | norm == 0 = 0+  | raw >= 4 = 0+  | otherwise = raw+ where+  !dx = x - centerX+  !dy = y - centerY+  !norm = abs dx + abs dy+  !projection = dx / norm+  !raw = if dy > 0 then 1 + projection else 3 - projection+{-# INLINE pseudoAngle #-}
+ src-build/Moonlight/Triangulation/Internal/Excision.hs view
@@ -0,0 +1,502 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Excision of a vertex from a thawed mesh: the removal kernel, stated over+-- the mutable arena and publishing nothing.+module Moonlight.Triangulation.Internal.Excision+  ( RemovalOutcome (..)+  , removeMutable+  ) where++import Control.DeepSeq (NFData)+import Control.Monad (forM, when)+import Control.Monad.ST (ST)+import Data.Bits (xor)+import Data.Foldable (traverse_)+import qualified Data.IntSet as IntSet+import Moonlight.Triangulation.Internal.DcelOperations (flipEdge, legalizeCavityFanScratch, legalizeEdges)+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , readScratch+  , writeScratch+  )+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Math (orient2d)+import GHC.Generics (Generic)++-- | What a single removal produced: the position and payload of the removed+-- vertex, and what swap compaction did — the slot it freed together with the+-- position now standing in it, when it moved anything. All fixed handles are+-- invalidated by removal, so the swap report is the only continuity the mesh+-- offers a caller still holding one.+--+-- Slot and position travel together because they are one fact. A caller told+-- only the slot has to go back to the mesh to learn what landed there, and a+-- caller that reconstructs the position from its own records reconstructs it+-- from something the mesh never stored: the arena holds @canonicalPoint@ of+-- what it was given, so a signed zero would differ in the last bit and every+-- distance tie decided against it would answer a different vertex.+--+-- It is not a location hint. A hint names a face; this names an arena slot,+-- and the vertex that landed in it is the arena's last, which stands wherever+-- it stands. The locator re-anchors on its own cached face, which+-- 'Moonlight.Triangulation.Internal.Mutable.swapRemoveFace' follows through+-- compaction.+data RemovalOutcome vertex = RemovalOutcome+  { removalOutcomePoint :: !(Point)+  , removalOutcomeData :: !vertex+  , removalOutcomeSwap :: !(Maybe (VertexId, Point))+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | The proved outgoing section of one ordinary removal. Its edges live in the+-- operation scratch arena in counter-clockwise order; the record carries only+-- the section's extent and the first outer-face incidence, if any.+data RemovalStar = RemovalStar {-# UNPACK #-} !Int !(Maybe Int)++-- | The swap-compaction primitive reports raw arena indices; the public+-- concept carries the named handle. One conversion, one owner.+removalOutcomeOf+  :: (Point, vertex, Maybe (Int, Point))+  -> RemovalOutcome vertex+removalOutcomeOf (point, payload, swapped) =+  RemovalOutcome+    { removalOutcomePoint = point+    , removalOutcomeData = payload+    , removalOutcomeSwap =+        (\(slot, standing) -> (VertexId (fromIntegral slot), standing)) <$> swapped+    }++removeMutable+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> ST s (Either BuildError (RemovalOutcome vertex))+removeMutable mutable operation vertex = do+  faces <- faceCount mutable+  if faces <= 1+    then fmap removalOutcomeOf <$> removeDegenerate mutable vertex+    else do+      collected <- collectRemovalStar mutable operation vertex+      case collected of+        Left obstruction -> pure (Left obstruction)+        Right (RemovalStar degree outerOutgoing) -> do+          case outerOutgoing of+            Nothing -> fmap removalOutcomeOf <$> removeInterior mutable operation vertex degree+            Just hullEdge -> fmap removalOutcomeOf <$> removeHull mutable operation vertex hullEdge++removeDegenerate+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point)))+removeDegenerate mutable vertex = do+  vertexCount <- pointCount mutable+  case vertexCount of+    0 ->+      pure+        (Left (RemovalEmptyTriangulation (VertexId (fromIntegral vertex))))+    1 -> do+      writeFaceEdge mutable 0 (-1)+      swapRemoveVertex mutable vertex+    2 -> do+      collected <- collectOutgoing mutable vertex+      case collected of+        Left obstruction -> pure (Left obstruction)+        Right outgoing ->+          case outgoing of+            [edge] -> do+              _ <- clearConstraint mutable edge+              removedEdge <- swapRemoveUndirectedEdge mutable (edge `quot` 2)+              case removedEdge of+                Left obstruction -> pure (Left obstruction)+                Right () -> do+                  let !other = if vertex == 0 then 1 else 0+                  writeVertexOut mutable other (-1)+                  writeFaceEdge mutable 0 (-1)+                  swapRemoveVertex mutable vertex+            _ ->+              pure+                ( Left+                    ( RemovalTwoPointDegreeMismatch+                        (VertexId (fromIntegral vertex))+                        (length outgoing)+                    )+                )+    _ -> removeCollinear mutable vertex++removeCollinear+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point)))+removeCollinear mutable vertex = do+  collected <- collectOutgoing mutable vertex+  case collected of+    Left obstruction -> pure (Left obstruction)+    Right outgoing ->+      case outgoing of+        [edge] -> do+          let !reversedEdge = edge `xor` 1+          target <- readOrigin mutable reversedEdge+          edgeNext <- readNext mutable edge+          writePrevious mutable edgeNext (edgeNext `xor` 1)+          writeNext mutable (edgeNext `xor` 1) edgeNext+          writeVertexOut mutable target edgeNext+          writeFaceEdge mutable 0 edgeNext+          _ <- clearConstraint mutable edge+          removedEdge <- swapRemoveUndirectedEdge mutable (edge `quot` 2)+          case removedEdge of+            Left obstruction -> pure (Left obstruction)+            Right () -> swapRemoveVertex mutable vertex+        [edge1, edge2] -> do+          let !t1 = edge1 `xor` 1+              !t1Reverse = edge1+              !t2 = edge2 `xor` 1+          constrained1 <- readConstraint mutable edge1+          constrained2 <- readConstraint mutable edge2+          edge2Next <- readNext mutable edge2+          edge2To <- readOrigin mutable t2+          t2Previous <- readPrevious mutable t2+          if edge2Next == t2+            then do+              writeNext mutable t1 t1Reverse+              writePrevious mutable t1Reverse t1+            else do+              writePrevious mutable edge2Next t1+              writeNext mutable t1 edge2Next+              writeNext mutable t2Previous t1Reverse+              writePrevious mutable t1Reverse t2Previous+          writeVertexOut mutable edge2To t1Reverse+          writeOrigin mutable t1Reverse edge2To+          -- The two segments meeting at the removed vertex are welded into+          -- one, and edge1's slot now spans both. It is neither of them.+          resetEdgeData mutable (edge1 `quot` 2)+          writeFaceEdge mutable 0 t1+          _ <- clearConstraint mutable edge1+          _ <- clearConstraint mutable edge2+          when (constrained1 || constrained2) $ do+            _ <- setConstraint mutable edge1+            pure ()+          removedVertex <- swapRemoveVertex mutable vertex+          case removedVertex of+            Left obstruction -> pure (Left obstruction)+            Right result -> do+              removedEdge <- swapRemoveUndirectedEdge mutable (edge2 `quot` 2)+              pure (result <$ removedEdge)+        _ ->+          pure+            ( Left+                ( RemovalCollinearDegreeMismatch+                    (VertexId (fromIntegral vertex))+                    (length outgoing)+                )+            )++removeInterior+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point)))+removeInterior mutable operation vertex degree = do+  traverse_ recordRing [0 .. degree - 1]+  capacity <- ensureCellCapacity mutable (max 0 (degree - 3)) (max 0 (degree - 2))+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> do+      -- Taken before the fan appends anything, so it separates the fan's own edges+      -- from the cavity border exactly, the way spade's is_new_edge does.+      !cavityFloor <- (`quot` 2) <$> directedEdgeCount mutable+      remeshed <- remeshRingScratch mutable operation degree+      case remeshed of+        Left obstruction -> pure (Left obstruction)+        Right newEdgeCount -> do+          legalizeCavityFanScratch+            mutable+            operation+            cavityFloor+            (3 * degree)+            newEdgeCount+          edgesToRemove <-+            traverse+              (readScratch operation . (degree +))+              [0 .. degree - 1]+          facesToRemove <-+            traverse+              (readScratch operation . (2 * degree +))+              [0 .. degree - 1]+          cleaned <- cleanupEdgesAndFaces mutable edgesToRemove facesToRemove+          case cleaned of+            Left obstruction -> pure (Left obstruction)+            Right () -> swapRemoveVertex mutable vertex+ where+  recordRing index = do+    edge <- readScratch operation index+    following <- readNext mutable edge+    face <- readFace mutable edge+    writeScratch operation index following+    writeScratch operation (degree + index) (edge `quot` 2)+    writeScratch operation (2 * degree + index) face++-- | Fan the cavity a removal leaves. The border arrives in ring order, which is+-- the order the fan consumes it in.+remeshRingScratch+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> ST s (Either BuildError Int)+remeshRingScratch mutable operation degree+  | degree < 3 = pure (Left (RemovalBorderTooShort degree))+  | otherwise = do+      inner0 <- readScratch operation 0+      fanOrigin <- readOrigin mutable inner0+      build fanOrigin 1 inner0 0+ where+  build !fanOrigin !index !innerEdge !newEdgeCount+    | index == degree - 2 = do+      innerNext <- readScratch operation index+      innerPrevious <- readScratch operation (index + 1)+      newFace <- addFace mutable innerEdge+      writeFace mutable innerEdge newFace+      writeFace mutable innerPrevious newFace+      writeFace mutable innerNext newFace+      writeNext mutable innerEdge innerNext+      writePrevious mutable innerNext innerEdge+      writePrevious mutable innerEdge innerPrevious+      writeNext mutable innerPrevious innerEdge+      writePrevious mutable innerPrevious innerNext+      writeNext mutable innerNext innerPrevious+      previousOrigin <- readOrigin mutable innerPrevious+      nextOrigin <- readOrigin mutable innerNext+      writeVertexOut mutable previousOrigin innerPrevious+      writeVertexOut mutable nextOrigin innerNext+      writeVertexOut mutable fanOrigin innerEdge+      pure (Right newEdgeCount)+    | index < degree - 2 = do+      outerEdge <- readScratch operation index+      outerFrom <- readOrigin mutable outerEdge+      outerTo <- readOrigin mutable (outerEdge `xor` 1)+      (newEdge, newTwin) <- addEdge mutable outerTo fanOrigin+      newFace <- addFace mutable newEdge+      writeNext mutable newEdge innerEdge+      writePrevious mutable newEdge outerEdge+      writeFace mutable newEdge newFace+      writeNext mutable newTwin 0+      writePrevious mutable newTwin 0+      writeFace mutable newTwin 0+      writeFace mutable outerEdge newFace+      writeNext mutable outerEdge newEdge+      writePrevious mutable outerEdge innerEdge+      writePrevious mutable innerEdge newEdge+      writeNext mutable innerEdge outerEdge+      writeFace mutable innerEdge newFace+      writeFaceEdge mutable newFace newEdge+      writeVertexOut mutable outerFrom outerEdge+      writeScratch operation (3 * degree + newEdgeCount) newEdge+      build+        fanOrigin+        (index + 1)+        newTwin+        (newEdgeCount + 1)+    | otherwise =+      pure (Left (RemovalBorderArityMismatch (degree - index)))++removeHull :: MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point)))+removeHull mutable operation vertex loopEnd = do+  loopStart <- counterClockwiseMutable mutable loopEnd+  loopEndNext <- readNext mutable loopEnd+  collected <- collectConvexStrip loopEnd loopStart [] []+  case collected of+    Left obstruction -> pure (Left obstruction)+    Right (!convexEdges, !edgesToValidate) -> do+      let !strip = convexEdges ++ [loopEndNext]+      (!edgesToRemove, !facesToRemove) <- disconnectStrip strip+      legalizeEdges mutable operation edgesToValidate+      cleaned <- cleanupEdgesAndFaces mutable edgesToRemove facesToRemove+      case cleaned of+        Left obstruction -> pure (Left obstruction)+        Right () -> swapRemoveVertex mutable vertex+ where+  collectConvexStrip !end !current !convexReversed !validate = do+    nextCurrent <- counterClockwiseMutable mutable current+    edge <- readNext mutable current+    repaired <- repairConvexity (edge : convexReversed) validate+    case repaired of+      Left obstruction -> pure (Left obstruction)+      Right (!repairedReversed, !validate') ->+        if nextCurrent == end+          then pure (Right (reverse repairedReversed, validate'))+          else collectConvexStrip end nextCurrent repairedReversed validate'++  repairConvexity !edgesReversed !validate =+    case edgesReversed of+      edge2 : edge1 : restReversed -> do+        target <- readOrigin mutable (edge2 `xor` 1)+        from <- edgeOriginPoint mutable edge1+        to <- edgeOriginPoint mutable (edge1 `xor` 1)+        targetPoint <- pointAt mutable target+        if orient2d from to targetPoint == GT+          then do+            previousEdge <- readPrevious mutable edge2+            let !toFlip = previousEdge `xor` 1+            rewritten <- flipEdge mutable toFlip+            case rewritten of+              Left obstruction -> pure (Left obstruction)+              Right () -> do+                addCounter operation CounterEdgeFlips 1+                repairConvexity (toFlip : restReversed) (toFlip : validate)+          else pure (Right (edgesReversed, validate))+      _ -> pure (Right (edgesReversed, validate))++  disconnectStrip strip = do+    removed <- forM strip $ \edge -> do+      previousSpoke <- readPrevious mutable edge+      face <- readFace mutable edge+      from <- readOrigin mutable edge+      ccw <- counterClockwiseMutable mutable edge+      predecessor <- readPrevious mutable ccw+      writeNext mutable predecessor edge+      writePrevious mutable edge predecessor+      writeFace mutable edge 0+      writeFaceEdge mutable 0 edge+      writeVertexOut mutable from edge+      pure (previousSpoke `quot` 2, face)+    pure (map fst removed, map snd removed)++cleanupEdgesAndFaces :: MutableDcel s vertex directed undirected face -> [Int] -> [Int] -> ST s (Either BuildError ())+cleanupEdgesAndFaces mutable rawEdges rawFaces = do+  let !edges = sortUniqueDesc rawEdges+      !faces = sortUniqueDesc (filter (> 0) rawFaces)+  removedEdges <- traverseUntilFailure (swapRemoveUndirectedEdge mutable) edges+  case removedEdges of+    Left obstruction -> pure (Left obstruction)+    Right () -> traverseUntilFailure (swapRemoveFace mutable) faces+ where+  traverseUntilFailure+    :: (Int -> ST s (Either BuildError ()))+    -> [Int]+    -> ST s (Either BuildError ())+  traverseUntilFailure action =+    foldr+      ( \item continuation -> do+          outcome <- action item+          case outcome of+            Left obstruction -> pure (Left obstruction)+            Right () -> continuation+      )+      (pure (Right ()))++-- | Descending, deduplicated. Both properties are load-bearing: swap-remove+-- must retire the high index first (a lower index shifts under it), and a+-- duplicated index would be retired twice.+--+-- A removal hands over its vertex's degree, which is small on ordinary meshes+-- and unbounded in the worst case, so the shape is chosen by size. Insertion+-- sort wins outright while the ring is short — measured 6.75 against+-- 8.24 KiB/removal for @IntSet@ on the n=10000 lane — and is quadratic, so a+-- high-degree ring goes to the ordered set that carries the asymptotics.+--+-- The lazy 'foldl' is deliberate: its accumulator is the output structure.+-- 'foldl'' forced each intermediate spine and measured 7.31 versus+-- 6.75 KiB/removal on the same lane.+sortUniqueDesc :: [Int] -> [Int]+sortUniqueDesc values+  | exceedsInsertionRing values = IntSet.toDescList (IntSet.fromList values)+  | otherwise = foldl insertUnique [] values+ where+  insertUnique :: [Int] -> Int -> [Int]+  insertUnique sorted value = go sorted+   where+    go [] = [value]+    go (first : rest) = case compare value first of+      GT -> value : first : rest+      EQ -> first : rest+      LT -> first : go rest++-- | Whether a ring is long enough to owe the ordered set its logarithm,+-- decided without measuring the whole list: the insertion path is chosen by+-- the prefix, never by a full traversal.+exceedsInsertionRing :: [Int] -> Bool+exceedsInsertionRing = not . null . drop insertionRingLimit++insertionRingLimit :: Int+insertionRingLimit = 32++collectRemovalStar+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> ST s (Either BuildError RemovalStar)+collectRemovalStar mutable operation vertex = do+  start <- readVertexOut mutable vertex+  if start < 0+    then pure (Right (RemovalStar 0 Nothing))+    else do+      halfEdges <- directedEdgeCount mutable+      let !budget = halfEdges + 1+          go !remaining !current !seen !degree !outerEdge+            | remaining <= 0 =+                pure+                  ( Left+                      ( RemovalOutgoingCycleDidNotTerminate+                          (VertexId (fromIntegral vertex))+                          (DirectedEdgeId (fromIntegral current))+                          budget+                      )+                  )+            | seen && current == start =+                pure (Right (RemovalStar degree outerEdge))+            | otherwise = do+                writeScratch operation degree current+                face <- readFace mutable current+                _ <- clearConstraint mutable current+                previousEdge <- readPrevious mutable current+                let !nextOuter =+                      case outerEdge of+                        Just edge -> Just edge+                        Nothing+                          | face == 0 -> Just current+                          | otherwise -> Nothing+                go+                  (remaining - 1)+                  (previousEdge `xor` 1)+                  True+                  (degree + 1)+                  nextOuter+      go budget start False 0 Nothing++collectOutgoing+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> ST s (Either BuildError [Int])+collectOutgoing mutable vertex = do+  start <- readVertexOut mutable vertex+  if start < 0+    then pure (Right [])+    else do+      halfEdges <- directedEdgeCount mutable+      let !budget = halfEdges + 1+          go !remaining !current !seen !result+            | remaining <= 0 =+                pure+                  ( Left+                      ( RemovalOutgoingCycleDidNotTerminate+                          (VertexId (fromIntegral vertex))+                          (DirectedEdgeId (fromIntegral current))+                          budget+                      )+                  )+            | seen && current == start = pure (Right (reverse result))+            | otherwise = do+                previousEdge <- readPrevious mutable current+                go (remaining - 1) (previousEdge `xor` 1) True (current : result)+      go budget start False []++counterClockwiseMutable :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+counterClockwiseMutable mutable edge = (`xor` 1) <$> readPrevious mutable edge
+ src-build/Moonlight/Triangulation/Internal/Join.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | The join of two triangulations: a Delaunay representative of the union of+-- their sites.+module Moonlight.Triangulation.Internal.Join+  ( joinNormalForm+  , joinBalanced+  , executeTournamentPlan+  , TournamentPlan (..)+  , planTournament+  ) where++import Data.Foldable (traverse_)+import Data.List.NonEmpty (NonEmpty (..))+import Moonlight.Triangulation.BulkLoad (empty)+import Moonlight.Triangulation.Internal.Join.Plan+  ( PairPlan (..)+  , TournamentPlan (..)+  , planPair+  , planTournament+  )+import Moonlight.Triangulation.Internal.Join.Seam (executeSeam)+import Moonlight.Triangulation.Internal.Join.Rebuild (rebuildCanonicalSiteSet)+import Moonlight.Triangulation.Internal.Join.SiteSet+  ( SiteSet+  , siteSetAssocs+  , siteSetSize+  )+import Moonlight.Triangulation.JoinSemilattice+  ( JoinSemilattice (joinAnnotations)+  )+import Moonlight.Triangulation.Session+  ( insertVertexAtCombining+  , withLocalSession+  )+import Moonlight.Triangulation.Types++-- | A Delaunay representative of the union of two site sets.+--+-- Skewed operands descend through the existing local copy-on-write session, so+-- the larger operand's vertex handles and untouched pages survive. Comparable+-- operands may merge along a separating seam or rebuild from their combined+-- site set. Every schedule returns valid topology; 'canonicalize' is the+-- separate physical observation when construction-independent numbering is+-- required.+--+-- Empty and structurally identical operands return an existing value verbatim.+-- Algebraic agreement between all schedules is stated by equal canonical+-- observations; structural equality continues to describe exact resident+-- representation.+joinNormalForm+  :: JoinSemilattice annotation+  => Triangulation 'Unconstrained annotation () () ()+  -> Triangulation 'Unconstrained annotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+joinNormalForm left right = executePairPlan (planPair left right) left right++executePairPlan+  :: JoinSemilattice annotation+  => PairPlan annotation+  -> Triangulation 'Unconstrained annotation () () ()+  -> Triangulation 'Unconstrained annotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+executePairPlan pairPlan left right =+  case pairPlan of+    ReturnLeftOperand -> Right left+    ReturnRightOperand -> Right right+    InsertLeftIntoRight sites -> insertSites sites right+    InsertRightIntoLeft sites -> insertSites sites left+    MergeSeparated seamPlan -> executeSeam seamPlan left right+    RebuildCanonicalUnion sites -> rebuildCanonicalSiteSet sites++insertSites+  :: JoinSemilattice annotation+  => SiteSet annotation+  -> Triangulation 'Unconstrained annotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+insertSites sites base = do+  ((), inserted, _) <-+    withLocalSession+      base+      (siteSetSize sites)+      ( traverse_+          (\(point, annotation) ->+             () <$ insertVertexAtCombining joinAnnotations point annotation+          )+          (siteSetAssocs sites)+      )+  pure inserted++-- | Combine by a balanced tournament rather than by a fold.+--+-- Associativity and commutativity make every bracketing canonically equivalent,+-- so this is a cost choice and not a semantic one. A left fold republishes an+-- accumulator that grows by one shard per step and so rebuilds @Θ(nk)@ sites+-- over @k@ shards; halving the list rebuilds @Θ(n log k)@.+--+-- The specialization below is load-bearing rather than decorative. Without it+-- this function is the only one on the path that stays polymorphic, and every+-- join in the tournament pays for a dictionary while a caller's own fold at a+-- known element type does not. That alone cost a factor of two and hid the+-- advantage this function exists for.+--+-- The tournament retains the binary operation's shortcut and annotation-gluing+-- semantics rather than inventing a second n-ary implementation.+joinBalanced+  :: JoinSemilattice annotation+  => [Triangulation 'Unconstrained annotation () () ()]+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+joinBalanced [] = Right (empty unitElementDefaults)+joinBalanced (first : rest) =+  executeTournamentPlan (planTournament (first :| rest))+{-# SPECIALIZE joinBalanced+  :: [Triangulation 'Unconstrained () () () ()]+  -> Either BuildError (Triangulation 'Unconstrained () () () ()) #-}++executeTournamentPlan+  :: JoinSemilattice annotation+  => TournamentPlan (Triangulation 'Unconstrained annotation () () ())+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+executeTournamentPlan tournament =+  case tournament of+    TournamentLeaf mesh -> Right mesh+    TournamentNode left right -> do+      leftMesh <- executeTournamentPlan left+      rightMesh <- executeTournamentPlan right+      joinNormalForm leftMesh rightMesh
+ src-build/Moonlight/Triangulation/Internal/Join/Plan.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | The sole physical planner for binary and n-ary joins. It derives exact+-- local compatibility facts, selects one schedule, and leaves execution to a+-- consumer; sequential and concurrent interpreters share the same tournament+-- tree rather than inventing pairing policies of their own.+module Moonlight.Triangulation.Internal.Join.Plan+  ( PairPlan (..)+  , planPair+  , TournamentPlan (..)+  , planTournament+  ) where++import Data.List.NonEmpty (NonEmpty (..))+import Moonlight.Triangulation.Dcel (numVertices)+import Moonlight.Triangulation.Internal.Join.Seam (SeamPlan, planSeam)+import Moonlight.Triangulation.Internal.Join.SiteSet+  ( SiteSet+  , siteSetFromTriangulation+  , siteSetRelation+  , siteSetUnionWith+  )+import Moonlight.Triangulation.Internal.Representation (Triangulation)+import Moonlight.Triangulation.JoinSemilattice (JoinSemilattice (joinAnnotations))+import Moonlight.Triangulation.Internal.Types+  ( ConstraintMode (Unconstrained)+  , SiteRelation (..)+  )++data PairPlan annotation+  = ReturnLeftOperand+  | ReturnRightOperand+  | InsertLeftIntoRight !(SiteSet annotation)+  | InsertRightIntoLeft !(SiteSet annotation)+  | MergeSeparated !SeamPlan+  | RebuildCanonicalUnion !(SiteSet annotation)++-- | Stage cheap facts before exact set classification. Empty and structurally+-- identical operands return verbatim; skewed pairs preserve the larger value+-- through local insertion before seam planning is considered.+planPair+  :: JoinSemilattice annotation+  => Triangulation 'Unconstrained annotation () () ()+  -> Triangulation 'Unconstrained annotation () () ()+  -> PairPlan annotation+planPair left right+  | leftCount == 0 = ReturnRightOperand+  | rightCount == 0 = ReturnLeftOperand+  | left == right = ReturnLeftOperand+  | insertionIsCheaper leftCount rightCount = InsertLeftIntoRight leftSites+  | insertionIsCheaper rightCount leftCount = InsertRightIntoLeft rightSites+  | Just seamPlan <- planSeam left right = MergeSeparated seamPlan+  | otherwise =+      case siteSetRelation leftSites rightSites of+        EqualSites -> InsertLeftIntoRight leftSites+        LeftProperSubset -> InsertLeftIntoRight leftSites+        RightProperSubset -> InsertRightIntoLeft rightSites+        DisjointSites -> rebuildUnion+        PartialOverlap _ -> rebuildUnion+ where+  !leftCount = numVertices left+  !rightCount = numVertices right+  leftSites = siteSetFromTriangulation left+  rightSites = siteSetFromTriangulation right+  rebuildUnion =+    RebuildCanonicalUnion+      (siteSetUnionWith joinAnnotations leftSites rightSites)++-- A transaction reuses an existing topology only when the added side is small+-- enough that its expected local cavities beat one bulk sweep. This is an+-- internal cost estimate, deliberately not a caller-controlled threshold.+insertionIsCheaper :: Int -> Int -> Bool+insertionIsCheaper addition base = addition <= 64 || addition <= base `quot` 8+{-# INLINE insertionIsCheaper #-}++-- | A deterministic dependency graph. Leaves retain meshes as values; no site+-- flattening occurs, so singleton and repeated-value shortcut semantics remain+-- those of the binary operation. Duplicate operands need no planning pass:+-- every adjacent pair reaches the binary operation, whose structural-equality+-- shortcut already returns the operand verbatim, so a dedup here would buy a+-- quadratic scan of whole meshes to skip work the executor skips anyway.+data TournamentPlan mesh+  = TournamentLeaf !mesh+  | TournamentNode !(TournamentPlan mesh) !(TournamentPlan mesh)++planTournament :: NonEmpty mesh -> TournamentPlan mesh+planTournament = buildBalanced . fmap TournamentLeaf+ where+  buildBalanced :: NonEmpty (TournamentPlan value) -> TournamentPlan value+  buildBalanced (single :| []) = single+  buildBalanced plans = buildBalanced (pairRound plans)++  pairRound :: NonEmpty (TournamentPlan value) -> NonEmpty (TournamentPlan value)+  pairRound (left :| right : rest) =+    TournamentNode left right :| pairTail rest+  pairRound (single :| []) = single :| []++  pairTail :: [TournamentPlan value] -> [TournamentPlan value]+  pairTail (left : right : rest) = TournamentNode left right : pairTail rest+  pairTail rest = rest
+ src-build/Moonlight/Triangulation/Internal/Join/Rebuild.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DataKinds #-}++-- | Canonical publication of an exact site section through the existing bulk+-- loader. Join, finite-set algebra, and constrained union share this boundary;+-- none owns a private point/payload carrier or a second constructor.+module Moonlight.Triangulation.Internal.Join.Rebuild+  ( rebuildCanonicalSiteSet+  ) where++import qualified Data.Vector as V+import Moonlight.Triangulation.BulkLoad+  ( DuplicatePayloadPolicy (KeepFirstPayload)+  , delaunayFromCoordinates+  )+import Moonlight.Triangulation.Internal.Canonical (canonicalize)+import Moonlight.Triangulation.Internal.Join.SiteSet (SiteSet, siteSetAssocs)+import Moonlight.Triangulation.Internal.Representation+  ( BuildResult (buildTriangulation)+  , Triangulation+  )+import Moonlight.Triangulation.Internal.Types+  ( BuildError+  , ConstraintMode (Unconstrained)+  , unitElementDefaults+  )++rebuildCanonicalSiteSet+  :: SiteSet annotation+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+rebuildCanonicalSiteSet sites = do+  built <-+    delaunayFromCoordinates+      unitElementDefaults+      (V.fromList (fmap fst associations))+      (V.fromList (fmap snd associations))+      KeepFirstPayload+  canonicalize (buildTriangulation built)+ where+  associations = siteSetAssocs sites
+ src-build/Moonlight/Triangulation/Internal/Join/Seam.hs view
@@ -0,0 +1,557 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Linear seam construction for separated Delaunay triangulations. Admission+-- returns an opaque proof carrying the exact source order and tangents; the+-- executor therefore has no untyped precondition and owns no fallback.+module Moonlight.Triangulation.Internal.Join.Seam+  ( SeamPlan+  , planSeam+  , executeSeam+  , ConstrainedSeamExecution+  , seamExecutionTriangulation+  , seamExecutionBuildStats+  , executeConstrainedSeam+  ) where++import Control.Monad.ST (ST, runST)+import Data.Bits (xor)+import Data.Foldable (traverse_)+import qualified Data.Vector.Unboxed as U+import Moonlight.Triangulation.Dcel+  ( adjacentEdge+  , faceDirectedEdges+  , numDirectedEdges+  , numFaces+  , numInnerFaces+  , numVertices+  , outerFace+  , vertexOutEdge+  , vertexData+  )+import Moonlight.Triangulation.Handles.HandleDefs+  ( DirectedEdgeId (..)+  , FaceId (..)+  , UndirectedEdgeId (..)+  , VertexId (..)+  )+import Moonlight.Triangulation.Internal.DcelOperations (closeOuterTurn, legalizeEdges)+import Moonlight.Triangulation.Internal.Cdt.Query (constraintEdges)+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( OperationState+  , freezeBuildStats+  , newOperationState+  )+import Moonlight.Triangulation.Internal.Paged (pagedUnsafeIndex)+import Moonlight.Triangulation.Internal.Representation (Triangulation (..))+import Moonlight.Triangulation.Internal.Types+  ( BuildError+  , BuildStats+  , ConstraintMode (Constrained, Unconstrained)+  , unitElementDefaults+  )+import Moonlight.Triangulation.Scalar (inCircleCoordinates, orient2dCoordinates)++-- | Proof that a particular pair can be copied and stitched by the seam+-- kernel. Constructors stay private so an unseparated pair cannot be handed to+-- the executor by accident.+data SeamPlan+  = SeamLeftBeforeRight !SeamTangents+  | SeamRightBeforeLeft !SeamTangents++planSeam+  :: Triangulation mode vertex () () ()+  -> Triangulation mode' vertex () () ()+  -> Maybe SeamPlan+planSeam left right =+  case separatedOrder left right of+    Just LeftBeforeRight ->+      Just (SeamLeftBeforeRight (seamTangents left right))+    Just RightBeforeLeft ->+      Just (SeamRightBeforeLeft (seamTangents right left))+    Nothing -> Nothing++-- | Execute a proved seam schedule. Numbering follows the schedule;+-- 'canonicalize' remains the explicit construction-independent observation.+executeSeam+  :: forall vertex+   . SeamPlan+  -> Triangulation 'Unconstrained vertex () () ()+  -> Triangulation 'Unconstrained vertex () () ()+  -> Either BuildError (Triangulation 'Unconstrained vertex () () ())+executeSeam plan left right =+  case plan of+    SeamLeftBeforeRight tangents ->+      fmap fst (mergeSeparated [] left right tangents)+    SeamRightBeforeLeft tangents ->+      fmap fst (mergeSeparated [] right left tangents)++-- | Result of the constrained seam kernel. Constraint flags are copied before+-- legalization, so source contour edges are immutable barriers while the+-- zipper constructs only the missing corridor.+data ConstrainedSeamExecution vertex = ConstrainedSeamExecution+  { seamExecutionTriangulation+      :: !(Triangulation 'Constrained vertex () () ())+  , seamExecutionBuildStats :: !BuildStats+  }++-- | Execute a proved seam while transporting both source constraint planes.+-- This is distinct from promoting the unconstrained result afterward: source+-- hull constraints must already be visible to seam legalization or the+-- legalization schedule could erase a solved source face before recovery had+-- a chance to mark it.+executeConstrainedSeam+  :: forall vertex+   . SeamPlan+  -> Triangulation 'Constrained vertex () () ()+  -> Triangulation 'Constrained vertex () () ()+  -> Either BuildError (ConstrainedSeamExecution vertex)+executeConstrainedSeam plan left right =+  fmap+    (uncurry ConstrainedSeamExecution)+    (case plan of+      SeamLeftBeforeRight tangents ->+        mergeSeparated+          [ (0, left)+          , (numDirectedEdges left, right)+          ]+          left+          right+          tangents+      SeamRightBeforeLeft tangents ->+        mergeSeparated+          [ (0, right)+          , (numDirectedEdges right, left)+          ]+          right+          left+          tangents+    )++data SeparatedOrder+  = LeftBeforeRight+  | RightBeforeLeft++separatedOrder+  :: Triangulation mode vertex directed undirected face+  -> Triangulation mode' vertex' directed' undirected' face'+  -> Maybe SeparatedOrder+separatedOrder left right+  | numInnerFaces left <= 0 || numInnerFaces right <= 0 = Nothing+  | otherwise = do+      (leftMinimum, leftMaximum) <- xBounds left+      (rightMinimum, rightMaximum) <- xBounds right+      if leftMaximum < rightMinimum+        then Just LeftBeforeRight+        else+          if rightMaximum < leftMinimum+            then Just RightBeforeLeft+            else Nothing++xBounds+  :: Triangulation mode vertex directed undirected face+  -> Maybe (Double, Double)+xBounds triangulation+  | total <= 0 = Nothing+  | otherwise = Just (go 1 first first)+ where+  !total = numVertices triangulation+  !coordinates = triPointX triangulation+  !first = coordinates `pagedUnsafeIndex` 0+  go !index !minimumX !maximumX+    | index >= total = (minimumX, maximumX)+    | otherwise =+        let !x = coordinates `pagedUnsafeIndex` index+         in go (index + 1) (min minimumX x) (max maximumX x)++-- The opposite-sign branch cannot overflow in its sum. The same-sign branch+-- cannot overflow in its difference.+data SeamTangents = SeamTangents+  {-# UNPACK #-} !Int+  {-# UNPACK #-} !Int+  {-# UNPACK #-} !Int+  {-# UNPACK #-} !Int++seamTangents+  :: Triangulation mode vertex directed undirected face+  -> Triangulation mode' vertex' directed' undirected' face'+  -> SeamTangents+seamTangents left right =+  let (lowerLeft, lowerRight) = lowerTangent left right leftHull rightHull+      (upperLeft, upperRight) = upperTangent left right leftHull rightHull+   in SeamTangents lowerLeft lowerRight upperLeft upperRight+ where+  !leftHull = outerEdges left+  !rightHull = outerEdges right++lowerTangent+  :: Triangulation mode vertex directed undirected face+  -> Triangulation mode' vertex' directed' undirected' face'+  -> U.Vector Int+  -> U.Vector Int+  -> (Int, Int)+-- The walk carries both endpoints' coordinates: a step replaces exactly one+-- endpoint, and the replacement is the neighbour whose coordinates the step's+-- own test already read.+lowerTangent left right leftHull rightHull =+  walk leftStart leftStartX leftStartY rightStart rightStartX rightStartY+ where+  !leftStart = extremeHullIndex preferRightmost left leftHull+  !rightStart = extremeHullIndex preferLeftmost right rightHull+  (!leftStartX, !leftStartY) = hullPoint left leftHull leftStart+  (!rightStartX, !rightStartY) = hullPoint right rightHull rightStart++  walk !leftIndex !leftX !leftY !rightIndex !rightX !rightY+    | leftBelow = walk nextLeft nextLeftX nextLeftY rightIndex rightX rightY+    | rightBelow = walk leftIndex leftX leftY previousRight previousRightX previousRightY+    | otherwise = (leftHull `U.unsafeIndex` leftIndex, rightHull `U.unsafeIndex` rightIndex)+   where+    !nextLeft = nextIndex (U.length leftHull) leftIndex+    (!nextLeftX, !nextLeftY) = hullPoint left leftHull nextLeft+    !leftBelow =+      orient2dCoordinates leftX leftY rightX rightY nextLeftX nextLeftY == LT+    previousRight = previousIndex (U.length rightHull) rightIndex+    (previousRightX, previousRightY) = hullPoint right rightHull previousRight+    rightBelow =+      orient2dCoordinates leftX leftY rightX rightY previousRightX previousRightY == LT++upperTangent+  :: Triangulation mode vertex directed undirected face+  -> Triangulation mode' vertex' directed' undirected' face'+  -> U.Vector Int+  -> U.Vector Int+  -> (Int, Int)+upperTangent left right leftHull rightHull =+  walk leftStart leftStartX leftStartY rightStart rightStartX rightStartY+ where+  !leftStart = extremeHullIndex preferRightmostUpper left leftHull+  !rightStart = extremeHullIndex preferLeftmostUpper right rightHull+  (!leftStartX, !leftStartY) = hullPoint left leftHull leftStart+  (!rightStartX, !rightStartY) = hullPoint right rightHull rightStart++  walk !leftIndex !leftX !leftY !rightIndex !rightX !rightY+    | leftAbove = walk previousLeft previousLeftX previousLeftY rightIndex rightX rightY+    | rightAbove = walk leftIndex leftX leftY nextRight nextRightX nextRightY+    | otherwise = (leftHull `U.unsafeIndex` leftIndex, rightHull `U.unsafeIndex` rightIndex)+   where+    !previousLeft = previousIndex (U.length leftHull) leftIndex+    (!previousLeftX, !previousLeftY) = hullPoint left leftHull previousLeft+    !leftAbove =+      orient2dCoordinates leftX leftY rightX rightY previousLeftX previousLeftY == GT+    nextRight = nextIndex (U.length rightHull) rightIndex+    (nextRightX, nextRightY) = hullPoint right rightHull nextRight+    rightAbove =+      orient2dCoordinates leftX leftY rightX rightY nextRightX nextRightY == GT++type ExtremePreference = Double -> Double -> Double -> Double -> Bool++preferRightmost :: ExtremePreference+preferRightmost bestX bestY candidateX candidateY =+  candidateX > bestX || (candidateX == bestX && candidateY < bestY)+{-# INLINE preferRightmost #-}++preferLeftmost :: ExtremePreference+preferLeftmost bestX bestY candidateX candidateY =+  candidateX < bestX || (candidateX == bestX && candidateY < bestY)+{-# INLINE preferLeftmost #-}++preferRightmostUpper :: ExtremePreference+preferRightmostUpper bestX bestY candidateX candidateY =+  candidateX > bestX || (candidateX == bestX && candidateY > bestY)+{-# INLINE preferRightmostUpper #-}++preferLeftmostUpper :: ExtremePreference+preferLeftmostUpper bestX bestY candidateX candidateY =+  candidateX < bestX || (candidateX == bestX && candidateY > bestY)+{-# INLINE preferLeftmostUpper #-}++extremeHullIndex+  :: ExtremePreference+  -> Triangulation mode vertex directed undirected face+  -> U.Vector Int+  -> Int+-- The running best carries its own coordinates. Re-reading them per candidate+-- read the same immutable slots @size@ times over instead of once.+extremeHullIndex prefer triangulation hull+  | size <= 0 = 0+  | otherwise =+      let (!firstX, !firstY) = hullPoint triangulation hull 0+       in go 1 0 firstX firstY+ where+  !size = U.length hull+  go !index !best !bestX !bestY+    | index >= size = best+    | otherwise =+        let (!candidateX, !candidateY) = hullPoint triangulation hull index+         in if prefer bestX bestY candidateX candidateY+              then go (index + 1) index candidateX candidateY+              else go (index + 1) best bestX bestY++outerEdges+  :: Triangulation mode vertex directed undirected face+  -> U.Vector Int+outerEdges =+  U.fromList+    . fmap (\(DirectedEdgeId edge) -> fromIntegral edge)+    . (`faceDirectedEdges` outerFace)++hullPoint+  :: Triangulation mode vertex directed undirected face+  -> U.Vector Int+  -> Int+  -> (Double, Double)+hullPoint triangulation hull index =+  let !edge = hull `U.unsafeIndex` index+      !vertex = topologyAt triangulation (4 * edge)+   in ( triPointX triangulation `pagedUnsafeIndex` vertex+      , triPointY triangulation `pagedUnsafeIndex` vertex+      )+{-# INLINE hullPoint #-}++nextIndex :: Int -> Int -> Int+nextIndex size index+  | index + 1 == size = 0+  | otherwise = index + 1+{-# INLINE nextIndex #-}++previousIndex :: Int -> Int -> Int+previousIndex size index+  | index == 0 = size - 1+  | otherwise = index - 1+{-# INLINE previousIndex #-}++mergeSeparated+  :: forall outputMode leftMode rightMode vertex+   . [(Int, Triangulation 'Constrained vertex () () ())]+  -> Triangulation leftMode vertex () () ()+  -> Triangulation rightMode vertex () () ()+  -> SeamTangents+  -> Either+      BuildError+      (Triangulation outputMode vertex () () (), BuildStats)+mergeSeparated constraintSections left right (SeamTangents lowerLeft lowerRight upperLeft upperRight) = runST $ do+  mutable <- newMutableDcel unitElementDefaults totalVertices+  pointCapacityOutcome <- ensurePointCapacity mutable totalVertices+  cellCapacityOutcome <-+    ensureCellCapacity+      mutable+      ((leftDirected + rightDirected) `quot` 2 + 1)+      (leftFaces + rightFaces - 2)+  case (pointCapacityOutcome, cellCapacityOutcome) of+    (Left obstruction, _) -> pure (Left obstruction)+    (_, Left obstruction) -> pure (Left obstruction)+    (Right (), Right ()) -> do+      appendSourceVertices mutable left+      appendSourceVertices mutable right+      _ <- addEdgeBlock mutable ((leftDirected + rightDirected) `quot` 2)+      _ <- addFaceBlock mutable (leftFaces + rightFaces - 2)+      copySource mutable left 0 0 0+      copySource mutable right leftVertices leftDirected (leftFaces - 1)+      traverse_ (uncurry (copySourceConstraints mutable)) constraintSections+      base <- spliceLowerTangent mutable leftDirected lowerLeft lowerRight+      operation <- newOperationState (halfEdgeCapacity mutable)+      stitched <-+        stitchSeam+          mutable+          operation+          base+          (topologyAt left (4 * upperLeft))+          (leftVertices + topologyAt right (4 * upperRight))+          []+      case stitched of+        Left obstruction -> pure (Left obstruction)+        Right () -> do+          statistics <- freezeBuildStats operation+          fmap (\triangulation -> (triangulation, statistics))+            <$> freezeTriangulation mutable+ where+  !leftVertices = numVertices left+  !rightVertices = numVertices right+  !totalVertices = leftVertices + rightVertices+  !leftDirected = numDirectedEdges left+  !rightDirected = numDirectedEdges right+  !leftFaces = numFaces left+  !rightFaces = numFaces right++stitchSeam+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> Int+  -> [Int]+  -> ST s (Either BuildError ())+stitchSeam mutable operation base upperLeft upperRight seeds = do+  leftVertex <- readOrigin mutable base+  rightVertex <- readOrigin mutable (base `xor` 1)+  if leftVertex == upperLeft && rightVertex == upperRight+    then legalizeEdges mutable operation seeds >> pure (Right ())+    else do+      leftEdge <- readPrevious mutable base+      rightEdge <- readNext mutable base+      nextLeft <- readOrigin mutable leftEdge+      nextRight <- readOrigin mutable (rightEdge `xor` 1)+      leftTurn <- vertexOrientation mutable nextLeft leftVertex rightVertex+      rightTurn <- vertexOrientation mutable leftVertex rightVertex nextRight+      chooseRight <-+        if rightVertex == upperRight+          then pure False+          else+            if leftVertex == upperLeft+              then pure True+              else+                case (leftTurn == GT, rightTurn == GT) of+                  (True, True) ->+                    (== GT) <$> vertexInCircle mutable nextLeft leftVertex rightVertex nextRight+                  (False, True) -> pure True+                  _ -> pure False+      if chooseRight+        then do+          closed <- closeOuterTurn mutable base+          case closed of+            Left obstruction -> pure (Left obstruction)+            Right nextBase ->+              stitchSeam mutable operation nextBase upperLeft upperRight (base : rightEdge : seeds)+        else do+          closed <- closeOuterTurn mutable leftEdge+          case closed of+            Left obstruction -> pure (Left obstruction)+            Right nextBase ->+              stitchSeam mutable operation nextBase upperLeft upperRight (leftEdge : base : seeds)++vertexOrientation+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> Int+  -> Int+  -> ST s Ordering+vertexOrientation mutable a b c = do+  ax <- readPointX mutable a+  ay <- readPointY mutable a+  bx <- readPointX mutable b+  by <- readPointY mutable b+  cx <- readPointX mutable c+  cy <- readPointY mutable c+  pure $! orient2dCoordinates ax ay bx by cx cy+{-# INLINE vertexOrientation #-}++vertexInCircle+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> Int+  -> Int+  -> Int+  -> ST s Ordering+vertexInCircle mutable a b c d = do+  ax <- readPointX mutable a+  ay <- readPointY mutable a+  bx <- readPointX mutable b+  by <- readPointY mutable b+  cx <- readPointX mutable c+  cy <- readPointY mutable c+  dx <- readPointX mutable d+  dy <- readPointY mutable d+  pure $! inCircleCoordinates ax ay bx by cx cy dx dy+{-# INLINE vertexInCircle #-}++appendSourceVertices+  :: MutableDcel s vertex () () ()+  -> Triangulation mode vertex () () ()+  -> ST s ()+appendSourceVertices mutable source =+  forRange 0 (numVertices source) $ \vertex -> do+    _ <-+      appendVertexCoordinates+        mutable+        (triPointX source `pagedUnsafeIndex` vertex)+        (triPointY source `pagedUnsafeIndex` vertex)+        (vertexData source (VertexId (fromIntegral vertex)))+    pure ()++copySource+  :: MutableDcel s vertex () () ()+  -> Triangulation mode vertex () () ()+  -> Int+  -> Int+  -> Int+  -> ST s ()+copySource mutable source vertexOffset edgeOffset faceOffset = do+  forRange 0 (numDirectedEdges source) $ \edge -> do+    let !target = edgeOffset + edge+        !sourceBase = 4 * edge+        !sourceFace = topologyAt source (sourceBase + 3)+        !targetFace = if sourceFace == 0 then 0 else faceOffset + sourceFace+    writeOrigin mutable target (vertexOffset + topologyAt source sourceBase)+    writeNext mutable target (edgeOffset + topologyAt source (sourceBase + 1))+    writePrevious mutable target (edgeOffset + topologyAt source (sourceBase + 2))+    writeFace mutable target targetFace+  forRange 0 (numVertices source) $ \vertex ->+    case vertexOutEdge source (VertexId (fromIntegral vertex)) of+      Nothing -> markConnected mutable (vertexOffset + vertex) (-1)+      Just (DirectedEdgeId edge) ->+        markConnected mutable (vertexOffset + vertex) (edgeOffset + fromIntegral edge)+  forRange 1 (numFaces source) $ \face ->+    case adjacentEdge source (FaceId (fromIntegral face)) of+      Nothing -> writeFaceEdge mutable (faceOffset + face) (-1)+      Just (DirectedEdgeId edge) ->+        writeFaceEdge mutable (faceOffset + face) (edgeOffset + fromIntegral edge)++copySourceConstraints+  :: MutableDcel s vertex () () ()+  -> Int+  -> Triangulation 'Constrained vertex () () ()+  -> ST s ()+copySourceConstraints mutable directedEdgeOffset source =+  traverse_+    (\(UndirectedEdgeId edge) ->+       ()+         <$ setConstraint+           mutable+           (directedEdgeOffset + 2 * fromIntegral edge)+    )+    (constraintEdges source)++spliceLowerTangent+  :: MutableDcel s vertex () () ()+  -> Int+  -> Int+  -> Int+  -> ST s Int+spliceLowerTangent mutable rightEdgeOffset leftOuter rightOuterSource = do+  let !rightOuter = rightEdgeOffset + rightOuterSource+  leftVertex <- readOrigin mutable leftOuter+  rightVertex <- readOrigin mutable rightOuter+  leftPrevious <- readPrevious mutable leftOuter+  rightPrevious <- readPrevious mutable rightOuter+  (forward, backward) <- addEdge mutable leftVertex rightVertex+  writeFace mutable forward 0+  writeFace mutable backward 0+  linkEdges mutable leftPrevious forward+  linkEdges mutable forward rightOuter+  linkEdges mutable rightPrevious backward+  linkEdges mutable backward leftOuter+  writeFaceEdge mutable 0 forward+  writeVertexOut mutable leftVertex forward+  writeVertexOut mutable rightVertex backward+  pure forward+{-# INLINE spliceLowerTangent #-}++topologyAt+  :: Triangulation mode vertex directed undirected face+  -> Int+  -> Int+topologyAt triangulation slot =+  fromIntegral (triHalfTopology triangulation `pagedUnsafeIndex` slot)+{-# INLINE topologyAt #-}+++forRange :: Monad m => Int -> Int -> (Int -> m ()) -> m ()+forRange from to action = go from+ where+  go !index+    | index >= to = pure ()+    | otherwise = action index >> go (index + 1)+{-# INLINE forRange #-}
+ src-build/Moonlight/Triangulation/Internal/Join/SiteSet.hs view
@@ -0,0 +1,363 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Exact transient site sections derived from the authoritative coordinate+-- planes. This is the sole owner of coordinate-set classification for joins,+-- set algebra, and constrained union. Payloads travel as annotations; they do+-- not participate in site identity.+module Moonlight.Triangulation.Internal.Join.SiteSet+  ( SiteSet+  , siteSetFromTriangulation+  , siteSupportFromTriangulation+  , siteSetSize+  , siteSetRelation+  , siteRelationFromTriangulations+  , siteSetUnionWith+  , siteSetIntersectionWith+  , siteSetDifference+  , siteSetSymmetricDifferenceFromTriangulations+  , siteSetAssocs+  , siteSetPoints+  ) where++import Control.Monad.ST (ST, runST)+import qualified Data.Map.Strict as Map+import qualified Data.Map.Merge.Strict as MapMerge+import Data.Functor.Const (Const (..))+import Data.Maybe (isJust)+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MUV+import Moonlight.Triangulation.Dcel (numVertices, vertexData, vertexPoint)+import Moonlight.Triangulation.Handles.HandleDefs (VertexId (..))+import Moonlight.Triangulation.Handles.Iterators.FixedIterators+  ( foldVertices'+  )+import Moonlight.Triangulation.Internal.Paged+  ( pagedUnsafeIndex+  , toVector+  )+import Moonlight.Triangulation.Internal.PointIndex+  ( MutablePointIndex+  , lookupMutablePoint+  , lookupPointIndex+  , newMutablePointIndex+  , seedMutablePointIndex+  )+import Moonlight.Triangulation.Internal.Representation (Triangulation (..))+import Moonlight.Triangulation.Internal.Types+  ( BuildError+  , Point (..)+  , SiteRelation (..)+  )++newtype SiteSet annotation = SiteSet (Map.Map (Point) annotation)++-- Strict sufficient statistics for the one-pass ordered-map descent used by+-- 'siteSetRelation'. Keeping the census strict prevents a relation query from+-- replacing an intermediate map allocation with a chain of monoidal thunks.+data SiteRelationCensus = SiteRelationCensus !Int !Int !Int++instance Semigroup SiteRelationCensus where+  SiteRelationCensus leftA rightA overlapA <> SiteRelationCensus leftB rightB overlapB =+    SiteRelationCensus+      (leftA + leftB)+      (rightA + rightB)+      (overlapA + overlapB)++instance Monoid SiteRelationCensus where+  mempty = SiteRelationCensus 0 0 0++siteSetFromTriangulation+  :: Triangulation mode annotation directed undirected face+  -> SiteSet annotation+siteSetFromTriangulation triangulation =+  SiteSet+    ( Map.fromList+        [ ( Point+              (triPointX triangulation `pagedUnsafeIndex` vertex)+              (triPointY triangulation `pagedUnsafeIndex` vertex)+          , vertexData triangulation (VertexId (fromIntegral vertex))+          )+        | vertex <- [0 .. numVertices triangulation - 1]+        ]+    )++-- | Coordinate support without touching the boxed annotation plane. Order and+-- set identity are geometric observations; callers that discard annotations+-- should not pay a boxed-page read per vertex merely to manufacture ignored+-- map values.+siteSupportFromTriangulation+  :: Triangulation mode vertex directed undirected face+  -> SiteSet ()+siteSupportFromTriangulation triangulation =+  SiteSet+    ( Map.fromList+        [ ( Point+              (triPointX triangulation `pagedUnsafeIndex` vertex)+              (triPointY triangulation `pagedUnsafeIndex` vertex)+          , ()+          )+        | vertex <- [0 .. numVertices triangulation - 1]+        ]+    )+{-# INLINE siteSupportFromTriangulation #-}++siteSetSize :: SiteSet annotation -> Int+siteSetSize (SiteSet sites) = Map.size sites+{-# INLINE siteSetSize #-}++siteSetRelation+  :: SiteSet leftAnnotation+  -> SiteSet rightAnnotation+  -> SiteRelation+siteSetRelation (SiteSet left) (SiteSet right) =+  siteRelationFromCardinalities+    (leftOnly + overlap)+    (rightOnly + overlap)+    overlap+ where+  SiteRelationCensus leftOnly rightOnly overlap =+    getConst+      ( MapMerge.mergeA+          (MapMerge.traverseMissing (\_ _ -> Const (SiteRelationCensus 1 0 0)))+          (MapMerge.traverseMissing (\_ _ -> Const (SiteRelationCensus 0 1 0)))+          (MapMerge.zipWithAMatched (\_ _ _ -> Const (SiteRelationCensus 0 0 1)))+          left+          right+      )+{-# INLINE siteSetRelation #-}++siteRelationFromTriangulations+  :: Triangulation leftMode leftAnnotation leftDirected leftUndirected leftFace+  -> Triangulation rightMode rightAnnotation rightDirected rightUndirected rightFace+  -> SiteRelation+siteRelationFromTriangulations left right =+  siteRelationFromCardinalities leftCount rightCount overlap+ where+  !leftCount = numVertices left+  !rightCount = numVertices right+  !overlap+    | leftCount <= rightCount = exactOverlapCount right left+    | otherwise = exactOverlapCount left right+{-# INLINE siteRelationFromTriangulations #-}++siteRelationFromCardinalities :: Int -> Int -> Int -> SiteRelation+siteRelationFromCardinalities leftCount rightCount overlap+  | leftCount == rightCount && overlap == leftCount = EqualSites+  | overlap == leftCount = LeftProperSubset+  | overlap == rightCount = RightProperSubset+  | overlap == 0 = DisjointSites+  | otherwise = PartialOverlap overlap+{-# INLINE siteRelationFromCardinalities #-}++exactOverlapCount+  :: Triangulation sourceMode sourceAnnotation sourceDirected sourceUndirected sourceFace+  -> Triangulation indexedMode indexedAnnotation indexedDirected indexedUndirected indexedFace+  -> Int+exactOverlapCount source indexed =+  either+    (const (persistentExactOverlapCount source indexed))+    id+    (transientExactOverlapCount source indexed)+{-# INLINE exactOverlapCount #-}++transientExactOverlapCount+  :: Triangulation sourceMode sourceAnnotation sourceDirected sourceUndirected sourceFace+  -> Triangulation indexedMode indexedAnnotation indexedDirected indexedUndirected indexedFace+  -> Either BuildError Int+transientExactOverlapCount source indexed = runST $ do+  pointIndex <- newMutablePointIndex (numVertices indexed)+  seeded <-+    seedMutablePointIndex+      pointIndex+      (numVertices indexed)+      (readCoordinateX indexed)+      (readCoordinateY indexed)+  case seeded of+    Left failure -> pure (Left failure)+    Right () ->+      fmap Right+        ( U.ifoldM'+            (\count vertex x -> do+               let y = triPointY source `pagedUnsafeIndex` vertex+               match <-+                 lookupMutablePoint+                   pointIndex+                   (readCoordinateX indexed)+                   (readCoordinateY indexed)+                   x+                   y+               pure (if isJust match then count + 1 else count)+            )+            0+            (toVector (triPointX source))+        )+{-# INLINE transientExactOverlapCount #-}++persistentExactOverlapCount+  :: Triangulation sourceMode sourceAnnotation sourceDirected sourceUndirected sourceFace+  -> Triangulation indexedMode indexedAnnotation indexedDirected indexedUndirected indexedFace+  -> Int+persistentExactOverlapCount source indexed =+  foldVertices'+    source+    (\count vertex ->+       if pointOccursIn indexed (vertexPoint source vertex)+         then count + 1+         else count+    )+    0+{-# INLINE persistentExactOverlapCount #-}++siteSetUnionWith+  :: (annotation -> annotation -> annotation)+  -> SiteSet annotation+  -> SiteSet annotation+  -> SiteSet annotation+siteSetUnionWith combine (SiteSet left) (SiteSet right) =+  SiteSet (Map.unionWith combine left right)+{-# INLINE siteSetUnionWith #-}++siteSetIntersectionWith+  :: (leftAnnotation -> rightAnnotation -> annotation)+  -> SiteSet leftAnnotation+  -> SiteSet rightAnnotation+  -> SiteSet annotation+siteSetIntersectionWith combine (SiteSet left) (SiteSet right) =+  SiteSet (Map.intersectionWith combine left right)+{-# INLINE siteSetIntersectionWith #-}++siteSetDifference+  :: SiteSet annotation+  -> SiteSet other+  -> SiteSet annotation+siteSetDifference (SiteSet left) (SiteSet right) = SiteSet (Map.difference left right)+{-# INLINE siteSetDifference #-}++siteSetSymmetricDifferenceFromTriangulations+  :: Triangulation leftMode annotation leftDirected leftUndirected leftFace+  -> Triangulation rightMode annotation rightDirected rightUndirected rightFace+  -> Either BuildError (SiteSet annotation)+siteSetSymmetricDifferenceFromTriangulations left right+  | numVertices left >= numVertices right = indexedSymmetricDifference left right+  | otherwise = indexedSymmetricDifference right left+{-# INLINE siteSetSymmetricDifferenceFromTriangulations #-}++indexedSymmetricDifference+  :: forall sourceMode annotation sourceDirected sourceUndirected sourceFace+            indexedMode indexedDirected indexedUndirected indexedFace+  . Triangulation sourceMode annotation sourceDirected sourceUndirected sourceFace+  -> Triangulation indexedMode annotation indexedDirected indexedUndirected indexedFace+  -> Either BuildError (SiteSet annotation)+indexedSymmetricDifference source indexed =+  fmap (SiteSet . Map.fromList) (runST collectExclusiveAssociations)+ where+  collectExclusiveAssociations+    :: forall state. ST state (Either BuildError [(Point, annotation)])+  collectExclusiveAssociations = do+    pointIndex <- newMutablePointIndex (numVertices indexed)+    seeded <-+      seedMutablePointIndex+        pointIndex+        (numVertices indexed)+        (readCoordinateX indexed)+        (readCoordinateY indexed)+    case seeded of+      Left failure -> pure (Left failure)+      Right () -> do+        matchedIndexedVertices <- MUV.replicate (numVertices indexed) False+        sourceExclusive <-+          U.ifoldM'+            (collectSourceExclusive pointIndex matchedIndexedVertices)+            []+            (toVector (triPointX source))+        indexedExclusive <-+          U.ifoldM'+            (collectIndexedExclusive matchedIndexedVertices)+            []+            (toVector (triPointX indexed))+        pure (Right (sourceExclusive <> indexedExclusive))+   where+    collectSourceExclusive+      :: MutablePointIndex state+      -> MUV.MVector state Bool+      -> [(Point, annotation)]+      -> Int+      -> Double+      -> ST state [(Point, annotation)]+    collectSourceExclusive pointIndex matchedIndexedVertices associations rawVertex x = do+      let vertex = VertexId (fromIntegral rawVertex)+          y = triPointY source `pagedUnsafeIndex` rawVertex+          point = Point x y+      match <-+        lookupMutablePoint+          pointIndex+          (readCoordinateX indexed)+          (readCoordinateY indexed)+          x+          y+      case match of+        Nothing -> pure ((point, vertexData source vertex) : associations)+        Just indexedVertex -> do+          MUV.unsafeWrite matchedIndexedVertices indexedVertex True+          pure associations++    collectIndexedExclusive+      :: MUV.MVector state Bool+      -> [(Point, annotation)]+      -> Int+      -> Double+      -> ST state [(Point, annotation)]+    collectIndexedExclusive matchedIndexedVertices associations rawVertex x = do+      let vertex = VertexId (fromIntegral rawVertex)+          point = Point x (triPointY indexed `pagedUnsafeIndex` rawVertex)+      matched <- MUV.unsafeRead matchedIndexedVertices rawVertex+      pure+        ( if matched+            then associations+            else (point, vertexData indexed vertex) : associations+        )+{-# INLINE indexedSymmetricDifference #-}++readCoordinateX+  :: Triangulation mode annotation directed undirected face+  -> Int+  -> ST state Double+readCoordinateX triangulation vertex =+  pure (triPointX triangulation `pagedUnsafeIndex` vertex)+{-# INLINE readCoordinateX #-}++readCoordinateY+  :: Triangulation mode annotation directed undirected face+  -> Int+  -> ST state Double+readCoordinateY triangulation vertex =+  pure (triPointY triangulation `pagedUnsafeIndex` vertex)+{-# INLINE readCoordinateY #-}++pointOccursIn+  :: Triangulation mode annotation directed undirected face+  -> Point+  -> Bool+pointOccursIn triangulation = isJust . lookupPointIn triangulation+{-# INLINE pointOccursIn #-}++lookupPointIn+  :: Triangulation mode annotation directed undirected face+  -> Point+  -> Maybe Int+lookupPointIn triangulation =+  lookupPointIndex+    (triPointX triangulation)+    (triPointY triangulation)+    (triPointIndex triangulation)+{-# INLINE lookupPointIn #-}++siteSetAssocs :: SiteSet annotation -> [(Point, annotation)]+siteSetAssocs (SiteSet sites) = Map.toAscList sites+{-# INLINE siteSetAssocs #-}++siteSetPoints :: SiteSet annotation -> V.Vector (Point)+siteSetPoints (SiteSet sites) = V.fromList (Map.keys sites)+{-# INLINE siteSetPoints #-}
+ src-build/Moonlight/Triangulation/Internal/Location.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}++module Moonlight.Triangulation.Internal.Location+  ( MutableLocation (..)+  , locateMutable+  , locateLineMutable+  , visibleOuterEdge+  ) where++import Control.Monad.ST (ST)+import Data.Bits (xor, (.&.))+import Data.STRef (readSTRef, writeSTRef)+import Moonlight.Triangulation.Internal.FaceProbe+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , maxCounter+  )+import Moonlight.Triangulation.Math+import Moonlight.Triangulation.Types++data MutableLocation+  = MutableEmpty+  | MutableOnVertex {-# UNPACK #-} !Int+  | MutableOnEdge {-# UNPACK #-} !Int+  | MutableInFace {-# UNPACK #-} !Int+  | MutableOutsideHull {-# UNPACK #-} !Int+  deriving stock (Eq, Ord, Show)++reverseIndex :: Int -> Int+reverseIndex edge = edge `xor` 1+{-# INLINE reverseIndex #-}++locateMutable+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Maybe Int+  -> Point+  -> ST s (Either BuildError MutableLocation)+locateMutable mutable operation hint rawQuery = do+  connected <- connectedCount mutable+  faces <- faceCount mutable+  let !query = canonicalPoint rawQuery+  case connected of+    0 -> pure (Right MutableEmpty)+    _ | faces <= 1 -> Right <$> locateLineMutable mutable query+    -- A hint is the caller vouching for adjacency, so the exact walk starts+    -- there directly; only an unhinted locate buys the vertex descent.+    _ | Just face <- hint, face > 0 && face < faces -> walk mutable operation query face+    _ -> do+      start <- chooseStartFace mutable hint+      anchor <- readFaceEdge mutable start+      if anchor < 0+        then walk mutable operation query start+        else do+          origin <- readOrigin mutable anchor+          nearest <- descendToNearest mutable operation query origin+          face <- incidentInnerFace mutable nearest start+          walk mutable operation query face++-- | Greedy first-improvement descent through vertex neighbours: hop to the+-- first neighbour strictly closer to the query until none improves. Distance+-- is a heuristic only — exact containment belongs to 'walk' — so the widened+-- comparison can lengthen the path but never move the located answer.+--+-- Strictly decreasing distance bounds the hops and nothing else: no vertex is+-- entered twice, but the star rotation terminates only if @reverse . previous@+-- closes an orbit, which is a property of the links rather than of the+-- geometry. Disjoint stars over distinct entered vertices spend at most one+-- step per outgoing half-edge, so a budget past 'directedEdgeCount' cannot be+-- exhausted while the links are well formed. Exhausting it means they are not,+-- and yields the vertex in hand rather than an error — a truncated descent can+-- only lengthen 'walk', never move what it finds.+descendToNearest+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Point+  -> Int+  -> ST s Int+descendToNearest mutable operation query start = do+  halfEdges <- directedEdgeCount mutable+  point <- pointAt mutable start+  settle (halfEdges + 1) start (squaredDistanceWide query point)+ where+  settle !budget !vertex !best = do+    first <- readVertexOut mutable vertex+    if first < 0+      then pure vertex+      else rotate budget vertex best first first+  rotate !budget !vertex !best !first !edge+    | budget <= 0 = pure vertex+    | otherwise = do+        neighbour <- readOrigin mutable (reverseIndex edge)+        point <- pointAt mutable neighbour+        let !candidate = squaredDistanceWide query point+        if candidate < best+          then do+            addCounter operation CounterLocationWalkSteps 1+            settle (budget - 1) neighbour candidate+          else do+            previousEdge <- readPrevious mutable edge+            let !outgoing = reverseIndex previousEdge+            if outgoing == first then pure vertex else rotate (budget - 1) vertex best first outgoing++-- | An inner face incident to the vertex, so the exact walk starts adjacent+-- to where the descent settled; the caller's face stands in when the star+-- offers none.+incidentInnerFace+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> Int+  -> ST s Int+incidentInnerFace mutable vertex fallback = do+  first <- readVertexOut mutable vertex+  if first < 0 then pure fallback else rotate first first+ where+  rotate !first !edge = do+    face <- readFace mutable edge+    if face > 0+      then pure face+      else do+        previousEdge <- readPrevious mutable edge+        let !outgoing = reverseIndex previousEdge+        if outgoing == first then pure fallback else rotate first outgoing++locateLineMutable :: MutableDcel s vertex directed undirected face -> Point -> ST s MutableLocation+locateLineMutable mutable rawQuery = do+  let !query = canonicalPoint rawQuery+  vertices <- pointCount mutable+  exactVertex <- findVertex query vertices 0+  case exactVertex of+    Just vertex -> pure (MutableOnVertex vertex)+    Nothing -> do+      halfEdges <- directedEdgeCount mutable+      if halfEdges == 0+        then pure (MutableOutsideHull 0)+        else do+          onEdge <- findSegment query halfEdges 0+          case onEdge of+            Just edge -> pure (MutableOnEdge edge)+            Nothing -> do+              firstConnected <- findConnected vertices 0+              firstOut <- readVertexOut mutable firstConnected+              let edge = if firstOut < 0 then 0 else firstOut+              from <- edgeOriginPoint mutable edge+              to <- edgeOriginPoint mutable (reverseIndex edge)+              case orient2d from to query of+                GT -> pure (MutableOutsideHull (orientOuter edge))+                LT -> pure (MutableOutsideHull (orientOuter (reverseIndex edge)))+                EQ -> MutableOutsideHull <$> nearestTerminalEdge query halfEdges edge+ where+  findVertex !query !limit !index+    | index >= limit = pure Nothing+    | otherwise = do+        connected <- isConnected mutable index+        if not connected+          then findVertex query limit (index + 1)+          else do+            point <- pointAt mutable index+            if point == query then pure (Just index) else findVertex query limit (index + 1)++  findSegment !query !limit !edge+    | edge >= limit = pure Nothing+    | otherwise = do+        let normalized = edge .&. complementOne+        from <- edgeOriginPoint mutable normalized+        to <- edgeOriginPoint mutable (reverseIndex normalized)+        if onClosedSegment from to query+          then pure (Just normalized)+          else findSegment query limit (normalized + 2)++  findConnected !limit !index+    | index >= limit = pure 0+    | otherwise = do+        connected <- isConnected mutable index+        if connected then pure index else findConnected limit (index + 1)++  orientOuter :: Int -> Int+  orientOuter edge = edge++  -- A degenerate chain's outer cycle doubles back exactly at its two terminal+  -- vertices, so @next e == reverse e@ characterises the edge entering a+  -- terminal. Collinear extension must attach to the terminal nearest the+  -- query, which for three or more vertices is not an endpoint of any single+  -- arbitrary edge.+  nearestTerminalEdge !query !limit !fallback = go 0 Nothing+   where+    go !edge !best+      | edge >= limit = pure (maybe fallback fst best)+      | otherwise = do+          edgeNext <- readNext mutable edge+          if edgeNext /= reverseIndex edge+            then go (edge + 1) best+            else do+              let !terminal = reverseIndex edge+              point <- edgeOriginPoint mutable terminal+              let !candidate = squaredDistanceWide query point+              case best of+                Just (_, closest) | closest <= candidate -> go (edge + 1) best+                _ -> go (edge + 1) (Just (terminal, candidate))++  complementOne = -2++walk+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Point+  -> Int+  -> ST s (Either BuildError MutableLocation)+walk mutable operation query initialFace = do+  faces <- faceCount mutable+  halfEdges <- directedEdgeCount mutable+  let !budget = max 8 (faces + halfEdges `quot` 2 + 4)+  go budget 0 initialFace+ where+  go !remaining !steps !face+    | remaining <= 0 = do+        addCounter operation CounterLocationFallbacks 1+        maxCounter operation CounterLocationMaxWalk steps+        pure (Left (LocationWalkExhausted query steps))+    | face <= 0 = Right . MutableOutsideHull <$> visibleOuterEdge mutable query+    | otherwise = do+        addCounter operation CounterLocationWalkSteps 1+        let !nextSteps = steps + 1+        probe <- probeFace mutable face query+        case probe of+          MutableInFace found -> do+            writeSTRef (mdLastFace mutable) found+            maxCounter operation CounterLocationMaxWalk nextSteps+            pure (Right probe)+          MutableOnVertex _ -> do+            writeSTRef (mdLastFace mutable) face+            maxCounter operation CounterLocationMaxWalk nextSteps+            pure (Right probe)+          MutableOnEdge _ -> do+            writeSTRef (mdLastFace mutable) face+            maxCounter operation CounterLocationMaxWalk nextSteps+            pure (Right probe)+          MutableOutsideHull edge -> do+            adjacent <- readFace mutable edge+            if adjacent == 0+              then do+                maxCounter operation CounterLocationMaxWalk nextSteps+                pure (Right (MutableOutsideHull edge))+              else go (remaining - 1) nextSteps adjacent+          MutableEmpty -> pure (Left (PointLocationFailed query))++probeFace :: MutableDcel s vertex directed undirected face -> Int -> Point -> ST s MutableLocation+-- 'faceEdges' walks the @next@ chain, so the cycle already states each+-- boundary's destination: @destination e0 = origin e1@. Reading the twin's+-- origin instead asks the store for what the face has already said, at twice+-- the endpoint loads and twice the coordinate loads per probe. Three origins+-- and three points settle all three boundaries. Vertex and edge hits still+-- return on the first boundary that reports one, and a later crossing still+-- displaces an earlier one.+probeFace mutable face query = do+  (e0, e1, e2) <- faceEdges mutable face+  a <- readOrigin mutable e0+  b <- readOrigin mutable e1+  c <- readOrigin mutable e2+  pa <- pointAt mutable a+  pb <- pointAt mutable b+  pc <- pointAt mutable c+  let !first = probeBoundary reverseIndex query e0 a pa b pb+  case first of+    BoundaryOnVertex vertex -> pure (MutableOnVertex vertex)+    BoundaryOnEdge boundary -> pure (MutableOnEdge boundary)+    _ -> do+      let !second = probeBoundary reverseIndex query e1 b pb c pc+      case second of+        BoundaryOnVertex vertex -> pure (MutableOnVertex vertex)+        BoundaryOnEdge boundary -> pure (MutableOnEdge boundary)+        _ -> do+          let !third = probeBoundary reverseIndex query e2 c pc a pa+          case third of+            BoundaryOnVertex vertex -> pure (MutableOnVertex vertex)+            BoundaryOnEdge boundary -> pure (MutableOnEdge boundary)+            _ -> pure $ case keep third (keep second (keep first Nothing)) of+              Nothing -> MutableInFace face+              Just boundary -> MutableOutsideHull boundary+ where+  keep :: BoundaryProbe boundary probeVertex -> Maybe boundary -> Maybe boundary+  keep (BoundaryCrossing boundary) _ = Just boundary+  keep _ held = held++chooseStartFace :: MutableDcel s vertex directed undirected face -> Maybe Int -> ST s Int+chooseStartFace mutable hint = do+  faces <- faceCount mutable+  cached <- readSTRef (mdLastFace mutable)+  let candidate = case hint of+        Just face | face > 0 && face < faces -> face+        _ | cached > 0 && cached < faces -> cached+        _ -> 1+  pure candidate++visibleOuterEdge :: MutableDcel s vertex directed undirected face -> Point -> ST s Int+visibleOuterEdge mutable query = do+  start <- readFaceEdge mutable 0+  halfEdges <- directedEdgeCount mutable+  if start < 0 || halfEdges == 0+    then pure 0+    else go (halfEdges + 1) start start Nothing+ where+  go !remaining !start !edge !fallback+    | remaining <= 0 = pure (maybe start id fallback)+    | otherwise = do+        from <- edgeOriginPoint mutable edge+        to <- edgeOriginPoint mutable (reverseIndex edge)+        let !side = orient2d from to query+            !fallback' = if side /= LT then Just edge else fallback+        if side == GT+          then pure edge+          else do+            edgeNext <- readNext mutable edge+            if edgeNext == start then pure (maybe edge id fallback') else go (remaining - 1) start edgeNext fallback'++
+ src-build/Moonlight/Triangulation/Internal/Refinement.hs view
@@ -0,0 +1,1284 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Ruppert refinement over three local worklists: forced segment splits,+-- fixed-edge encroachment candidates, and skinny faces. A face candidate is+-- transactional: preflight locates the circumcenter and follows the+-- prospective legalization cavity without mutating topology; a fixed edge the+-- cavity meets is tested against the point's diametral disk and aborts the+-- plan into a segment split; otherwise the located site commits directly.+module Moonlight.Triangulation.Internal.Refinement+  ( RefinementInitialSeed (..)+  , RefinementDomain (..)+  , refineMutable+  ) where++import Control.Monad (filterM, forM_, unless, when)+import Control.Monad.ST (ST)+import Data.Foldable (traverse_)+import Data.Bits (xor)+import qualified Data.IntSet as IntSet+import Data.List (find)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.STRef (STRef, modifySTRef', newSTRef, readSTRef, writeSTRef)+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32)+import Moonlight.Triangulation.Handles.HandleDefs (FaceId (..), UndirectedEdgeId (..))+import Moonlight.Triangulation.Internal.DcelOperations (insertOnEdge, legalizeEdges)+import Moonlight.Triangulation.Internal.Growable+  ( GrowableWord32+  , clearGrowable+  , growableLength+  , newGrowableWord32+  , popGrowableOr+  , pushGrowable+  , readGrowable+  )+import Moonlight.Triangulation.Internal.Location+  ( MutableLocation (..)+  , locateMutable+  )+import Moonlight.Triangulation.Internal.FaceQueue+  ( FaceQueue+  , newFaceQueue+  , popFace+  , pushFace+  )+import Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel (..)+  , addEdgeBlock+  , addFaceBlock+  , appendVertex+  , directedEdgeCount+  , edgeOriginPoint+  , ensureCellCapacity+  , faceCount+  , faceEdges+  , markConnected+  , pointAt+  , pointCapacity+  , readConstraint+  , readFace+  , readNext+  , readOrigin+  , readPrevious+  , readVertexOut+  , resetEdgeData+  , resetFaceData+  , setCycle3+  , writeOrigin+  , writeVertexOut+  )+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , maxCounter+  , readScratch+  , writeScratch+  )+import Moonlight.Triangulation.Internal.PackedIndex (noIndex, packIndex)+import Moonlight.Triangulation.Internal.Probe (Probe (..))+import Moonlight.Triangulation.Math+  ( canonicalPoint+  , circumcenter+  , inCircle+  , inDiametralCircle+  , isFinite+  , midpoint+  , orient2d+  , squaredDistance+  , squaredDistanceWide+  , triangleArea+  , triangleRadiusEdgeRatioSquaredWithArea+  , validateCoordinate+  )+import Moonlight.Triangulation.Insertion (insertExistingVertexAtLocation)+import Moonlight.Triangulation.Types+  ( BuildError (..)+  , Point (..)+  , RefinementParameters (..)+  )++-- | The worklists refinement owns for the duration of one transaction. Every+-- one is local to the cavity or segment it drains; nothing geometric is+-- indexed globally.+data Workspace s = Workspace+  { wsQueue :: !(FaceQueue s)+  , wsExcluded :: !(MUV.MVector s Bool)+  , wsPermitted :: !(Maybe (MUV.MVector s Bool))+  , wsVisited :: !(Maybe (MUV.MVector s Bool))+  , wsInterfaceBoundaryReads :: !(STRef s Int)+  , wsBoundaryCrossingAttempts :: !(STRef s Int)+  , wsForcedSplits :: !(GrowableWord32 s)+  , wsEncroachment :: !(GrowableWord32 s)+  -- | Where each pair's live entry sits in 'wsEncroachment', 'noIndex' when+  -- the pair is not queued. A re-push relocates the pair to the top and leaves+  -- the older entry behind as a slot that no longer names it, so a pair is+  -- tested once at its most recent offer instead of once per offer.+  , wsEncroachmentSlot :: !(MUV.MVector s Word32)+  -- | Steiner vertices on constraints carry the original segment's endpoint+  -- pair, two words per vertex, 'noIndex' when the vertex is not on one.+  , wsSegmentOrigin :: !(MUV.MVector s Word32)+  -- | Cavity discovery state: an epoch stamp per face, edge pair and boundary+  -- vertex, plus the three records a successful commit consumes. A cavity is+  -- explored without mutating topology; the commit either fans the recorded+  -- boundary or abandons the records entirely.+  , wsCavityEpoch :: !(STRef s Word32)+  , wsCavityFaceMarks :: !(MUV.MVector s Word32)+  , wsCavityPairMarks :: !(MUV.MVector s Word32)+  , wsCavityVertexMarks :: !(MUV.MVector s Word32)+  , wsCavityFaces :: !(GrowableWord32 s)+  , wsCavityInternal :: !(GrowableWord32 s)+  , wsCavityBoundary :: !(GrowableWord32 s)+  , wsCavityCocircular :: !(GrowableWord32 s)+  -- | The recorded boundary in cycle order, written by the chaining walk and+  -- read by the fan.+  , wsCavityChain :: !(GrowableWord32 s)+  -- | The flood and hull-simulation stack. The old mesh-global work stack+  -- served both; the transaction owns it now, cleared before either use.+  , wsCavityWork :: !(GrowableWord32 s)+  }++data FaceHint+  = FaceAcceptable+  | FaceMustRefine+  | FaceShouldRefine++-- | The initial support a refinement run is allowed to inspect. Subsequent+-- cavity, star, and fixed-edge propagation remains exactly the ordinary+-- refinement law; only the first offers differ. The constructor is internal+-- so public callers cannot smuggle a mutable worklist across the transaction+-- boundary.+data RefinementInitialSeed+  = RefineEveryFace+  | RefineSeededFaces !IntSet.IntSet++-- | A checked local section. Face and edge integers are admitted by the+-- immutable constructor in "Moonlight.Triangulation.Refinement"; the mutable+-- interpreter sees only the already-descended dense membership witnesses.+data RefinementDomain = RefinementDomain+  { refinementDomainPermittedFaces :: !IntSet.IntSet+  , refinementDomainInterfacePairs :: !IntSet.IntSet+  , refinementDomainInputFaces :: !(Map.Map FaceId [Point])+  , refinementDomainInputFaceCount :: {-# UNPACK #-} !Int+  , refinementDomainInputEdgeCount :: {-# UNPACK #-} !Int+  }+  deriving stock (Eq, Show)++reverseIndex :: Int -> Int+reverseIndex edge = edge `xor` 1+{-# INLINE reverseIndex #-}++-- | Refine the existing finite DCEL. Fixed edges (constraints and the convex+-- hull) are legal barriers: a candidate whose prospective cavity meets one+-- inside its diametral disk is abandoned and the segment is split instead.+-- The result is @(worklists-drained, Steiner-count, excluded-outer-faces)@.+refineMutable+  :: forall s vertex directed undirected face. (Point -> vertex)+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> RefinementParameters+  -> Int+  -> IntSet.IntSet+  -> RefinementInitialSeed+  -> Maybe RefinementDomain+  -> ST s (Either BuildError (Bool, Int, [Int], [Int], Int, Int))+refineMutable makeVertex mutable operation parameters originalVertexCount initialExcludedFaces initialSeed domain = do+  let !faceBound = 3 * pointCapacity mutable + 8+      !pairBound = mdHalfCapacity mutable `quot` 2+  wsQueue <- newFaceQueue faceBound+  wsExcluded <- MUV.replicate faceBound False+  wsPermitted <- traverse (const (MUV.replicate faceBound False)) domain+  wsVisited <- traverse (const (MUV.replicate faceBound False)) domain+  wsInterfaceBoundaryReads <- newSTRef 0+  wsBoundaryCrossingAttempts <- newSTRef 0+  traverse_+    (\membership ->+       traverse_+         (\face -> when (face < faceBound) (MUV.unsafeWrite membership face True))+         (maybe [] (IntSet.toAscList . refinementDomainPermittedFaces) domain)+    )+    wsPermitted+  when (refineExcludeOuterFaces parameters) $+    forM_ (IntSet.toAscList initialExcludedFaces) $ \face ->+      when (face < faceBound) (MUV.unsafeWrite wsExcluded face True)+  wsForcedSplits <- newGrowableWord32 16+  wsEncroachment <- newGrowableWord32 64+  wsEncroachmentSlot <- MUV.replicate (max 1 pairBound) noIndex+  wsSegmentOrigin <- MUV.replicate (2 * pointCapacity mutable) noIndex+  wsCavityEpoch <- newSTRef 0+  wsCavityFaceMarks <- MUV.replicate faceBound 0+  wsCavityPairMarks <- MUV.replicate (max 1 pairBound) 0+  wsCavityVertexMarks <- MUV.replicate (pointCapacity mutable) 0+  wsCavityFaces <- newGrowableWord32 16+  wsCavityInternal <- newGrowableWord32 16+  wsCavityBoundary <- newGrowableWord32 16+  wsCavityCocircular <- newGrowableWord32 4+  wsCavityChain <- newGrowableWord32 16+  wsCavityWork <- newGrowableWord32 16+  let workspace = Workspace{wsQueue, wsExcluded, wsPermitted, wsVisited, wsInterfaceBoundaryReads, wsBoundaryCrossingAttempts, wsForcedSplits, wsEncroachment, wsEncroachmentSlot, wsSegmentOrigin, wsCavityEpoch, wsCavityFaceMarks, wsCavityPairMarks, wsCavityVertexMarks, wsCavityFaces, wsCavityInternal, wsCavityBoundary, wsCavityCocircular, wsCavityChain, wsCavityWork}+  seedInitialWork workspace initialSeed+  loop workspace 0+ where+  !limit = max 0 (fromMaybe (10 * originalVertexCount) (refineMaxAdditionalVertices parameters))++  -- The three bounds every queued face is measured against. They are fixed for+  -- the whole run, and the ratio bound is squared once here rather than once+  -- per face the ratio test reaches.+  !maximumArea = refineMaxArea parameters+  !minimumArea = refineMinArea parameters+  !squaredRatioBound = case refineMaxRadiusEdgeRatio parameters of+    Nothing -> Nothing+    Just bound -> Just $! squareBound bound++  -- One charged stack push: the old mesh-global 'pushWork' wrapper fed the+  -- legalization depth counter on every push, and the hull-simulation sites+  -- used that wrapper deliberately. The cavity flood's bypass stays raw.+  pushChargedWork :: GrowableWord32 s -> Int -> ST s ()+  pushChargedWork work value = do+    pushGrowable work (packIndex value)+    size <- growableLength work+    maxCounter operation CounterLegalizationMaxStack size++  -- Offer a fixed edge pair for the encroachment question. An offer always+  -- wins the pair's slot, so the pair is answered at its most recent offer and+  -- the entries it left behind are recognised as superseded when reached.+  pushEncroachment :: Workspace s -> Int -> ST s ()+  pushEncroachment Workspace{wsEncroachment, wsEncroachmentSlot} pair = do+    index <- growableLength wsEncroachment+    pushGrowable wsEncroachment (packIndex pair)+    MUV.unsafeWrite wsEncroachmentSlot pair (packIndex index)++  -- 'noIndex' when the offers are drained.+  popEncroachment :: Workspace s -> ST s Word32+  popEncroachment Workspace{wsEncroachment, wsEncroachmentSlot} = go+   where+    go = do+      size <- growableLength wsEncroachment+      if size <= 0+        then pure noIndex+        else do+          let !index = size - 1+          packed <- popGrowableOr noIndex wsEncroachment+          let !pair = fromIntegral packed+          slot <- MUV.unsafeRead wsEncroachmentSlot pair+          if slot == packIndex index+            then do+              MUV.unsafeWrite wsEncroachmentSlot pair noIndex+              pure packed+            else go++  -- The cavity epoch stamps three planes and is compared against them, so the+  -- wrap has to retire every stamp a reused value would answer for.+  nextCavityEpoch :: Workspace s -> ST s Word32+  nextCavityEpoch Workspace{wsCavityEpoch, wsCavityFaceMarks, wsCavityPairMarks, wsCavityVertexMarks} = do+    current <- readSTRef wsCavityEpoch+    let !next = current + 1+    if next == 0+      then do+        MUV.set wsCavityFaceMarks 0+        MUV.set wsCavityPairMarks 0+        MUV.set wsCavityVertexMarks 0+        writeSTRef wsCavityEpoch 1+        pure 1+      else do+        writeSTRef wsCavityEpoch next+        pure next++  loop :: Workspace s -> Int -> ST s (Either BuildError (Bool, Int, [Int], [Int], Int, Int))+  loop workspace@Workspace{wsQueue, wsForcedSplits} !added+    | added >= limit = finish workspace False added+    | otherwise = do+        forced <- popGrowableOr noIndex wsForcedSplits+        if forced /= noIndex+          then do+            splitOutcome <- resolveSplit workspace (fromIntegral forced)+            case splitOutcome of+              Left obstruction -> pure (Left obstruction)+              Right split ->+                if split+                  then loop workspace (added + 1)+                  else do+                    -- The split refused (degenerate position or a kept+                    -- constraint). Retrying the face that forced it would loop,+                    -- so one queued face is sacrificed, exactly the face whose+                    -- requeue sits on top.+                    _ <- popFace wsQueue+                    loop workspace added+          else do+            candidate <- popEncroachment workspace+            if candidate /= noIndex+              then do+                splitOutcome <- checkEncroachment workspace (fromIntegral candidate)+                case splitOutcome of+                  Left obstruction -> pure (Left obstruction)+                  Right split -> loop workspace (if split then added + 1 else added)+              else do+                next <- popFace wsQueue+                case next of+                  Nothing -> finish workspace True added+                  Just face -> do+                    outcome <- handleFace workspace face+                    case outcome of+                      Left failure -> pure (Left failure)+                      Right gained -> loop workspace (added + gained)++  finish :: Workspace s -> Bool -> Int -> ST s (Either BuildError (Bool, Int, [Int], [Int], Int, Int))+  finish Workspace{wsExcluded, wsVisited, wsInterfaceBoundaryReads, wsBoundaryCrossingAttempts} complete added = do+    faces <- faceCount mutable+    let gather :: [Int] -> Int -> ST s [Int]+        gather !collected face+          | face < 0 = pure collected+          | otherwise = do+              flagged <- MUV.unsafeRead wsExcluded face+              gather (if flagged then face : collected else collected) (face - 1)+    excludedFaces <- gather [] (min (MUV.length wsExcluded) faces - 1)+    visitedFaces <-+      case wsVisited of+        Nothing -> pure []+        Just visited -> do+          let gatherVisited :: [Int] -> Int -> ST s [Int]+              gatherVisited !collected face+                | face < 1 = pure collected+                | otherwise = do+                    flagged <- MUV.unsafeRead visited face+                    gatherVisited (if flagged then face : collected else collected) (face - 1)+          gatherVisited [] (min (MUV.length visited) faces - 1)+    interfaceBoundaryReads <- readSTRef wsInterfaceBoundaryReads+    boundaryCrossingAttempts <- readSTRef wsBoundaryCrossingAttempts+    pure (Right (complete, added, excludedFaces, visitedFaces, interfaceBoundaryReads, boundaryCrossingAttempts))++  offerAll :: FaceQueue s -> ST s ()+  offerAll queue = do+    faces <- faceCount mutable+    forM_ [1 .. faces - 1] (pushFace queue)++  -- A seeded run is not a weaker refinement interpreter. It begins at the+  -- supplied faces and asks only the fixed edges those faces can immediately+  -- encroach; every later cavity and star contributes its own local closure+  -- through the same queue and encroachment machinery as the global entry.+  seedInitialWork :: Workspace s -> RefinementInitialSeed -> ST s ()+  seedInitialWork workspace seed =+    case seed of+      RefineEveryFace -> seedFixedEdges workspace >> offerAll (wsQueue workspace)+      RefineSeededFaces faces ->+        traverse_ (seedFace workspace) (IntSet.toAscList faces)++  seedFace :: Workspace s -> Int -> ST s ()+  seedFace workspace face = do+    pushFace (wsQueue workspace) face+    (e0, e1, e2) <- faceEdges mutable face+    traverse_ (offerFixedEdge workspace) [e0, e1, e2]++  -- Every fixed edge present at entry, queued once for the existing-vertex+  -- encroachment question. Later candidates arrive from the star walks of the+  -- insertions that could have created a new encroachment.+  seedFixedEdges :: Workspace s -> ST s ()+  seedFixedEdges workspace = do+    halfEdges <- directedEdgeCount mutable+    traverse_+      (offerFixedEdge workspace . (2 *))+      [0 .. halfEdges `quot` 2 - 1]++  offerFixedEdge :: Workspace s -> Int -> ST s ()+  offerFixedEdge workspace directed = do+    fixed <- isFixedEdge directed+    let !pair = directed `quot` 2+    -- An interface is a fixed boundary condition, not a quality obligation+    -- owned by this section. It is still encountered by candidate cavities,+    -- where any demand to split or cross it is a typed obstruction.+    when (fixed && not (isInterfacePair pair)) $+      pushEncroachment workspace pair++  isFixedEdge :: Int -> ST s Bool+  isFixedEdge directed = do+    if isInterfacePair (directed `quot` 2)+      then pure True+      else do+        protected <- readConstraint mutable directed+        if protected+          then pure True+          else do+            own <- readFace mutable directed+            if own == 0+              then pure True+              else (== 0) <$> readFace mutable (reverseIndex directed)++  isInterfacePair :: Int -> Bool+  isInterfacePair pair =+    maybe False (IntSet.member pair . refinementDomainInterfacePairs) domain+  {-# INLINE isInterfacePair #-}++  interfaceCrossing :: Workspace s -> Int -> ST s BuildError+  interfaceCrossing Workspace{wsPermitted, wsBoundaryCrossingAttempts} pair = do+    modifySTRef' wsBoundaryCrossingAttempts (+ 1)+    forwardFace <- readFace mutable (2 * pair)+    backwardFace <- readFace mutable (2 * pair + 1)+    joinFace <-+      case wsPermitted of+        Nothing -> pure Nothing+        Just permitted -> do+          forwardPermitted <- dynamicPermitted permitted forwardFace+          backwardPermitted <- dynamicPermitted permitted backwardFace+          pure+            ( if forwardPermitted+                then Just forwardFace+                else if backwardPermitted then Just backwardFace else Nothing+            )+    pure+      ( case joinFace of+          Just face ->+            RefinementDomainWouldCrossInterface+              (UndirectedEdgeId (fromIntegral pair))+              (FaceId (fromIntegral face))+          Nothing -> RefinementDomainTopologyChanged+      )+   where+    dynamicPermitted :: MUV.MVector s Bool -> Int -> ST s Bool+    dynamicPermitted membership face =+      if face > 0 && face < MUV.length membership+        then MUV.unsafeRead membership face+        else pure False++  -- The area bound condemns outright ('FaceMustRefine'); the ratio bound only+  -- invites refinement, which the input-angle guard may still decline. The+  -- ratio is left for last: a face the area bound has already judged needs no+  -- second reason, and the ratio is the more expensive of the two questions.+  faceHint :: Point -> Point -> Point -> FaceHint+  faceHint p0 p1 p2+    | areaBad = FaceMustRefine+    | belowMinimum = FaceAcceptable+    | angleBad = FaceShouldRefine+    | otherwise = FaceAcceptable+   where+    !area = triangleArea p0 p1 p2+    areaBad = maybe False (exceeds area) maximumArea+    belowMinimum = maybe False (area <) minimumArea+    angleBad = case squaredRatioBound of+      Nothing -> False+      Just bound -> exceeds (triangleRadiusEdgeRatioSquaredWithArea area p0 p1 p2) bound++  handleFace :: Workspace s -> Int -> ST s (Either BuildError Int)+  handleFace workspace@Workspace{wsExcluded, wsPermitted, wsVisited} face = do+    addCounter operation CounterRefinementQueuePops 1+    permitted <-+      maybe+        (pure True)+        (\membership -> MUV.unsafeRead membership face)+        wsPermitted+    if not permitted+      then pure (Left (RefinementDomainWouldRewriteProtectedFace (FaceId (fromIntegral face))))+      else do+        traverse_ (\visited -> MUV.unsafeWrite visited face True) wsVisited+        skip <- MUV.unsafeRead wsExcluded face+        if skip+          then pure (Right 0)+          else do+            addCounter operation CounterRefinementFaceChecks 1+            (e0, e1, e2) <- faceEdges mutable face+            p0 <- edgeOriginPoint mutable e0+            p1 <- edgeOriginPoint mutable e1+            p2 <- edgeOriginPoint mutable e2+            case faceHint p0 p1 p2 of+              FaceAcceptable -> pure (Right 0)+              FaceMustRefine -> attemptCandidate workspace face p0 p1 p2+              FaceShouldRefine -> do+                blocked <- inputAngleBlocks workspace e0 e1 e2 p0 p1 p2+                if blocked+                  then pure (Right 0)+                  else attemptCandidate workspace face p0 p1 p2++  -- Two subsegments of one original segment meeting at a small input angle+  -- cannot be refined apart: the angle is fixed by the input geometry. When+  -- the shortest edge of a ratio-bound face joins two Steiner vertices whose+  -- lineages share an original endpoint, the face is as good as it gets.+  inputAngleBlocks :: Workspace s -> Int -> Int -> Int -> Point -> Point -> Point -> ST s Bool+  inputAngleBlocks Workspace{wsSegmentOrigin} e0 e1 e2 p0 p1 p2 = do+    let !shortest = shortestFaceEdge e0 e1 e2 p0 p1 p2+    a <- readOrigin mutable shortest+    b <- readOrigin mutable (reverseIndex shortest)+    shared <- sharedSegmentOrigin wsSegmentOrigin a b+    if not shared+      then pure False+      else not <$> isFixedEdge shortest++  shortestFaceEdge :: Int -> Int -> Int -> Point -> Point -> Point -> Int+  shortestFaceEdge e0 e1 e2 p0 p1 p2+    | side01 <= side12 && side01 <= side20 = e0+    | side12 <= side20 = e1+    | otherwise = e2+   where+    !side01 = squaredDistanceWide p0 p1+    !side12 = squaredDistanceWide p1 p2+    !side20 = squaredDistanceWide p2 p0++  sharedSegmentOrigin :: MUV.MVector s Word32 -> Int -> Int -> ST s Bool+  sharedSegmentOrigin lineage a b = do+    a0 <- MUV.unsafeRead lineage (2 * a)+    a1 <- MUV.unsafeRead lineage (2 * a + 1)+    b0 <- MUV.unsafeRead lineage (2 * b)+    b1 <- MUV.unsafeRead lineage (2 * b + 1)+    pure (a0 /= noIndex && b0 /= noIndex && (a0 == b0 || a0 == b1 || a1 == b0 || a1 == b1))++  validCandidate :: Point -> Maybe (Point)+  validCandidate point@(Point x y)+    | validateCoordinate x == Nothing && validateCoordinate y == Nothing = Just point+    | otherwise = Nothing++  attemptCandidate :: Workspace s -> Int -> Point -> Point -> Point -> ST s (Either BuildError Int)+  attemptCandidate workspace@Workspace{wsExcluded, wsForcedSplits} face p0 p1 p2 =+    case circumcenter p0 p1 p2 >>= validCandidate of+      Nothing -> pure (Right 0)+      Just point -> do+        located <- locateMutable mutable operation (Just face) point+        case located of+          Left failure -> pure (Left failure)+          Right site -> case site of+            MutableOnVertex _ -> pure (Right 0)+            MutableEmpty -> pure (Right 0)+            MutableOutsideHull edge+              | refinePreserveConvexHull parameters -> pure (Right 0)+              | otherwise -> attemptOutside workspace face point edge+            MutableOnEdge edge -> do+              if isInterfacePair (edge `quot` 2)+                then Left <$> interfaceCrossing workspace (edge `quot` 2)+                else do+                  protected <- readConstraint mutable edge+                  if protected+                    then do+                      -- A circumcenter on a constraint is a request to split that+                      -- constraint, unless constraints are kept whole.+                      unless (refineKeepConstraintEdges parameters) $+                        pushGrowable wsForcedSplits (packIndex (edge `quot` 2))+                      pure (Right 0)+                    else exploreThenCommit workspace face point site+            MutableInFace under -> do+              permittedSite <-+                maybe+                  (pure True)+                  (\membership -> MUV.unsafeRead membership under)+                  (wsPermitted workspace)+              if not permittedSite+                then pure (Left (RefinementDomainWouldRewriteProtectedFace (FaceId (fromIntegral under))))+                else do+                  excludedSite <- MUV.unsafeRead wsExcluded under+                  if excludedSite+                    then pure (Right 0)+                    else exploreThenCommit workspace face point site++  -- Follow the prospective legalization cavity of the candidate without+  -- mutating topology, recording what the commit will consume: the cavity+  -- faces, the internal edge pairs, and the ordered boundary. Fixed edges are+  -- never crossed: the ones the cavity meets become boundary and are tested+  -- against the candidate's diametral disk. Every encroached fixed edge met+  -- is queued for splitting and the source face is revisited afterwards; a+  -- clean cavity is committed directly.+  exploreThenCommit :: Workspace s -> Int -> Point -> MutableLocation -> ST s (Either BuildError Int)+  exploreThenCommit workspace@Workspace{wsQueue, wsForcedSplits} face point site = do+    (visible, encroached) <- exploreCavity workspace point site+    case find isInterfacePair encroached of+      Just pair -> Left <$> interfaceCrossing workspace pair+      Nothing ->+        if null encroached+          then commitCavity workspace point site visible+          else do+            pushable <- filterM splittablePair encroached+            forM_ pushable $ \pair -> pushGrowable wsForcedSplits (packIndex pair)+            unless (null pushable) $ pushFace wsQueue face+            pure (Right 0)++  splittablePair :: Int -> ST s Bool+  splittablePair pair =+    if isInterfacePair pair+      then pure False+      else if refineKeepConstraintEdges parameters+      then not <$> readConstraint mutable (2 * pair)+      else pure True++  admitStar :: Workspace s -> Int -> ST s ()+  admitStar Workspace{wsPermitted} vertex =+    traverse_+      (\membership ->+         forEachStarFace vertex (\face -> MUV.unsafeWrite membership face True)+      )+      wsPermitted++  -- The flood never mutates, so a popped edge can be retested idempotently:+  -- an edge whose far face conflicts crosses, marks the face, and pushes that+  -- face's other two edges; each directed edge has at most its two+  -- face-neighbours as pushers, and a revisited crossing is deduplicated by+  -- the face and pair stamps. Boundary visibility for the fan is accumulated+  -- in place: every boundary edge is asked here, where its endpoints are+  -- already loaded, whether the point sees it from the cavity side.+  exploreCavity :: Workspace s -> Point -> MutableLocation -> ST s (Bool, [Int])+  exploreCavity workspace@Workspace{wsVisited, wsCavityFaceMarks, wsCavityPairMarks, wsCavityFaces, wsCavityInternal, wsCavityBoundary, wsCavityCocircular, wsCavityWork} point site = do+    next <- nextCavityEpoch workspace+    clearGrowable wsCavityFaces+    clearGrowable wsCavityInternal+    clearGrowable wsCavityBoundary+    clearGrowable wsCavityCocircular+    clearGrowable wsCavityWork+    seedVisible <- case site of+      MutableInFace under -> do+        markFace next under+        (e0, e1, e2) <- faceEdges mutable under+        pushCavityWork e0+        pushCavityWork e1+        pushCavityWork e2+        pure True+      MutableOnEdge edge -> do+        seedAcross next edge+        seedAcross next (reverseIndex edge)+        -- The located edge is never encroachment-tested: a point on it lies+        -- trivially inside its own diametral circle, and the question would+        -- force the same split forever. A fixed edge is boundary; any other+        -- is the cavity's first internal pair. Its visibility still counts.+        fixed <- isFixedEdge edge+        if fixed+          then do+            pushGrowable wsCavityBoundary (packIndex edge)+            from <- edgeOriginPoint mutable edge+            to <- edgeOriginPoint mutable (reverseIndex edge)+            pure (orient2d from to point == GT)+          else do+            recordInternal next (edge `quot` 2)+            pure True+      _ -> pure True+    drain next [] seedVisible+   where+    markFace :: Word32 -> Int -> ST s ()+    markFace epoch face = do+      MUV.unsafeWrite wsCavityFaceMarks face epoch+      traverse_ (\visited -> MUV.unsafeWrite visited face True) wsVisited+      pushGrowable wsCavityFaces (packIndex face)++    isMarked :: Word32 -> Int -> ST s Bool+    isMarked epoch face = (== epoch) <$> MUV.unsafeRead wsCavityFaceMarks face++    recordInternal :: Word32 -> Int -> ST s ()+    recordInternal epoch pair = do+      seen <- MUV.unsafeRead wsCavityPairMarks pair+      when (seen /= epoch) $ do+        MUV.unsafeWrite wsCavityPairMarks pair epoch+        pushGrowable wsCavityInternal (packIndex pair)++    -- The flood's stack traffic is transaction-local and owns no diagnostics;+    -- the charged wrapper would report every push as legalization depth.+    pushCavityWork :: Int -> ST s ()+    pushCavityWork value = pushGrowable wsCavityWork (packIndex value)++    seedAcross :: Word32 -> Int -> ST s ()+    seedAcross epoch directed = do+      adjacent <- readFace mutable directed+      when (adjacent /= 0) $ do+        markFace epoch adjacent+        next <- readNext mutable directed+        previous <- readPrevious mutable directed+        pushCavityWork next+        pushCavityWork previous++    -- Visibility is read by the caller only when nothing was encroached, so+    -- the first encroached edge retires the question: every later boundary+    -- edge skips the orientation that would only be conjoined into a value+    -- about to be discarded.+    drain :: Word32 -> [Int] -> Bool -> ST s (Bool, [Int])+    drain epoch = go+     where+      go !acc !visible = do+        packed <- popGrowableOr noIndex wsCavityWork+        if packed == noIndex+          then pure (visible, acc)+          else do+            let !directed = fromIntegral packed+            fixed <- isFixedEdge directed+            if fixed+              then do+                pushGrowable wsCavityBoundary (packIndex directed)+                from <- edgeOriginPoint mutable directed+                to <- edgeOriginPoint mutable (reverseIndex directed)+                let pair = directed `quot` 2+                    encroached = inDiametralCircle from to point+                when (isInterfacePair pair && not encroached) $+                  modifySTRef' (wsInterfaceBoundaryReads workspace) (+ 1)+                if encroached+                  then go (pair : acc) False+                  else go acc (visible && orient2d from to point == GT)+              else do+                across <- readFace mutable (reverseIndex directed)+                marked <- isMarked epoch across+                if marked+                  then do+                    recordInternal epoch (directed `quot` 2)+                    go acc visible+                  else do+                    let !twin = reverseIndex directed+                    acrossPrevious <- readPrevious mutable twin+                    opposite <- readOrigin mutable acrossPrevious+                    from <- edgeOriginPoint mutable directed+                    to <- pointAt mutable =<< readOrigin mutable twin+                    acrossPoint <- pointAt mutable opposite+                    let !verdict = inCircle to from acrossPoint point+                    if verdict == GT+                      then do+                        markFace epoch across+                        recordInternal epoch (directed `quot` 2)+                        acrossNext <- readNext mutable twin+                        pushCavityWork acrossNext+                        pushCavityWork acrossPrevious+                        go acc visible+                      else do+                        pushGrowable wsCavityBoundary (packIndex directed)+                        when (verdict == EQ) $+                          pushGrowable wsCavityCocircular (packIndex directed)+                        go acc (visible && orient2d from to point == GT)++  -- The flood never mutates, so a popped edge can be retested idempotently:+  -- an edge whose far face conflicts pushes that face's other two edges, and+  -- each directed edge has at most its two face-neighbours as pushers.+  drainSimulation :: GrowableWord32 s -> Point -> [Int] -> ST s [Int]+  drainSimulation work point = go+   where+    go :: [Int] -> ST s [Int]+    go !acc = do+      packed <- popGrowableOr noIndex work+      if packed == noIndex+        then pure acc+        else do+          let !directed = fromIntegral packed+          fixed <- isFixedEdge directed+          if fixed+            then do+              from <- edgeOriginPoint mutable directed+              to <- edgeOriginPoint mutable (reverseIndex directed)+              if inDiametralCircle from to point+                then go (directed `quot` 2 : acc)+                else go acc+            else do+              let !twin = reverseIndex directed+              acrossPrevious <- readPrevious mutable twin+              opposite <- readOrigin mutable acrossPrevious+              from <- edgeOriginPoint mutable directed+              to <- pointAt mutable =<< readOrigin mutable twin+              across <- pointAt mutable opposite+              if inCircle to from across point == GT+                then do+                  acrossNext <- readNext mutable twin+                  pushChargedWork work acrossNext+                  pushChargedWork work acrossPrevious+                  go acc+                else go acc++  -- A cavity the fan commit cannot take: a degenerate or barrier-bent+  -- boundary, a pinched boundary walk, or a duplicate site. The located site+  -- commits through the ordinary split-and-legalize path instead; the+  -- recorded cavity is simply abandoned.+  commitFlipCandidate :: Workspace s -> Point -> MutableLocation -> ST s (Either BuildError Int)+  commitFlipCandidate workspace@Workspace{wsQueue, wsExcluded} point site = do+    let !canonical = canonicalPoint point+    vertex <- appendVertex mutable canonical (makeVertex canonical)+    splitSides <- case site of+      MutableOnEdge edge+        | refineExcludeOuterFaces parameters -> do+            own <- readFace mutable edge+            let !inner = if own == 0 then reverseIndex edge else edge+            leftFace <- readFace mutable inner+            rightFace <- readFace mutable (reverseIndex inner)+            leftExcluded <- MUV.unsafeRead wsExcluded leftFace+            rightExcluded <- sideExcluded wsExcluded (reverseIndex inner)+            faceBase <- faceCount mutable+            pure (Just (leftFace, leftExcluded, rightFace, rightExcluded, faceBase))+      _ -> pure Nothing+    inserted <- insertExistingVertexAtLocation @'ProbeOff mutable operation vertex site+    case inserted of+      Left failure -> pure (Left failure)+      Right () -> do+        addCounter operation CounterSteinerPoints 1+        admitStar workspace vertex+        case splitSides of+          Just (leftFace, leftExcluded, rightFace, rightExcluded, faceBase) ->+            inheritSplitExclusion wsExcluded leftFace leftExcluded rightFace rightExcluded faceBase+          Nothing -> pure ()+        forEachStarFace vertex $ \starFace -> do+          skip <- MUV.unsafeRead wsExcluded starFace+          unless skip $ pushFace wsQueue starFace+        pure (Right 1)++  -- Commit a clean cavity by fanning its boundary to the new vertex. The+  -- recorded cavity faces and internal pairs are recycled into fan faces and+  -- spokes; exactly two faces and three edge pairs are appended, whatever the+  -- cavity's size. Any boundary that is not a simple, strictly-visible cycle+  -- falls back to the split-and-legalize commit: that is the degenerate and+  -- the barrier-bent case, never an error.+  commitCavity :: Workspace s -> Point -> MutableLocation -> Bool -> ST s (Either BuildError Int)+  commitCavity workspace@Workspace{wsCavityFaces, wsCavityInternal, wsCavityBoundary} point site visible = do+    boundaryCount <- growableLength wsCavityBoundary+    cavityFaceCount <- growableLength wsCavityFaces+    internalCount <- growableLength wsCavityInternal+    chained <-+      if visible && boundaryCount == cavityFaceCount + 2 && boundaryCount == internalCount + 3+        then chainBoundary workspace boundaryCount+        else pure False+    if chained+      then fanCommit workspace point boundaryCount cavityFaceCount internalCount+      else commitFlipCandidate workspace point site++  -- Order the recorded boundary edges into the cycle they form, starting each+  -- successor by rotating around the current edge's destination. The records+  -- agree with a simple cycle only when the walk closes after exactly the+  -- recorded count and meets no boundary vertex twice; anything else is the+  -- pinched case the fan cannot take.+  chainBoundary :: Workspace s -> Int -> ST s Bool+  chainBoundary Workspace{wsCavityEpoch, wsCavityFaceMarks, wsCavityVertexMarks, wsCavityBoundary, wsCavityChain} count = do+    epoch <- readSTRef wsCavityEpoch+    budget <- directedEdgeCount mutable+    start <- fromIntegral <$> readGrowable wsCavityBoundary 0+    clearGrowable wsCavityChain+    pushGrowable wsCavityChain (packIndex start)+    walk epoch (budget + 2) start start (count - 1)+   where+    walk :: Word32 -> Int -> Int -> Int -> Int -> ST s Bool+    walk epoch budget start current remaining = do+      destination <- readOrigin mutable (reverseIndex current)+      seen <- MUV.unsafeRead wsCavityVertexMarks destination+      if seen == epoch+        then pure False+        else do+          MUV.unsafeWrite wsCavityVertexMarks destination epoch+          successor <- nextBoundaryEdge epoch budget current+          if remaining == 0+            then pure (successor == start)+            else+              if successor == start+                then pure False+                else do+                  pushGrowable wsCavityChain (packIndex successor)+                  walk epoch budget start successor (remaining - 1)++    nextBoundaryEdge :: Word32 -> Int -> Int -> ST s Int+    nextBoundaryEdge epoch budget edge = do+      first <- readNext mutable edge+      rotate first budget+     where+      rotate candidate !remaining+        | remaining <= 0 = pure candidate+        | otherwise = do+            adjacent <- readFace mutable candidate+            markedHere <- (== epoch) <$> MUV.unsafeRead wsCavityFaceMarks adjacent+            across <- readFace mutable (reverseIndex candidate)+            markedAcross <- (== epoch) <$> MUV.unsafeRead wsCavityFaceMarks across+            if markedHere && not markedAcross+              then pure candidate+              else do+                following <- readNext mutable (reverseIndex candidate)+                rotate following (remaining - 1)++  fanCommit :: Workspace s -> Point -> Int -> Int -> Int -> ST s (Either BuildError Int)+  fanCommit workspace@Workspace{wsQueue, wsExcluded, wsCavityFaces, wsCavityInternal, wsCavityCocircular, wsCavityChain} point boundaryCount cavityFaceCount internalCount = do+    capacity <- ensureCellCapacity mutable (boundaryCount - internalCount) (boundaryCount - cavityFaceCount)+    case capacity of+      Left obstruction -> pure (Left obstruction)+      Right () -> fanCommitWithCapacity+   where+    fanCommitWithCapacity = do+      let !canonical = canonicalPoint point+      vertex <- appendVertex mutable canonical (makeVertex canonical)+      faceBase <- addFaceBlock mutable (boundaryCount - cavityFaceCount)+      edgeBase <- addEdgeBlock mutable (boundaryCount - internalCount)+      firstPair <- fanPair edgeBase 0+      let spoke :: Int -> Int -> ST s ()+          spoke !index !pair+            | index >= boundaryCount = pure ()+            | otherwise = do+                boundaryEdge <- fromIntegral <$> readGrowable wsCavityChain index+                face <- fanFace faceBase index+                nextPair <-+                  if index + 1 >= boundaryCount+                    then pure firstPair+                    else fanPair edgeBase (index + 1)+                origin <- readOrigin mutable boundaryEdge+                writeOrigin mutable (2 * pair) origin+                writeOrigin mutable (2 * pair + 1) vertex+                setCycle3 mutable face boundaryEdge (2 * nextPair) (2 * pair + 1)+                writeVertexOut mutable origin boundaryEdge+                -- 'fanFace' and 'fanPair' hand back the cavity's own faces and+                -- interior edges before they hand out new ones. A recycled slot+                -- is given a spoke to the Steiner vertex and a triangle that did+                -- not exist, so whatever the cavity element it displaced was+                -- labelled with does not survive.+                resetEdgeData mutable pair+                resetFaceData mutable face+                spoke (index + 1) nextPair+      spoke 0 firstPair+      markConnected mutable vertex (2 * firstPair + 1)+      addCounter operation CounterSteinerPoints 1+      admitStar workspace vertex+      -- Exactly-cocircular boundary quads are legal ties for the flip+      -- commit but not for a static boundary. Only those edges are drained:+      -- the flood already decided every other boundary edge's quad, so a+      -- full shouldFlip pass would ask again what it already answered.+      cocircular <- growableLength wsCavityCocircular+      when (cocircular > 0) $ do+        ties <- traverse (\index -> fromIntegral <$> readGrowable wsCavityCocircular index) [0 .. cocircular - 1]+        legalizeEdges mutable operation ties+      let offer :: Int -> ST s ()+          offer !index+            | index >= boundaryCount = pure ()+            | otherwise = do+                face <- fanFace faceBase index+                skip <- MUV.unsafeRead wsExcluded face+                unless skip $ pushFace wsQueue face+                offer (index + 1)+      offer 0+      pure (Right 1)++    fanFace :: Int -> Int -> ST s Int+    fanFace faceBase index+      | index < cavityFaceCount = fromIntegral <$> readGrowable wsCavityFaces index+      | otherwise = pure (faceBase + (index - cavityFaceCount))++    fanPair :: Int -> Int -> ST s Int+    fanPair edgeBase index+      | index < internalCount = fromIntegral <$> readGrowable wsCavityInternal index+      | otherwise = pure ((edgeBase + 2 * (index - internalCount)) `quot` 2)++  -- A candidate outside the hull (only reachable when the hull is not+  -- preserved) preflights against the whole visible hull chain: the+  -- prospective cavity reaches the hull, so the chain edges are exactly the+  -- fixed edges the insertion would meet.+  attemptOutside :: Workspace s -> Int -> Point -> Int -> ST s (Either BuildError Int)+  attemptOutside workspace@Workspace{wsQueue, wsExcluded, wsForcedSplits, wsCavityWork} face point edge = do+    chain <- visibleChain edge point+    clearGrowable wsCavityWork+    forM_ chain $ \hull -> do+      pushChargedWork wsCavityWork hull+      let !inner = reverseIndex hull+      innerFace <- readFace mutable inner+      when (innerFace /= 0) $ do+        next <- readNext mutable inner+        previous <- readPrevious mutable inner+        pushChargedWork wsCavityWork next+        pushChargedWork wsCavityWork previous+    encroached <- drainSimulation wsCavityWork point []+    if not (null encroached)+      then do+        pushable <- filterM splittablePair encroached+        forM_ pushable $ \pair -> pushGrowable wsForcedSplits (packIndex pair)+        unless (null pushable) $ pushFace wsQueue face+        pure (Right 0)+      else do+        let !canonical = canonicalPoint point+        vertex <- appendVertex mutable canonical (makeVertex canonical)+        inserted <- insertExistingVertexAtLocation @'ProbeOff mutable operation vertex (MutableOutsideHull edge)+        case inserted of+          Left failure -> pure (Left failure)+          Right () -> do+            addCounter operation CounterSteinerPoints 1+            admitStar workspace vertex+            when (refineExcludeOuterFaces parameters) $ do+              seedCount <- newSTRef 0+              forEachStarFace vertex $ \starFace -> do+                MUV.unsafeWrite wsExcluded starFace True+                count <- readSTRef seedCount+                writeScratch operation count starFace+                writeSTRef seedCount (count + 1)+              count <- readSTRef seedCount+              propagateExcluded wsExcluded count+            forEachStarFace vertex $ \starFace -> do+              skip <- MUV.unsafeRead wsExcluded starFace+              unless skip $ pushFace wsQueue starFace+            forEachStarFace vertex $ \starFace -> do+              (e0, e1, e2) <- faceEdges mutable starFace+              forM_ [e0, e1, e2] $ \directed -> do+                fixed <- isFixedEdge directed+                when fixed $ pushEncroachment workspace (directed `quot` 2)+            pure (Right 1)++  -- The maximal run of outer-cycle edges visible from the candidate, centred+  -- on the edge location reported. Bounded by the hull length.+  visibleChain :: Int -> Point -> ST s [Int]+  visibleChain edge point = do+    halfEdges <- directedEdgeCount mutable+    left <- expand (readPrevious mutable) (halfEdges + 1) edge+    right <- expand (readNext mutable) (halfEdges + 1) edge+    walk left right (halfEdges + 1) []+   where+    expand :: (Int -> ST s Int) -> Int -> Int -> ST s Int+    expand step !budget !current+      | budget <= 0 = pure current+      | otherwise = do+          candidate <- step current+          if candidate == edge+            then pure current+            else do+              from <- edgeOriginPoint mutable candidate+              to <- edgeOriginPoint mutable (reverseIndex candidate)+              if orient2d from to point == GT+                then expand step (budget - 1) candidate+                else pure current++    walk :: Int -> Int -> Int -> [Int] -> ST s [Int]+    walk !current !end !budget !acc+      | budget <= 0 = pure acc+      | current == end = pure (current : acc)+      | otherwise = do+          following <- readNext mutable current+          walk following end (budget - 1) (current : acc)++  -- New faces outside the hull sit at barrier depth zero; whatever they now+  -- reach without crossing a constraint joined the outer region with them.+  propagateExcluded :: MUV.MVector s Bool -> Int -> ST s ()+  propagateExcluded excluded = drain+   where+    drain :: Int -> ST s ()+    drain !count+      | count <= 0 = pure ()+      | otherwise = do+          face <- readScratch operation (count - 1)+          (e0, e1, e2) <- faceEdges mutable face+          next <- spread (count - 1) e0 >>= (`spread` e1) >>= (`spread` e2)+          drain next++    spread :: Int -> Int -> ST s Int+    spread !count !directed = do+      protected <- readConstraint mutable directed+      if protected+        then pure count+        else do+          adjacent <- readFace mutable (reverseIndex directed)+          if adjacent == 0+            then pure count+            else do+              already <- MUV.unsafeRead excluded adjacent+              if already+                then pure count+                else do+                  MUV.unsafeWrite excluded adjacent True+                  writeScratch operation count adjacent+                  pure (count + 1)++  -- A queued fixed edge against the vertices currently opposite it, from each+  -- non-excluded side. A stale candidate simply answers for the subsegment+  -- its handle now names, which is the edge the queue cares about.+  checkEncroachment :: Workspace s -> Int -> ST s (Either BuildError Bool)+  checkEncroachment workspace@Workspace{wsExcluded} pair = do+    let !directed = 2 * pair+    first <- sideEncroaches wsExcluded directed+    encroached <-+      if first+        then pure True+        else sideEncroaches wsExcluded (reverseIndex directed)+    if encroached+      then+        if isInterfacePair pair+          then Left <$> interfaceCrossing workspace pair+          else resolveSplit workspace pair+      else pure (Right False)+   where+    sideEncroaches :: MUV.MVector s Bool -> Int -> ST s Bool+    sideEncroaches excluded side = do+      adjacent <- readFace mutable side+      if adjacent == 0+        then pure False+        else do+          skip <- MUV.unsafeRead excluded adjacent+          if skip+            then pure False+            else do+              opposite <- readOrigin mutable =<< readPrevious mutable side+              query <- pointAt mutable opposite+              from <- edgeOriginPoint mutable side+              to <- edgeOriginPoint mutable (reverseIndex side)+              pure (inDiametralCircle from to query)++  -- Split a fixed edge. A first split lands at the midpoint; a subsegment+  -- split rounds its offset to the nearest power of two toward the original+  -- endpoint, so segments meeting at a small input angle stop encroaching+  -- each other instead of subdividing forever.+  resolveSplit :: Workspace s -> Int -> ST s (Either BuildError Bool)+  resolveSplit workspace@Workspace{wsExcluded, wsSegmentOrigin} pair = do+    let !directed = 2 * pair+    protected <- readConstraint mutable directed+    if isInterfacePair pair+      then Left <$> interfaceCrossing workspace pair+      else if refineKeepConstraintEdges parameters && protected+      then pure (Right False)+      else do+        v0 <- readOrigin mutable directed+        v1 <- readOrigin mutable (reverseIndex directed)+        from <- pointAt mutable v0+        to <- pointAt mutable v1+        lineage0 <- MUV.unsafeRead wsSegmentOrigin (2 * v0)+        lineage1 <- MUV.unsafeRead wsSegmentOrigin (2 * v1)+        let !onSegment0 = lineage0 /= noIndex+            !onSegment1 = lineage1 /= noIndex+            !splitPoint = splitPosition onSegment0 onSegment1 from to+        valid <- validateSplitPosition directed splitPoint+        if not valid+          then pure (Right False)+          else do+            -- Inheritance is read as structural face identities, never as+            -- post-split handle membership: the split's own legalization can+            -- flip seeded edges and relocate handles before any read, but it+            -- cannot rename a face. The kept side faces and the append base+            -- name the sides exactly.+            own <- readFace mutable directed+            let !inner = if own == 0 then reverseIndex directed else directed+            leftFace <- readFace mutable inner+            rightFace <- readFace mutable (reverseIndex inner)+            leftExcluded <- MUV.unsafeRead wsExcluded leftFace+            rightExcluded <- sideExcluded wsExcluded (reverseIndex inner)+            faceBase <- faceCount mutable+            let !canonical = canonicalPoint splitPoint+            vertex <- appendVertex mutable canonical (makeVertex canonical)+            inserted <- insertOnEdge @'ProbeOff mutable operation directed vertex+            case inserted of+              Left obstruction -> pure (Left obstruction)+              Right () -> do+                admitStar workspace vertex+                if onSegment0+                  then do+                    second <- MUV.unsafeRead wsSegmentOrigin (2 * v0 + 1)+                    writeSegmentOrigin wsSegmentOrigin vertex lineage0 second+                  else+                    if onSegment1+                      then do+                        second <- MUV.unsafeRead wsSegmentOrigin (2 * v1 + 1)+                        writeSegmentOrigin wsSegmentOrigin vertex lineage1 second+                      else writeSegmentOrigin wsSegmentOrigin vertex (packIndex v0) (packIndex v1)+                when (refineExcludeOuterFaces parameters) $+                  inheritSplitExclusion wsExcluded leftFace leftExcluded rightFace rightExcluded faceBase+                addCounter operation CounterSteinerPoints 1+                pushStarAfterSplit workspace vertex+                pure (Right True)++  splitPosition :: Bool -> Bool -> Point -> Point -> Point+  splitPosition onSegment0 onSegment1 from to+    | not onSegment0 && not onSegment1 = midpoint from to+    | otherwise =+        let !halfLength = sqrt (squaredDistance from to) * 0.5+         in if not (isFinite halfLength) || halfLength <= 0+              then midpoint from to+              else+                let !nearest = 2 ** fromIntegral (round (logBase 2 halfLength) :: Int)+                    !otherWeight = 0.5 * nearest / halfLength+                    !originalWeight = 1 - otherWeight+                    (!weight0, !weight1) =+                      if onSegment0+                        then (otherWeight, originalWeight)+                        else (originalWeight, otherWeight)+                    Point fromX fromY = from+                    Point toX toY = to+                 in Point (fromX * weight0 + toX * weight1) (fromY * weight0 + toY * weight1)++  -- The split is refused when the constructed vertex would leave one of the+  -- four new faces degenerate or clockwise — for an in-segment point that is+  -- exactly the coincidence-with-an-endpoint-or-opposite case.+  validateSplitPosition :: Int -> Point -> ST s Bool+  validateSplitPosition directed splitPoint@(Point splitX splitY)+    | validateCoordinate splitX /= Nothing = pure False+    | validateCoordinate splitY /= Nothing = pure False+    | otherwise = do+        from <- edgeOriginPoint mutable directed+        to <- edgeOriginPoint mutable (reverseIndex directed)+        first <- sideKeepsOrientation directed from to+        if not first+          then pure False+          else sideKeepsOrientation (reverseIndex directed) to from+   where+    sideKeepsOrientation :: Int -> Point -> Point -> ST s Bool+    sideKeepsOrientation side sideFrom sideTo = do+      adjacent <- readFace mutable side+      if adjacent == 0+        then pure True+        else do+          opposite <- readOrigin mutable =<< readPrevious mutable side+          oppositePoint <- pointAt mutable opposite+          pure+            ( orient2d sideFrom oppositePoint splitPoint == LT+                && orient2d oppositePoint sideTo splitPoint == LT+            )++  sideExcluded :: MUV.MVector s Bool -> Int -> ST s Bool+  sideExcluded excluded side = do+    adjacent <- readFace mutable side+    if adjacent == 0 then pure True else MUV.unsafeRead excluded adjacent++  -- A split keeps each side's classification. The faces a side holds+  -- afterwards are the side face it kept and the face appended over it:+  -- interior splits append two, boundary splits one, and both ids are+  -- immune to the legalization that runs between the geometry and here.+  inheritSplitExclusion :: MUV.MVector s Bool -> Int -> Bool -> Int -> Bool -> Int -> ST s ()+  inheritSplitExclusion excluded leftFace leftExcluded rightFace rightExcluded faceBase = do+    writeSide leftExcluded leftFace+    writeSide leftExcluded faceBase+    when (rightFace /= 0) $ do+      writeSide rightExcluded rightFace+      writeSide rightExcluded (faceBase + 1)+   where+    writeSide :: Bool -> Int -> ST s ()+    writeSide status side = do+      when (side /= 0) $ MUV.unsafeWrite excluded side status++  writeSegmentOrigin :: MUV.MVector s Word32 -> Int -> Word32 -> Word32 -> ST s ()+  writeSegmentOrigin lineage vertex first second = do+    MUV.unsafeWrite lineage (2 * vertex) first+    MUV.unsafeWrite lineage (2 * vertex + 1) second++  pushStarAfterSplit :: Workspace s -> Int -> ST s ()+  pushStarAfterSplit workspace@Workspace{wsQueue} vertex =+    forEachStarFace vertex $ \starFace -> do+      pushFace wsQueue starFace+      (e0, e1, e2) <- faceEdges mutable starFace+      forM_ [e0, e1, e2] $ \directed -> do+        fixed <- isFixedEdge directed+        when fixed $ pushEncroachment workspace (directed `quot` 2)++  -- Every interior face incident to a vertex, once. One rotation direction+  -- covers a full interior star; a hull star additionally needs the other+  -- direction from the starting edge.+  forEachStarFace :: Int -> (Int -> ST s ()) -> ST s ()+  forEachStarFace vertex visit = do+    start <- readVertexOut mutable vertex+    when (start >= 0) $ do+      wrapped <- rotate start start+      unless wrapped (rotateBack start)+   where+    rotate :: Int -> Int -> ST s Bool+    rotate !start !edge = do+      adjacent <- readFace mutable edge+      if adjacent == 0+        then pure False+        else do+          visit adjacent+          next <- reverseIndex <$> readPrevious mutable edge+          if next == start then pure True else rotate start next++    rotateBack :: Int -> ST s ()+    rotateBack edge = do+      let !twin = reverseIndex edge+      adjacent <- readFace mutable twin+      when (adjacent /= 0) $ do+        visit adjacent+        next <- readNext mutable twin+        rotateBack next++-- | Whether a measurement is over its bound. A non-positive bound admits+-- nothing, which is what dividing by it used to say by returning an infinity+-- that then compared greater than one.+exceeds :: Double -> Double -> Bool+exceeds value bound = bound <= 0 || value > bound+{-# INLINE exceeds #-}++-- | The bound the squared radius-edge ratio is compared against. Squaring is+-- monotone on the non-negative reals, so this asks the same question of the+-- squares that the unsquared bound asked of the lengths.+squareBound :: Double -> Double+squareBound bound+  | bound <= 0 = bound+  | otherwise = bound * bound+{-# INLINE squareBound #-}
+ src-build/Moonlight/Triangulation/Internal/Transaction.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}++-- | The hidden publication boundary shared by persistent build-side edits.+--+-- The rank-two action can observe one mutable section, but neither the section+-- nor any site witness can escape it.  This is deliberately below the public+-- Session surface: a caller may compose public verbs, while an owner that has+-- just derived private evidence can interpret it without making that evidence+-- forgeable.+module Moonlight.Triangulation.Internal.Transaction+  ( runTransaction+  ) where++import Control.Monad.ST (ST, runST)+import Moonlight.Triangulation.Dcel (numVertices)+import Moonlight.Triangulation.Internal.Capacity (ensureCapacity)+import Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel+  , freezeTriangulation+  , halfEdgeCapacity+  , thawTriangulation+  , thawTriangulationDense+  )+import Moonlight.Triangulation.Internal.OperationState+  ( OperationState+  , freezeBuildStats+  , newOperationState+  )+import Moonlight.Triangulation.Internal.Paged (TransactionShape (..))+import Moonlight.Triangulation.Internal.Representation (Triangulation)+import Moonlight.Triangulation.Internal.Types (BuildError, BuildStats)++-- | Reserve, thaw, interpret, and publish one transaction.+--+-- The physical section is selected by the operation that knows its edit+-- volume.  Refusal short-circuits before freezing, so a partially rewritten+-- mutable mesh cannot escape as a published triangulation.+runTransaction+  :: (BuildError -> failure)+  -> TransactionShape+  -> Triangulation mode vertex directed undirected face+  -> Int+  -> (forall s. MutableDcel s vertex directed undirected face -> OperationState s -> ST s (Either failure result))+  -> Either failure (result, Triangulation mode vertex directed undirected face, BuildStats)+runTransaction mapBuildFailure shape triangulation additional action = do+  let !capacity = numVertices triangulation + max 0 additional+  case ensureCapacity capacity of+    Left failure -> Left (mapBuildFailure failure)+    Right () -> pure ()+  runST $ do+    mutable <-+      case shape of+        DenseTransaction -> thawTriangulationDense capacity triangulation+        LocalTransaction -> thawTriangulation capacity triangulation+    operation <- newOperationState (halfEdgeCapacity mutable)+    outcome <- action mutable operation+    case outcome of+      Left refusal -> pure (Left refusal)+      Right value -> do+        frozenOutcome <- freezeTriangulation mutable+        case frozenOutcome of+          Left obstruction -> pure (Left (mapBuildFailure obstruction))+          Right frozen -> do+            stats <- freezeBuildStats operation+            pure (Right (value, frozen, stats))+{-# INLINE runTransaction #-}
+ src-build/Moonlight/Triangulation/Refinement.hs view
@@ -0,0 +1,448 @@+{-# LANGUAGE NamedFieldPuns #-}++-- | Ruppert refinement: Steiner insertion composed after a built mesh, never a+-- second kind of mesh. Parameters are reached through checked verbs rather than+-- a raw record, so an unrealizable quality bar is a refusal.+module Moonlight.Triangulation.Refinement+  ( refine+  , refineWithinDomain+  , validateRefinementParameters+  , withMinimumAngle+  , radiusEdgeRatioForAngle+  ) where++import Control.Monad.ST (ST, runST)+import Data.Foldable (traverse_)+import qualified Data.IntSet as IntSet+import Data.List (sort)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import qualified Data.Set as Set+import qualified Data.Vector as V+import Moonlight.Triangulation.Dcel+  ( faceVertices+  , incidentFace+  , isConstraintEdge+  , numFaces+  , numUndirectedEdges+  , numVertices+  , undirectedEndpoints+  , vertexPoint+  )+import Moonlight.Triangulation.FloodFillIterator (facesAtEvenBarrierDepth)+import Moonlight.Triangulation.Handles+  ( FaceId (..)+  , UndirectedEdgeId (..)+  , directedPair+  )+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.Capacity (ensureCapacity)+import Moonlight.Triangulation.Internal.OperationState (freezeBuildStats, newOperationState)+import Moonlight.Triangulation.Internal.Refinement+import Moonlight.Triangulation.Types+import Moonlight.Triangulation.Validation (validateTopology)++data RefinementExecution mode vertex directed undirected face = RefinementExecution+  { refinementExecutionResult :: !(RefinementResult mode vertex directed undirected face)+  , refinementExecutionVisitedFaces :: ![Int]+  , refinementExecutionInterfaceBoundaryReads :: {-# UNPACK #-} !Int+  , refinementExecutionBoundaryCrossingAttempts :: {-# UNPACK #-} !Int+  }++-- | The radius-edge ratio admitting a minimum angle, in degrees.+radiusEdgeRatioForAngle :: Double -> Either BuildError (Maybe Double)+radiusEdgeRatioForAngle degrees =+  case classifyNonFinite degrees of+    Just nonFinite ->+      Left (RefinementMinimumAngleNotFinite nonFinite)+    Nothing+      | degrees < 0 || degrees > 60 ->+          Left (RefinementMinimumAngleOutOfRange degrees)+      | degrees == 0 -> Right Nothing+      | otherwise ->+          let ratio = 0.5 / sin (degrees * pi / 180)+           in case classifyNonFinite ratio of+                Just nonFinite ->+                  Left (RefinementMinimumAngleDerivedRatioNotFinite nonFinite)+                Nothing -> Right (Just ratio)++-- | Set the minimum angle, in degrees.+withMinimumAngle :: Double -> RefinementParameters -> Either BuildError (RefinementParameters)+withMinimumAngle degrees parameters = do+  ratio <- radiusEdgeRatioForAngle degrees+  pure parameters{refineMaxRadiusEdgeRatio = ratio}++-- | Refine an unconstrained or constrained triangulation in the same finite+-- DCEL. The constructor supplies application payloads for Steiner vertices;+-- payloads annotate the requested geometric point and cannot reauthor it.+refine+  :: (Point -> vertex)+  -> RefinementParameters+  -> Triangulation mode vertex directed undirected face+  -> Either BuildError (RefinementResult mode vertex directed undirected face)+refine makeVertex parameters =+  fmap refinementExecutionResult+    . refineWithInitialSeed RefineEveryFace Nothing makeVertex parameters++-- | Prove that a set of active faces is separated from every protected inner+-- face by exactly the supplied immutable edge section. The witness is tied to+-- the input arena cardinalities and is revalidated before interpretation.+mkRefinementDomain+  :: Set.Set FaceId+  -> Set.Set UndirectedEdgeId+  -> Triangulation mode vertex directed undirected face+  -> Either BuildError RefinementDomain+mkRefinementDomain permittedFaces interfaceEdges triangulation = do+  permitted <- validateSeedFaces triangulation permittedFaces+  interface <- IntSet.fromList <$> traverse validateInterfaceEdge (Set.toAscList interfaceEdges)+  let expected = expectedInterface permitted+  case IntSet.lookupMin (expected IntSet.\\ interface) of+    Just pair -> Left (RefinementDomainInterfaceMissing (UndirectedEdgeId (fromIntegral pair)))+    Nothing ->+      case IntSet.lookupMin (interface IntSet.\\ expected) of+        Just pair -> Left (RefinementDomainInterfaceExtraneous (UndirectedEdgeId (fromIntegral pair)))+        Nothing ->+          Right+            RefinementDomain+              { refinementDomainPermittedFaces = permitted+              , refinementDomainInterfacePairs = interface+              , refinementDomainInputFaces =+                  Map.fromAscList+                    [ (face, faceSignature triangulation face)+                    | raw <- [1 .. numFaces triangulation - 1]+                    , let face = FaceId (fromIntegral raw)+                    ]+              , refinementDomainInputFaceCount = numFaces triangulation+              , refinementDomainInputEdgeCount = numUndirectedEdges triangulation+              }+ where+  totalEdges = numUndirectedEdges triangulation+  validateInterfaceEdge edge@(UndirectedEdgeId raw)+    | toInteger raw >= toInteger totalEdges =+        Left (RefinementDomainInterfaceEdgeNotActive edge totalEdges)+    | otherwise = Right (fromIntegral raw)++  expectedInterface permitted =+    IntSet.fromList+      [ pair+      | pair <- [0 .. totalEdges - 1]+      , let edge = UndirectedEdgeId (fromIntegral pair)+            (forward, backward) = directedPair edge+            FaceId forwardFace = incidentFace triangulation forward+            FaceId backwardFace = incidentFace triangulation backward+            forwardInner = forwardFace /= 0+            backwardInner = backwardFace /= 0+            forwardPermitted = IntSet.member (fromIntegral forwardFace) permitted+            backwardPermitted = IntSet.member (fromIntegral backwardFace) permitted+      , forwardInner && backwardInner && forwardPermitted /= backwardPermitted+      ]++-- | Refine exactly one checked local section. Interface edges are installed as+-- transaction-local legalization barriers and removed before publication;+-- every protected face signature is then compared with the input witness.+refineWithinDomain+  :: (Point -> vertex)+  -> RefinementParameters+  -> Set.Set FaceId+  -> Set.Set UndirectedEdgeId+  -> Triangulation mode vertex directed undirected face+  -> Either BuildError (RefinementDomainResult mode vertex directed undirected face)+refineWithinDomain makeVertex parameters permittedFaces interfaceEdges triangulation = do+  validateDomainParameters parameters+  domain <- mkRefinementDomain permittedFaces interfaceEdges triangulation+  execution <-+    refineWithInitialSeed+      (RefineSeededFaces (refinementDomainPermittedFaces domain))+      (Just domain)+      makeVertex+      parameters+      triangulation+  let result = refinementExecutionResult execution+      receipt =+        buildRefinementReceipt+          domain+          triangulation+          (refinedTriangulation result)+          (refinementExecutionVisitedFaces execution)+          (refinementExecutionInterfaceBoundaryReads execution)+          (refinementExecutionBoundaryCrossingAttempts execution)+  validateProtectedFaces domain triangulation (refinedTriangulation result)+  case V.toList (refinementVisitedProtectedFaces receipt) of+    protected : _ -> Left (RefinementDomainWouldRewriteProtectedFace protected)+    [] ->+      Right+        RefinementDomainResult+          { refinementDomainResult = result+          , refinementDomainReceipt = receipt+          }++validateDomainParameters :: RefinementParameters -> Either BuildError ()+validateDomainParameters parameters+  | not (refinePreserveConvexHull parameters) =+      Left RefinementDomainRequiresConvexHullPreservation+  | not (refineKeepConstraintEdges parameters) =+      Left RefinementDomainRequiresConstraintPreservation+  | refineExcludeOuterFaces parameters =+      Left RefinementDomainForbidsOuterFaceExclusion+  | otherwise = Right ()++refineWithInitialSeed+  :: RefinementInitialSeed+  -> Maybe RefinementDomain+  -> (Point -> vertex)+  -> RefinementParameters+  -> Triangulation mode vertex directed undirected face+  -> Either BuildError (RefinementExecution mode vertex directed undirected face)+refineWithInitialSeed initialSeed domain makeVertex parameters triangulation = do+  validateRefinementParameters parameters+  case validateTopology triangulation of+    violation : _ -> Left (RefinementInputTopologyInvalid violation)+    [] -> pure ()+  let originalCount = numVertices triangulation+      budget = max 0 (fromMaybe (10 * max 1 originalCount) (refineMaxAdditionalVertices parameters))+      maximumVerticesInteger = toInteger originalCount + toInteger budget+      initialExcludedFaces =+        if refineExcludeOuterFaces parameters+          then+            IntSet.fromList+              [ fromIntegral raw+              | FaceId raw <-+                  facesAtEvenBarrierDepth+                    triangulation+                    (isConstraintEdge triangulation)+              ]+          else IntSet.empty+  let maximumVertices =+        if maximumVerticesInteger > toInteger (maxBound :: Int)+          then maxBound+          else fromInteger maximumVerticesInteger+  ensureCapacity maximumVertices+  runST $ do+      mutable <-+        thawTriangulationDense+          maximumVertices+          triangulation+      operation <- newOperationState (halfEdgeCapacity mutable)+      installInterfaceBarriers mutable domain+      outcome <-+        refineMutable+          makeVertex+          mutable+          operation+          parameters+          originalCount+          initialExcludedFaces+          initialSeed+          domain+      removeInterfaceBarriers mutable triangulation domain+      case outcome of+        Left failure -> pure (Left failure)+        Right (complete, added, excluded, visited, interfaceBoundaryReads, boundaryCrossingAttempts) -> do+          frozenOutcome <- freezeTriangulation mutable+          case frozenOutcome of+            Left obstruction -> pure (Left obstruction)+            Right frozen -> do+              stats <- freezeBuildStats operation+              pure+                ( Right+                    RefinementExecution+                      { refinementExecutionResult =+                          RefinementResult+                            { refinedTriangulation = frozen+                            , refinementStats = stats+                            , refinementAddedVertices = added+                            , refinementComplete = complete+                            , refinementExcludedFaces = V.fromList (map (FaceId . fromIntegral) excluded)+                            }+                      , refinementExecutionVisitedFaces = visited+                      , refinementExecutionInterfaceBoundaryReads = interfaceBoundaryReads+                      , refinementExecutionBoundaryCrossingAttempts = boundaryCrossingAttempts+                      }+                )++installInterfaceBarriers+  :: MutableDcel s vertex directed undirected face+  -> Maybe RefinementDomain+  -> ST s ()+installInterfaceBarriers mutable =+  traverse_+    (\pair -> setConstraint mutable (2 * pair) >> pure ())+    . maybe [] (IntSet.toAscList . refinementDomainInterfacePairs)++removeInterfaceBarriers+  :: MutableDcel s vertex directed undirected face+  -> Triangulation mode vertex directed undirected face+  -> Maybe RefinementDomain+  -> ST s ()+removeInterfaceBarriers mutable input =+  traverse_+    (\pair ->+       let edge = UndirectedEdgeId (fromIntegral pair)+        in if isConstraintEdge input edge+             then pure ()+             else clearConstraint mutable (2 * pair) >> pure ()+    )+    . maybe [] (IntSet.toAscList . refinementDomainInterfacePairs)++validateProtectedFaces+  :: RefinementDomain+  -> Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex directed undirected face+  -> Either BuildError ()+validateProtectedFaces domain before after =+  traverse_ validateProtected protectedFaces+ where+  protectedFaces =+    [ FaceId (fromIntegral face)+    | face <- [1 .. refinementDomainInputFaceCount domain - 1]+    , IntSet.notMember face (refinementDomainPermittedFaces domain)+    ]+  validateProtected face+    | Map.lookup face (refinementDomainInputFaces domain)+        == Just (faceSignature before face)+        && Map.lookup face (refinementDomainInputFaces domain)+          == Just (faceSignature after face) = Right ()+    | otherwise = Left (RefinementDomainProtectedFaceChanged face)++faceSignature+  :: Triangulation mode vertex directed undirected face+  -> FaceId+  -> [Point]+faceSignature triangulation =+  sort . fmap (vertexPoint triangulation) . faceVertices triangulation++type EdgeSignature = (Point, Point, [FaceId])++edgeSignature+  :: Triangulation mode vertex directed undirected face+  -> UndirectedEdgeId+  -> EdgeSignature+edgeSignature triangulation edge =+  (min fromPoint toPoint, max fromPoint toPoint, sort [forwardFace, backwardFace])+ where+  (fromVertex, toVertex) = undirectedEndpoints triangulation edge+  fromPoint = vertexPoint triangulation fromVertex+  toPoint = vertexPoint triangulation toVertex+  (forward, backward) = directedPair edge+  forwardFace = incidentFace triangulation forward+  backwardFace = incidentFace triangulation backward++buildRefinementReceipt+  :: RefinementDomain+  -> Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex directed undirected face+  -> [Int]+  -> Int+  -> Int+  -> RefinementReceipt+buildRefinementReceipt domain before after visited interfaceBoundaryReads boundaryCrossingAttempts =+  RefinementReceipt+    { refinementVisitedJoinFaces = V.fromList (fmap toFace visitedJoin)+    , refinementVisitedProtectedFaces = V.fromList (fmap toFace visitedProtected)+    , refinementCreatedFaces =+        V.fromList+          [ targetFace+          | face <- [1 .. numFaces after - 1]+          , let targetFace = toFace face+          , face >= numFaces before+              || faceSignature before targetFace /= faceSignature after targetFace+          ]+    , refinementTouchedEdges = V.fromList touched+    , refinementRemovedEdges = V.fromList removed+    , refinementInterfaceBoundaryReads = interfaceBoundaryReads+    , refinementAttemptedBoundaryCrossings = boundaryCrossingAttempts+    }+ where+  permitted = refinementDomainPermittedFaces domain+  (visitedProtected, visitedJoin) =+    foldr+      (\face (protected, join) ->+         if IntSet.member face permitted || face >= refinementDomainInputFaceCount domain+           then (protected, face : join)+           else (face : protected, join)+      )+      ([], [])+      visited+  toFace = FaceId . fromIntegral+  beforeEdges = numUndirectedEdges before+  afterEdges = numUndirectedEdges after+  touched =+    [ edge+    | raw <- [0 .. afterEdges - 1]+    , let edge = UndirectedEdgeId (fromIntegral raw)+    , raw >= beforeEdges || edgeSignature before edge /= edgeSignature after edge+    ]+  removed =+    [ edge+    | raw <- [0 .. beforeEdges - 1]+    , let edge = UndirectedEdgeId (fromIntegral raw)+    , raw >= afterEdges || edgeSignature before edge /= edgeSignature after edge+    ]++-- | Refuse outer or absent faces rather than silently treating an invalid+-- topology witness as an empty repair. Face zero is the outer face and has no+-- active refinement equation.+validateSeedFaces+  :: Triangulation mode vertex directed undirected face+  -> Set.Set FaceId+  -> Either BuildError IntSet.IntSet+validateSeedFaces triangulation requested =+  IntSet.fromList <$> traverse validateFace (Set.toAscList requested)+ where+  totalFaces = numFaces triangulation++  validateFace face@(FaceId raw)+    | raw == 0 || toInteger raw >= toInteger totalFaces =+        Left (RefinementSeedFaceNotActive face totalFaces)+    | otherwise = Right (fromIntegral raw)++-- | Refuse parameters no mesh can satisfy.+validateRefinementParameters :: RefinementParameters -> Either BuildError ()+validateRefinementParameters RefinementParameters{refineMaxAdditionalVertices, refineMinArea, refineMaxArea, refineMaxRadiusEdgeRatio} = do+  case refineMaxAdditionalVertices of+    Just value+      | value < 0 ->+          Left (RefinementMaximumAdditionalVerticesNegative value)+    _ -> Right ()+  validateOptionalRefinementParameter+    RefinementMinimumAreaNotFinite+    RefinementMinimumAreaNegative+    (>= 0)+    refineMinArea+  validateOptionalRefinementParameter+    RefinementMaximumAreaNotFinite+    RefinementMaximumAreaNotPositive+    (> 0)+    refineMaxArea+  validateOptionalRefinementParameter+    RefinementMaximumRadiusEdgeRatioNotFinite+    RefinementMaximumRadiusEdgeRatioNotPositive+    (> 0)+    refineMaxRadiusEdgeRatio+  case (refineMinArea, refineMaxArea) of+    (Just minimumArea, Just maximumArea)+      | minimumArea > maximumArea ->+          Left+            ( RefinementMinimumAreaExceedsMaximum+                minimumArea+                maximumArea+            )+    _ -> Right ()++validateOptionalRefinementParameter+  :: (NonFiniteValue -> BuildError)+  -> (Double -> BuildError)+  -> (Double -> Bool)+  -> Maybe Double+  -> Either BuildError ()+validateOptionalRefinementParameter nonFinite outsideRange predicate value =+  case value of+    Nothing -> Right ()+    Just number ->+      case classifyNonFinite number of+        Just nonFiniteValue ->+          Left (nonFinite nonFiniteValue)+        Nothing+          | predicate number -> Right ()+          | otherwise ->+              Left (outsideRange number)
+ src-build/Moonlight/Triangulation/Removal.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Persistent removal: one excision, published as its own triangulation.+module Moonlight.Triangulation.Removal+  ( RemovalOutcome (..)+  , RemovalResult (..)+  , removeVertex+  , locateAndRemove+  ) where++import Control.DeepSeq (NFData)+import Moonlight.Triangulation.Handles.HandleDefs (VertexId (..))+import Moonlight.Triangulation.Internal.Excision (RemovalOutcome (..))+import Moonlight.Triangulation.Internal.PointIndex (lookupPointIndex)+import Moonlight.Triangulation.Internal.Representation (Triangulation (..))+import Moonlight.Triangulation.Internal.Types (BuildError, BuildStats, Point, queryPointValue)+import Moonlight.Triangulation.Math (validatePoint)+import Moonlight.Triangulation.Session (excise, withLocalSession)+import GHC.Generics (Generic)++-- | One removal and its publication: the frozen triangulation, the outcome+-- record, and the operation's counters. The persistent entries publish all+-- three; a session publishes the outcome per call and the counters once.+data RemovalResult mode vertex directed undirected face = RemovalResult+  { removalTriangulation :: !(Triangulation mode vertex directed undirected face)+  , removalOutcome :: !(RemovalOutcome vertex)+  , removalStats :: !BuildStats+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++deriving stock instance+  (Eq vertex, Eq directed, Eq undirected, Eq face)+  => Eq (RemovalResult mode vertex directed undirected face)+deriving stock instance+  (Show vertex, Show directed, Show undirected, Show face)+  => Show (RemovalResult mode vertex directed undirected face)++-- | Remove the vertex a handle names. The triangulation the caller passed in+-- still denotes the mesh it always did; the removal is in the returned one.+--+-- This is a session over a single 'excise', which is what makes replacing a+-- fold of it with one session sound: the two agree on every mesh, and differ+-- only in how many of the intermediate ones are published. A fold publishes+-- @k@ meshes and pays a thaw for each, so it runs in Θ(n·k); the session pays+-- one thaw and runs in O(k·deg).+removeVertex+  :: Triangulation mode vertex directed undirected face+  -> VertexId+  -> Either BuildError (RemovalResult mode vertex directed undirected face)+removeVertex triangulation requested = do+  (outcome, frozen, stats) <- withLocalSession triangulation 0 (excise requested)+  pure+    RemovalResult+      { removalTriangulation = frozen+      , removalOutcome = outcome+      , removalStats = stats+      }++-- | Resolve a point through the mesh's exact derived identity section, then+-- remove the handle it proves. A hash is only a rejection filter; the lookup+-- confirms both authoritative coordinate planes before the topology is+-- opened. A point that sites no vertex answers 'Nothing' without publishing a+-- cosmetically different mesh.+--+-- See 'removeVertex' on the cost of folding this rather than opening one+-- session over @removeAt@.+locateAndRemove+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> Either BuildError (Maybe (RemovalResult mode vertex directed undirected face))+locateAndRemove triangulation point = do+  queryPoint <- validatePoint Nothing point+  case+      lookupPointIndex+        (triPointX triangulation)+        (triPointY triangulation)+        (triPointIndex triangulation)+        -- Stored coordinates are canonical; the query must be too, or any+        -- coordinate whose canonicalization exceeds signed zero misses a vertex+        -- the session verbs would find.+        (queryPointValue queryPoint) of+    Nothing -> Right Nothing+    Just rawVertex ->+      Just <$> removeVertex triangulation (VertexId (fromIntegral rawVertex))++-- Polymorphic entries consumed from other packages; without exposed+-- unfoldings they run boxed through an imported boundary.
+ src-build/Moonlight/Triangulation/Session.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE BangPatterns #-}++-- | One owned editing transaction over a triangulation: thaw once, edit, publish once.+module Moonlight.Triangulation.Session+  ( Session+  , withSession+  , withLocalSession+  , insertVertex+  , insertVertexAt+  , insertVertexAtNear+  , insertVertexAtCombining+  , removeAt+  , removeAtNear+  , removeManyAt+  , removeManyAtNear+  , excise+  , refuse+  ) where++import Control.Monad.ST (ST)+import Data.Bits (xor)+import qualified Data.Vector as V+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Insertion (insertPointCombining)+import Moonlight.Triangulation.Internal.Excision (RemovalOutcome, removeMutable)+import Moonlight.Triangulation.Internal.Location (MutableLocation (..), locateMutable)+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState (OperationState)+import Moonlight.Triangulation.Internal.Paged (TransactionShape (..))+import Moonlight.Triangulation.Math (canonicalPoint)+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Transaction (runTransaction)+import Moonlight.Triangulation.Internal.Types++-- | An edit sequence against one thawed mesh.+--+-- The two published entry points before this one — an insertion session and a+-- removal session — each handed the caller a function and could not compose,+-- so a caller who wanted to remove a hundred vertices and insert fifty thawed+-- twice and paid the O(n) publication a session exists to delete. They are the+-- same transaction; only the verb differed. This is that transaction, and the+-- verbs are its primitives.+--+-- The public session algebra and the private exact-site single-insertion+-- interpreter cross the same hidden transaction boundary. Sessions provide+-- composition; the private interpreter reaches that boundary only with+-- evidence from the immediately preceding frozen read. A fold of persistent+-- verbs and a session over the same verbs therefore differ only in which+-- intermediate meshes they publish.+--+-- Refusal short-circuits: the first 'BuildError' abandons the rest of the+-- sequence, and 'withSession' freezes nothing. A partly edited arena cannot+-- reach a caller as a published triangulation.+newtype Session s vertex directed undirected face a = Session+  { stepSession+      :: MutableDcel s vertex directed undirected face+      -> OperationState s+      -> ST s (Either BuildError a)+  }++instance Functor (Session s vertex directed undirected face) where+  fmap f (Session step) = Session $ \mesh operation -> fmap (fmap f) (step mesh operation)+  {-# INLINE fmap #-}++instance Applicative (Session s vertex directed undirected face) where+  pure a = Session $ \_ _ -> pure (Right a)+  {-# INLINE pure #-}+  Session left <*> Session right = Session $ \mesh operation -> do+    outcome <- left mesh operation+    case outcome of+      Left refusal -> pure (Left refusal)+      Right f -> fmap (fmap f) (right mesh operation)+  {-# INLINE (<*>) #-}++instance Monad (Session s vertex directed undirected face) where+  Session step >>= f = Session $ \mesh operation -> do+    outcome <- step mesh operation+    case outcome of+      Left refusal -> pure (Left refusal)+      Right a -> stepSession (f a) mesh operation+  {-# INLINE (>>=) #-}++-- | Abandon the transaction. Nothing is published.+refuse :: BuildError -> Session s vertex directed undirected face a+refuse failure = Session $ \_ _ -> pure (Left failure)+{-# INLINE refuse #-}++-- | Insert a vertex, answering the handle it was given. A point already+-- present keeps its handle and takes the new payload.+insertVertex+  :: HasPosition vertex+  => vertex+  -> Session s vertex directed undirected face VertexId+insertVertex payload = Session $ \mesh operation ->+  fmap+    (fmap (VertexId . fromIntegral . fst))+    (insertPointCombining (\_ replacement -> replacement) Nothing mesh operation (position payload) payload)++-- | Insert at a stated point, answering the handle and whether a site was+-- created. 'insertVertex' is this with the point read out of the payload; a+-- caller that computed the point — a constraint split, a Steiner refinement —+-- states it rather than round-tripping through 'HasPosition'.+insertVertexAt+  :: Point+  -> vertex+  -> Session s vertex directed undirected face (VertexId, InsertionDisposition)+insertVertexAt point payload = Session $ \mesh operation ->+  fmap+    (fmap (\(vertex, disposition) -> (VertexId (fromIntegral vertex), disposition)))+    (insertPointCombining (\_ replacement -> replacement) Nothing mesh operation point payload)++-- | 'insertVertexAt' with the walk seeded at a face the caller vouches for --+-- typically the face a locate on the just-published value settled on, which+-- is exact on the mesh this transaction thawed. The seed is a hint, not an+-- authority: an out-of-range face degrades to the unhinted descent, and the+-- walk corrects.+insertVertexAtNear+  :: FaceId+  -> Point+  -> vertex+  -> Session s vertex directed undirected face (VertexId, InsertionDisposition)+insertVertexAtNear (FaceId rawSeed) point payload = Session $ \mesh operation ->+  fmap+    (fmap (\(vertex, disposition) -> (VertexId (fromIntegral vertex), disposition)))+    (insertPointCombining+       (\_ replacement -> replacement)+       (Just (fromIntegral rawSeed))+       mesh+       operation+       point+       payload+    )++-- | Insert at a site while combining an occupied site's resident annotation+-- with the incoming one. Geometry still owns identity; this supplies only the+-- overlap law used by annotated joins.+insertVertexAtCombining+  :: (vertex -> vertex -> vertex)+  -> Point+  -> vertex+  -> Session s vertex directed undirected face (VertexId, InsertionDisposition)+insertVertexAtCombining combine point payload = Session $ \mesh operation ->+  fmap+    (fmap (\(vertex, disposition) -> (VertexId (fromIntegral vertex), disposition)))+    (insertPointCombining combine Nothing mesh operation point payload)++-- | Remove the vertex standing at a point, answering 'Nothing' when no vertex+-- stands there.+--+-- Keyed by position rather than by handle because removal swap-compacts the+-- arenas: every outstanding t'VertexId' may relocate, and over a sequence of+-- removals a handle-keyed verb would force the caller to thread every+-- relocation by hand. A position is invariant under compaction. The relocation+-- is still reported, in the 'RemovalOutcome', for callers holding handles.+-- The question is an identity question -- which vertex stands at this exact+-- position. A session that has committed to identity work ('removeManyAt',+-- 'excise') answers it through the identity index in O(1); one that has not+-- answers it with a single walk, because a published index is a lazy rebuild+-- and forcing a whole-mesh build to answer one question is the wrong trade.+removeAt+  :: Point+  -> Session s vertex directed undirected face (Maybe (RemovalOutcome vertex))+removeAt point = Session $ \mesh operation -> do+  indexed <- identityIndexActive mesh+  if indexed+    then removeIndexed mesh operation point+    else walkAndRemove mesh operation Nothing point++removeIndexed+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Point+  -> ST s (Either BuildError (Maybe (RemovalOutcome vertex)))+removeIndexed mesh operation point = do+  located <- lookupPointVertex mesh point+  case located of+    Just vertex -> fmap (fmap Just) (removeMutable mesh operation vertex)+    Nothing -> pure (Right Nothing)++-- | Remove the vertex standing at a point, starting from a caller-supplied+-- near vertex -- a locate hint from an external structure such as the+-- Delaunay hierarchy. The guess is a hint, not an authority: a slot renamed+-- by swap-compaction or out of range degrades to a walk hinted by the+-- guess's incident face, and the walk corrects.+removeAtNear+  :: VertexId+  -> Point+  -> Session s vertex directed undirected face (Maybe (RemovalOutcome vertex))+removeAtNear (VertexId rawGuess) point = Session $ \mesh operation -> do+  indexed <- identityIndexActive mesh+  let !guess = fromIntegral rawGuess+      !query = canonicalPoint point+  if indexed+    then removeIndexed mesh operation query+    else do+      vertices <- pointCount mesh+      if guess < 0 || guess >= vertices+        then walkAndRemove mesh operation Nothing query+        else do+          stored <- pointAt mesh guess+          if stored == query+            then fmap (fmap Just) (removeMutable mesh operation guess)+            else do+              outgoing <- readVertexOut mesh guess+              let interiorFace edge fallback = do+                    face <- readFace mesh edge+                    if face > 0 then pure (Just face) else fallback+              hint <-+                if outgoing < 0+                  then pure Nothing+                  else interiorFace outgoing (interiorFace (outgoing `xor` 1) (pure Nothing))+              walkAndRemove mesh operation hint query++walkAndRemove+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Maybe Int+  -> Point+  -> ST s (Either BuildError (Maybe (RemovalOutcome vertex)))+walkAndRemove mesh operation hint query = do+  located <- locateMutable mesh operation hint query+  case located of+    Left obstruction -> pure (Left obstruction)+    Right (MutableOnVertex vertex) ->+      fmap (fmap Just) (removeMutable mesh operation vertex)+    Right _ -> pure (Right Nothing)++-- | Remove the vertex standing at each point, answering per point in order.+-- One session-level decision buys the locate strategy: few removals walk the+-- mesh, each a ~O(sqrt n) descent, while many seed the existing mutable+-- open-addressed identity section once from coordinate authority and answer+-- each question by hash. The guard squares the crossover to avoid a root.+removeManyAt+  :: V.Vector (Point)+  -> Session s vertex directed undirected face (V.Vector (Maybe (RemovalOutcome vertex)))+removeManyAt points =+  withBatchIdentityForLoad (V.length points) (V.mapM removeAt points)++-- | Install the mutable identity section only around a dense removal program.+-- It is a local section over the coordinate arenas, not a new published cache:+-- on every result path it is discarded and freeze glues a lazy @PointIndex@+-- back from those arenas. Sparse loads retain the existing locate walk.+withBatchIdentityForLoad+  :: Int+  -> Session s vertex directed undirected face result+  -> Session s vertex directed undirected face result+withBatchIdentityForLoad count (Session action) = Session $ \mesh operation -> do+  vertices <- pointCount mesh+  if count * count > 10 * vertices+    then do+      activated <- activateBatchPointIndex mesh+      case activated of+        Left failure -> pure (Left failure)+        Right () -> do+          outcome <- action mesh operation+          discardBatchPointIndex mesh+          pure outcome+    else action mesh operation++identityCommitted :: Session s vertex directed undirected face Bool+identityCommitted = Session $ \mesh _ -> fmap Right (identityIndexActive mesh)+{-# INLINE identityCommitted #-}++-- | 'removeManyAt' with a near vertex per point where the caller has one — a+-- hierarchy sample, a previous answer. The batch commits to its load first,+-- so the identity-index crossover decides the regime once: a dense batch buys+-- its local mutable table and never examines a guess, a sparse one walks from+-- its guesses.+removeManyAtNear+  :: V.Vector (Maybe VertexId)+  -> V.Vector (Point)+  -> Session s vertex directed undirected face (V.Vector (Maybe (RemovalOutcome vertex)))+removeManyAtNear guesses points =+  withBatchIdentityForLoad (V.length points) $ do+    indexed <- identityCommitted+    if indexed+      then V.mapM removeAt points+      else+        V.zipWithM+          (\guess point -> maybe (removeAt point) (\vertex -> removeAtNear vertex point) guess)+          guesses+          points++-- | Remove a stated vertex. Sound only while the handle still denotes what the+-- caller means: the first removal in a sequence compacts the arenas, so a+-- handle taken before it may name a different vertex after. @removeAt@ is the+-- verb for a sequence; this is the verb for a handle the caller has just been+-- given and has not yet let a removal run underneath.+excise+  :: VertexId+  -> Session s vertex directed undirected face (RemovalOutcome vertex)+excise requested@(VertexId raw) = Session $ \mesh operation -> do+  vertices <- pointCount mesh+  if toInteger raw >= toInteger vertices+    then pure (Left (RemovalVertexOutOfRange requested vertices))+    else do+      activatePointIndex mesh+      removeMutable mesh operation (fromIntegral raw)++-- | Run an edit sequence: thaw once, edit, freeze once, and publish the+-- counters the whole transaction charged.+--+-- The reservation is taken for the peak vertex count, so it is the insertion+-- count that sizes it; removals only shrink the mesh and a mixed sequence+-- cannot exceed the peak an insert-only sequence of the same count reaches.+--+-- The session cannot escape its callback: the state token is universally+-- quantified, so the mesh it addresses is dead by the time the frozen+-- triangulation is returned.+withSession+  :: forall mode vertex directed undirected face result+   . Triangulation mode vertex directed undirected face+  -> Int+  -> (forall s. Session s vertex directed undirected face result)+  -> Either BuildError (result, Triangulation mode vertex directed undirected face, BuildStats)+withSession triangulation additional session =+  runTransaction+    id+    DenseTransaction+    triangulation+    additional+    (\mesh operation -> stepSession session mesh operation)++-- | The local-edit transaction: copy-on-write pages, publication proportional+-- to what the edit dirtied. This is the section for singleton persistent+-- verbs, whose one edit cannot amortize a dense copy of the whole mesh.+withLocalSession+  :: forall mode vertex directed undirected face result+   . Triangulation mode vertex directed undirected face+  -> Int+  -> (forall s. Session s vertex directed undirected face result)+  -> Either BuildError (result, Triangulation mode vertex directed undirected face, BuildStats)+withLocalSession triangulation additional session =+  runTransaction+    id+    LocalTransaction+    triangulation+    additional+    (\mesh operation -> stepSession session mesh operation)
+ src-build/Moonlight/Triangulation/SetAlgebra.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE DataKinds #-}++-- | Finite-set operations on unconstrained meshes. Every+-- constructing operation returns the finite-arena obstruction instead of+-- laundering it through a partial class instance.+module Moonlight.Triangulation.SetAlgebra+  ( siteRelation+  , union+  , unions+  , intersection+  , intersectionWith+  , difference+  , symmetricDifference+  ) where++import Data.Foldable (traverse_)+import Data.Maybe (isJust)+import qualified Data.Vector as V+import Moonlight.Triangulation.BulkLoad (empty)+import Moonlight.Triangulation.Dcel (numVertices, vertexData, vertexPoint)+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (vertices)+import Moonlight.Triangulation.Internal.Join (joinBalanced, joinNormalForm)+import Moonlight.Triangulation.Internal.Join.Rebuild (rebuildCanonicalSiteSet)+import Moonlight.Triangulation.Internal.Join.SiteSet+  ( siteSetDifference+  , siteSetFromTriangulation+  , siteSetIntersectionWith+  , siteSetPoints+  , siteRelationFromTriangulations+  , siteSetSymmetricDifferenceFromTriangulations+  , siteSupportFromTriangulation+  )+import Moonlight.Triangulation.Internal.Representation (Triangulation)+import Moonlight.Triangulation.Internal.Types+  ( BuildError (PointLocationFailed)+  , ConstraintMode (Unconstrained)+  , InsertionDisposition (..)+  , Point+  , SiteRelation (..)+  , unitElementDefaults+  )+import Moonlight.Triangulation.JoinSemilattice (JoinSemilattice)+import Moonlight.Triangulation.Session+  ( Session+  , insertVertexAt+  , refuse+  , removeAtNear+  , removeManyAt+  , withLocalSession+  )++-- | Exact relation between two triangulations' coordinate supports. Vertex+-- annotations and topology-element payloads are observations over the support;+-- none participates in this classification.+siteRelation+  :: Triangulation leftMode leftAnnotation leftDirected leftUndirected leftFace+  -> Triangulation rightMode rightAnnotation rightDirected rightUndirected rightFace+  -> SiteRelation+siteRelation left right =+  siteRelationFromTriangulations left right+{-# INLINE siteRelation #-}++-- | A valid Delaunay representative of both site sets. Use 'canonicalize'+-- when construction-independent dense numbering is required.+union+  :: JoinSemilattice annotation+  => Triangulation 'Unconstrained annotation () () ()+  -> Triangulation 'Unconstrained annotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+union = joinNormalForm++-- | @union@ over a list, folded as a balanced tournament.+unions+  :: JoinSemilattice annotation+  => [Triangulation 'Unconstrained annotation () () ()]+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+unions = joinBalanced++-- | The sites both meshes hold.+intersection+  :: Triangulation 'Unconstrained () () () ()+  -> Triangulation 'Unconstrained () () () ()+  -> Either BuildError (Triangulation 'Unconstrained () () () ())+intersection left right+  | numVertices left == 0 = Right left+  | numVertices right == 0 = Right right+  | otherwise =+      case siteRelationFromTriangulations left right of+        EqualSites -> Right left+        LeftProperSubset -> Right left+        RightProperSubset -> Right right+        DisjointSites -> Right (empty unitElementDefaults)+        PartialOverlap overlap -> intersectPartialOverlap overlap+ where+  leftSites = siteSupportFromTriangulation left+  rightSites = siteSupportFromTriangulation right+  rebuildIntersection = intersectionWith (\_ _ -> ()) left right+  intersectPartialOverlap overlap+    | leftRemoved <= rightRemoved+    , removalDeltaIsEligible leftRemoved overlap =+        removeExpectedFrom left (siteSetPoints (siteSetDifference leftSites rightSites))+    | rightRemoved < leftRemoved+    , removalDeltaIsEligible rightRemoved overlap =+        removeExpectedFrom right (siteSetPoints (siteSetDifference rightSites leftSites))+    | otherwise = rebuildIntersection+   where+    leftRemoved = numVertices left - overlap+    rightRemoved = numVertices right - overlap+{-# INLINE intersection #-}++-- | The sites both meshes hold, with the result annotation computed from the+-- left and right annotations at that exact coordinate. The combiner is called+-- only for shared sites, in left-then-right order; geometry remains the sole+-- authority for membership. @intersectionWith const left mask@ is the+-- annotation-preserving restriction of @left@ to @mask@'s support.+intersectionWith+  :: (leftAnnotation -> rightAnnotation -> annotation)+  -> Triangulation 'Unconstrained leftAnnotation () () ()+  -> Triangulation 'Unconstrained rightAnnotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+intersectionWith combine left right =+  rebuildCanonicalSiteSet+    ( siteSetIntersectionWith+        combine+        (siteSetFromTriangulation left)+        (siteSetFromTriangulation right)+    )+{-# INLINE intersectionWith #-}++-- | The left's sites, less the right's.+difference+  :: Triangulation 'Unconstrained leftAnnotation () () ()+  -> Triangulation 'Unconstrained rightAnnotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained leftAnnotation () () ())+difference left right+  | numVertices left == 0 || numVertices right == 0 = Right left+  | numVertices right < numVertices left+  , removalDeltaIsEligible (numVertices right) (numVertices left - numVertices right) =+      removeAvailableFrom left (V.fromList (fmap (vertexPoint right) (vertices right)))+  | otherwise =+      rebuildCanonicalSiteSet+        ( siteSetDifference+            (siteSetFromTriangulation left)+            (siteSupportFromTriangulation right)+        )+{-# INLINE difference #-}++-- | The sites exactly one mesh holds.+symmetricDifference+  :: Triangulation 'Unconstrained annotation () () ()+  -> Triangulation 'Unconstrained annotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+symmetricDifference left right+  | numVertices left == 0 = Right right+  | numVertices right == 0 = Right left+  | numVertices right < numVertices left+  , toggleDeltaIsEligible (numVertices right) (numVertices left - numVertices right) =+      toggleIncoming left right+  | numVertices left < numVertices right+  , toggleDeltaIsEligible (numVertices left) (numVertices right - numVertices left) =+      toggleIncoming right left+  | otherwise =+      siteSetSymmetricDifferenceFromTriangulations left right+        >>= rebuildCanonicalSiteSet+{-# INLINE symmetricDifference #-}++removalDeltaIsEligible :: Int -> Int -> Bool+removalDeltaIsEligible removed survivors = removed <= survivors `quot` 128+{-# INLINE removalDeltaIsEligible #-}++toggleDeltaIsEligible :: Int -> Int -> Bool+toggleDeltaIsEligible incoming residentRemainder = incoming <= residentRemainder `quot` 128+{-# INLINE toggleDeltaIsEligible #-}++removeAvailableFrom+  :: Triangulation 'Unconstrained annotation () () ()+  -> V.Vector (Point)+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+removeAvailableFrom triangulation points =+  fmap published+    (withLocalSession triangulation 0 (V.any isJust <$> removeManyAt points))+ where+  published (removed, revised, _) = if removed then revised else triangulation+{-# INLINE removeAvailableFrom #-}++removeExpectedFrom+  :: Triangulation 'Unconstrained annotation () () ()+  -> V.Vector (Point)+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+removeExpectedFrom triangulation points =+  fmap (\(_, revised, _) -> revised)+    (withLocalSession triangulation 0 (removeExpectedPoints points))+{-# INLINE removeExpectedFrom #-}++removeExpectedPoints+  :: V.Vector (Point)+  -> Session state annotation () () () ()+removeExpectedPoints points = do+  outcomes <- removeManyAt points+  V.zipWithM_+    (\point outcome -> maybe (refuse (PointLocationFailed point)) (const (pure ())) outcome)+    points+    outcomes+{-# INLINE removeExpectedPoints #-}++toggleIncoming+  :: Triangulation 'Unconstrained annotation () () ()+  -> Triangulation 'Unconstrained annotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+toggleIncoming base incoming =+  fmap (\(_, revised, _) -> revised)+    (withLocalSession base (numVertices incoming) (toggleIncomingVertices incoming))+{-# INLINE toggleIncoming #-}++toggleIncomingVertices+  :: Triangulation 'Unconstrained annotation () () ()+  -> Session state annotation () () () ()+toggleIncomingVertices incoming =+  traverse_+    (\vertex -> do+      let point = vertexPoint incoming vertex+          annotation = vertexData incoming vertex+      (fresh, disposition) <- insertVertexAt point annotation+      case disposition of+        Inserted -> pure ()+        AlreadyPresent -> do+          outcome <- removeAtNear fresh point+          maybe (refuse (PointLocationFailed point)) (const (pure ())) outcome+    )+    (vertices incoming)+{-# INLINE toggleIncomingVertices #-}
+ src-core/Moonlight/Triangulation/Internal/BoxedPaged.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}++module Moonlight.Triangulation.Internal.BoxedPaged+  ( BoxedPaged+  , MutableBoxedPaged+  , BoxedStorageError (..)+  , emptyBoxedPaged+  , boxedFill+  , boxedPagedLength+  , boxedUnsafeIndex+  , boxedFromVector+  , boxedToVector+  , thawBoxedPaged+  , readBoxedPaged+  , writeBoxedPaged+  , resetBoxedRange+  , boxedThawPristine+  , freezeBoxedPaged+  , boxedUpdate+  ) where++import Control.DeepSeq (NFData)+import Control.Monad.ST (ST)+import Data.Bits (shiftL, shiftR, (.&.))+import qualified Data.IntMap.Strict as IntMap+import qualified Data.List as List+import Data.STRef+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import Moonlight.Triangulation.Internal.PageDirectory++import GHC.Generics (Generic)++-- | A paged payload store in which an absent page means every slot in it holds+-- the fill. The fill belongs to the store rather than to a thaw of it: a+-- payload component either has a default that new elements inherit — the three+-- element payloads do — or it has none and every slot must be written before it+-- is read, which is the vertex component, whose payloads arrive with it.+--+-- The near-universal instantiation is @() () ()@, and under an unconditional+-- representation that costs one pointer per directed edge, undirected edge and+-- face, all aimed at the same closure. Here it costs nothing: an element+-- created at its default writes no slot, so no page is ever materialized.+data BoxedStorage a+  = DenseBoxedPages !(V.Vector (V.Vector a))+  | DefaultedBoxedPages !a !(PageDirectory (V.Vector a))+  deriving stock (Generic, Functor)+  deriving anyclass (NFData)++data BoxedPaged a = BoxedPaged+  { boxedLength :: {-# UNPACK #-} !Int+  , boxedStorage :: !(BoxedStorage a)+  }+  deriving stock (Generic, Functor)+  deriving anyclass (NFData)++data BoxedStorageError+  = BoxedFreezeLengthNegative {-# UNPACK #-} !Int+  | BoxedFreezeDensePageMissing {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++boxedFill :: BoxedPaged a -> Maybe a+boxedFill BoxedPaged{boxedStorage = DenseBoxedPages _} = Nothing+boxedFill BoxedPaged{boxedStorage = DefaultedBoxedPages fill _} = Just fill++-- Structural equality would distinguish a store that materialized a page of+-- defaults from one that did not, and the two are the same store. Equality is+-- therefore what can be observed: the length, the fill every unwritten slot+-- will report, and the sequence itself.+instance Eq a => Eq (BoxedPaged a) where+  left == right =+    boxedLength left == boxedLength right+      && boxedFill left == boxedFill right+      && boxedToVector left == boxedToVector right++instance Show a => Show (BoxedPaged a) where+  showsPrec precedence paged =+    showParen (precedence > 10) $+      showString "BoxedPaged "+        . showsPrec 11 (boxedFill paged)+        . showString " "+        . showsPrec 11 (boxedToVector paged)++data MutableBoxedPaged s a = MutableBoxedPaged+  { mutableBoxedBase :: !(BoxedPaged a)+  , mutableBoxedDirty :: !(STRef s (IntMap.IntMap (MV.MVector s a)))+  , mutableBoxedFill :: !(Maybe a)+  , -- | The thaw found no materialized page. Together with an empty dirty set+    -- this says every slot in the store reports the fill, which is the state a+    -- payload component nobody writes stays in for the whole transaction —+    -- the near-universal @() () ()@ case. Read through 'boxedThawPristine'.+    mutableBoxedPristineBase :: !Bool+  }++pageBits :: Int+pageBits = 8+{-# INLINE pageBits #-}++pageSize :: Int+pageSize = 1 `shiftL` pageBits+{-# INLINE pageSize #-}++-- Every index this store decomposes is an element identifier or a walk over+-- one, so the signed division a 'quotRem' would emit corrects for a sign that+-- cannot occur.+pageOf :: Int -> Int+pageOf index = index `shiftR` pageBits+{-# INLINE pageOf #-}++offsetOf :: Int -> Int+offsetOf index = index .&. (pageSize - 1)+{-# INLINE offsetOf #-}++emptyBoxedPaged :: Maybe a -> BoxedPaged a+emptyBoxedPaged fill =+  BoxedPaged+    0+    (case fill of+       Nothing -> DenseBoxedPages V.empty+       Just value -> DefaultedBoxedPages value emptyDirectory)++boxedPagedLength :: BoxedPaged a -> Int+boxedPagedLength = boxedLength+{-# INLINE boxedPagedLength #-}++-- | Index with a handle already admitted by the owning triangulation. Dense+-- stores carry every live page explicitly; defaulted stores can answer an+-- absent or short page from their stored default. The handle domain is owned+-- by the DCEL, so this raw kernel performs no second, disagreeing bounds check.+boxedUnsafeIndex :: BoxedPaged a -> Int -> a+boxedUnsafeIndex BoxedPaged{boxedStorage} index =+  let !page = pageOf index+      !offset = offsetOf index+   in case boxedStorage of+        DenseBoxedPages pages ->+          V.unsafeIndex (V.unsafeIndex pages page) offset+        DefaultedBoxedPages fill pages ->+          case lookupDirectory page pages of+            Just values | offset < V.length values -> V.unsafeIndex values offset+            _ -> fill+{-# INLINE boxedUnsafeIndex #-}++boxedFromVector :: Maybe a -> V.Vector a -> BoxedPaged a+boxedFromVector fill values =+  BoxedPaged+    { boxedLength = V.length values+    , boxedStorage =+        case fill of+          Nothing -> DenseBoxedPages (V.fromList (map snd (go 0)))+          Just value -> DefaultedBoxedPages value (directoryFromAscList (go 0))+    }+ where+  go !offset+    | offset >= V.length values = []+    | otherwise =+        let !page = pageOf offset+            !count = min pageSize (V.length values - offset)+            !chunk = V.slice offset count values+         in (page, chunk) : go (offset + count)++-- Resolved a page at a time. Asking the directory per element paid a descent+-- for every slot of a run the descent had already found.+boxedToVector :: BoxedPaged a -> V.Vector a+boxedToVector BoxedPaged{boxedLength, boxedStorage}+  | boxedLength <= 0 = V.empty+  | otherwise = case boxedStorage of+      DenseBoxedPages pages -> V.take boxedLength (V.concat (V.toList pages))+      DefaultedBoxedPages fill pages ->+        V.concat (map (pageRun fill pages) [0 .. pageOf (boxedLength - 1)])+ where+  pageRun fill pages page =+    let !base = page `shiftL` pageBits+        !width = min pageSize (boxedLength - base)+     in case lookupDirectory page pages of+          Just values+            | V.length values >= width -> V.slice 0 width values+            | otherwise -> values V.++ V.replicate (width - V.length values) fill+          Nothing -> V.replicate width fill++-- The fill comes from the store, not from the caller. A thaw that took it as an+-- argument obliged every call site to name the right one, and 'boxedUpdate' —+-- which passed the value being written — named the wrong one. That was harmless+-- only while pages were never absent.+thawBoxedPaged :: BoxedPaged a -> ST s (MutableBoxedPaged s a)+thawBoxedPaged base = do+  mutableBoxedDirty <- newSTRef IntMap.empty+  pure+    MutableBoxedPaged+      { mutableBoxedBase = base+      , mutableBoxedDirty+      , mutableBoxedFill = boxedFill base+      , mutableBoxedPristineBase = case boxedStorage base of+          DenseBoxedPages pages -> V.null pages+          DefaultedBoxedPages _ pages -> directorySize pages == 0+      }++readBoxedPaged :: MutableBoxedPaged s a -> Int -> ST s a+readBoxedPaged MutableBoxedPaged{mutableBoxedBase, mutableBoxedDirty} index = do+  dirty <- readSTRef mutableBoxedDirty+  let !page = pageOf index+      !offset = offsetOf index+  case IntMap.lookup page dirty of+    Just values -> MV.unsafeRead values offset+    Nothing -> case boxedStorage mutableBoxedBase of+      DenseBoxedPages pages ->+        pure (V.unsafeIndex (V.unsafeIndex pages page) offset)+      DefaultedBoxedPages fill pages ->+        case lookupDirectory page pages of+          Just values | offset < V.length values -> pure (V.unsafeIndex values offset)+          _ -> pure fill+{-# INLINE readBoxedPaged #-}++writeBoxedPaged :: MutableBoxedPaged s a -> Int -> a -> ST s ()+writeBoxedPaged paged index value = do+  let !page = pageOf index+      !offset = offsetOf index+  values <- ensureMutableBoxedPage paged page+  MV.unsafeWrite values offset value+{-# INLINE writeBoxedPaged #-}++-- | Whether the thaw found no materialized page. With no writer into the+-- element payload planes inside a transaction — there is none; they are+-- written only through the persistent setters, outside one — this answers for+-- the whole transaction that every slot reports the fill, so a rewrite has+-- nothing to return and a relocation has nothing to move. It is why the+-- near-universal @() () ()@ mesh pays a predictable branch and no page.+boxedThawPristine :: MutableBoxedPaged s a -> Bool+boxedThawPristine = mutableBoxedPristineBase+{-# INLINE boxedThawPristine #-}++-- | Return a contiguous run of slots to the store's fill. A slot no write has+-- reached already reports the fill, so a page absent from both the base and the+-- dirty set is left absent: recycling an element at its default keeps the store+-- sparse. Only a page holding written values is materialized and overwritten.+resetBoxedRange :: MutableBoxedPaged s a -> a -> Int -> Int -> ST s ()+resetBoxedRange paged@MutableBoxedPaged{mutableBoxedBase, mutableBoxedDirty} fill start count+  | count <= 0 = pure ()+  | otherwise = go start+ where+  !end = start + count+  go !index+    | index >= end = pure ()+    | otherwise = do+        dirty <- readSTRef mutableBoxedDirty+        let !page = pageOf index+            !offset = offsetOf index+            !width = min (pageSize - offset) (end - index)+            !written =+              IntMap.member page dirty+                || case boxedStorage mutableBoxedBase of+                  DenseBoxedPages pages ->+                    page < V.length pages+                      && offset < V.length (V.unsafeIndex pages page)+                  DefaultedBoxedPages _ pages ->+                    case lookupDirectory page pages of+                      Just values -> offset < V.length values+                      Nothing -> False+        if written+          then do+            values <- ensureMutableBoxedPage paged page+            MV.set (MV.slice offset width values) fill+            go (index + width)+          else go (index + width)++ensureMutableBoxedPage :: MutableBoxedPaged s a -> Int -> ST s (MV.MVector s a)+ensureMutableBoxedPage MutableBoxedPaged{mutableBoxedBase, mutableBoxedDirty, mutableBoxedFill} page = do+  dirty <- readSTRef mutableBoxedDirty+  case IntMap.lookup page dirty of+    Just values -> pure values+    Nothing -> do+      -- Copying a page slot by slot writes every element twice — once to+      -- establish the fill and once to overwrite it — and pays a write barrier+      -- per store. A full page is one thaw; a short tail page fills only the+      -- slots the base does not reach. This is the same shape the unboxed+      -- store already uses.+      values <- case boxedStorage mutableBoxedBase of+        DenseBoxedPages pages+          | page < V.length pages -> copyExisting (V.unsafeIndex pages page)+          | otherwise -> MV.new pageSize+        DefaultedBoxedPages fill pages ->+          case lookupDirectory page pages of+            Just old -> copyExisting old+            Nothing -> MV.replicate pageSize fill+      writeSTRef mutableBoxedDirty $! IntMap.insert page values dirty+      pure values+ where+  copyExisting old+    | V.length old == pageSize = V.thaw old+    | otherwise = do+        vector <- case mutableBoxedFill of+          Just fill -> MV.replicate pageSize fill+          Nothing -> MV.new pageSize+        V.copy (MV.slice 0 (V.length old) vector) old+        pure vector++freezeBoxedPaged :: Int -> MutableBoxedPaged s a -> ST s (Either BoxedStorageError (BoxedPaged a))+freezeBoxedPaged length' MutableBoxedPaged{mutableBoxedBase, mutableBoxedDirty}+  | length' < 0 = pure (Left (BoxedFreezeLengthNegative length'))+  | otherwise = do+      dirty <- readSTRef mutableBoxedDirty+      frozenDirty <- traverse V.unsafeFreeze dirty+      pure $ case boxedStorage mutableBoxedBase of+        DenseBoxedPages basePages -> do+          pages <-+            traverse+              (densePage frozenDirty basePages)+              [0 .. pageCount - 1]+          pure+            BoxedPaged+              { boxedLength = length'+              , boxedStorage = DenseBoxedPages (V.fromList pages)+              }+        DefaultedBoxedPages fill basePages ->+          let !merged =+                List.foldl'+                  (\pages (page, values) -> insertDirectory page values pages)+                  basePages+                  (IntMap.toAscList frozenDirty)+              !kept = directoryRestrict pageCount merged+              !trimmed = case directoryLookupMax kept of+                Nothing -> kept+                Just (lastPage, values) ->+                  let !lastLength = length' - lastPage * pageSize+                   in if lastLength < V.length values+                        then insertDirectory lastPage (V.take lastLength values) kept+                        else kept+           in Right+                BoxedPaged+                  { boxedLength = length'+                  , boxedStorage = DefaultedBoxedPages fill trimmed+                  }+ where+  !pageCount = if length' <= 0 then 0 else pageOf (length' + pageSize - 1)++  densePage frozenDirty basePages page =+    let !width = min pageSize (length' - page * pageSize)+     in case IntMap.lookup page frozenDirty of+          Just values -> Right (V.take width values)+          Nothing -> case basePages V.!? page of+            Just values -> Right (V.take width values)+            Nothing -> Left (BoxedFreezeDensePageMissing page pageCount)++boxedUpdate :: Int -> a -> BoxedPaged a -> BoxedPaged a+boxedUpdate index value source@BoxedPaged{boxedStorage} =+  source{boxedStorage = updateStorage boxedStorage}+ where+  !page = pageOf index+  !offset = offsetOf index++  updateStorage (DenseBoxedPages pages) =+    let !values = V.unsafeIndex pages page+        !updated = V.modify (\mutable -> MV.unsafeWrite mutable offset value) values+     in DenseBoxedPages (V.modify (\mutable -> MV.unsafeWrite mutable page updated) pages)+  updateStorage (DefaultedBoxedPages fill pages) =+    let !values = case lookupDirectory page pages of+          Just existing+            | V.length existing == pageSize -> existing+            | otherwise -> existing V.++ V.replicate (pageSize - V.length existing) fill+          Nothing -> V.replicate pageSize fill+        !updated = V.modify (\mutable -> MV.unsafeWrite mutable offset value) values+     in DefaultedBoxedPages fill (insertDirectory page updated pages)
+ src-core/Moonlight/Triangulation/Internal/Dyadic.hs view
@@ -0,0 +1,491 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++module Moonlight.Triangulation.Internal.Dyadic+  ( exactOrientDet+  , exactOrientSignDouble+  , exactInCircleDet+  , exactBarycentricDeterminants+  , exactDiametralDot+  , integerRatioToDouble+  ) where++import Data.Bits (shiftL, shiftR)+#if WORD_SIZE_IN_BITS == 64+import GHC.Exts+  ( Double (D#)+  , Double#+  , Int#+  , Word#+  , and#+  , castDoubleToWord64#+  , eqWord#+  , gtWord#+  , int2Word#+  , isTrue#+  , or#+  , plusWord#+  , plusWord2#+  , subWordC#+  , timesWord2#+  , uncheckedShiftL#+  , uncheckedShiftRL#+  , word2Int#+  , word64ToWord#+  , (*#)+  , (+#)+  , (-#)+  , (<=#)+  , (==#)+  , (>#)+  , (>=#)+  )+#endif++-- Every finite binary64 value is a dyadic rational. Aligning all mantissas to+-- one exponent gives exact integer predicates without constructing Rational+-- expression trees.+type Decoded = (Integer, Int)++commonExponent :: [Decoded] -> Int+commonExponent = foldl' step 0+ where+  step :: Int -> Decoded -> Int+  step !current (!mantissa, !power)+    | mantissa == 0 = current+    | otherwise = min current power+{-# INLINE commonExponent #-}++alignDecoded :: Int -> Decoded -> Integer+alignDecoded !power (!mantissa, !sourcePower)+  | mantissa == 0 = 0+  | otherwise = mantissa `shiftL` (sourcePower - power)+{-# INLINE alignDecoded #-}++aligned6+  :: Double -> Double -> Double -> Double -> Double -> Double+  -> (Integer, Integer, Integer, Integer, Integer, Integer)+aligned6 a b c d e f =+  let !da = decodeFloat a+      !db = decodeFloat b+      !dc = decodeFloat c+      !dd = decodeFloat d+      !de = decodeFloat e+      !df = decodeFloat f+      !power = commonExponent [da, db, dc, dd, de, df]+   in ( alignDecoded power da+      , alignDecoded power db+      , alignDecoded power dc+      , alignDecoded power dd+      , alignDecoded power de+      , alignDecoded power df+      )++aligned8+  :: Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double+  -> (Integer, Integer, Integer, Integer, Integer, Integer, Integer, Integer)+aligned8 a b c d e f g h =+  let !da = decodeFloat a+      !db = decodeFloat b+      !dc = decodeFloat c+      !dd = decodeFloat d+      !de = decodeFloat e+      !df = decodeFloat f+      !dg = decodeFloat g+      !dh = decodeFloat h+      !power = commonExponent [da, db, dc, dd, de, df, dg, dh]+   in ( alignDecoded power da+      , alignDecoded power db+      , alignDecoded power dc+      , alignDecoded power dd+      , alignDecoded power de+      , alignDecoded power df+      , alignDecoded power dg+      , alignDecoded power dh+      )++exactOrientDet+  :: Double -> Double -> Double -> Double -> Double -> Double -> Integer+exactOrientDet ax ay bx by cx cy =+  let (!iax, !iay, !ibx, !iby, !icx, !icy) = aligned6 ax ay bx by cx cy+      !acx = iax - icx+      !acy = iay - icy+      !bcx = ibx - icx+      !bcy = iby - icy+   in acx * bcy - acy * bcx++exactInCircleDet+  :: Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double+  -> Integer+exactInCircleDet ax ay bx by cx cy dx dy =+  let (!iax, !iay, !ibx, !iby, !icx, !icy, !idx, !idy) =+        aligned8 ax ay bx by cx cy dx dy+      !adx = iax - idx+      !ady = iay - idy+      !bdx = ibx - idx+      !bdy = iby - idy+      !cdx = icx - idx+      !cdy = icy - idy+      !abdet = adx * bdy - bdx * ady+      !bcdet = bdx * cdy - cdx * bdy+      !cadet = cdx * ady - adx * cdy+      !alift = adx * adx + ady * ady+      !blift = bdx * bdx + bdy * bdy+      !clift = cdx * cdx + cdy * cdy+   in alift * bcdet + blift * cadet + clift * abdet++exactDiametralDot+  :: Double -> Double -> Double -> Double -> Double -> Double -> Integer+exactDiametralDot ax ay bx by px py =+  let (!iax, !iay, !ibx, !iby, !ipx, !ipy) = aligned6 ax ay bx by px py+      !pax = ipx - iax+      !pay = ipy - iay+      !pbx = ipx - ibx+      !pby = ipy - iby+   in pax * pbx + pay * pby++exactBarycentricDeterminants+  :: Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double+  -> (Integer, Integer, Integer, Integer)+exactBarycentricDeterminants ax ay bx by cx cy qx qy =+  let (!iax, !iay, !ibx, !iby, !icx, !icy, !iqx, !iqy) =+        aligned8 ax ay bx by cx cy qx qy+      determinant :: Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer+      determinant px py rx ry sx sy =+        let !psx = px - sx+            !psy = py - sy+            !rsx = rx - sx+            !rsy = ry - sy+         in psx * rsy - psy * rsx+      !denominator = determinant iax iay ibx iby icx icy+      !weightA = determinant iqx iqy ibx iby icx icy+      !weightB = determinant iax iay iqx iqy icx icy+      !weightC = determinant iax iay ibx iby iqx iqy+   in (denominator, weightA, weightB, weightC)++integerRatioToDouble :: Integer -> Integer -> Double+integerRatioToDouble numerator denominator+  | denominator == 0 = 0 / 0+  | numerator == 0 = 0+  | otherwise =+      let !precision = floatDigits (0 :: Double)+          !numeratorMagnitude = abs numerator+          !denominatorMagnitude = abs denominator+          !numeratorBits = integerBitLength numeratorMagnitude+          !denominatorBits = integerBitLength denominatorMagnitude+          !numeratorShift = max 0 (numeratorBits - precision)+          !denominatorShift = max 0 (denominatorBits - precision)+          !scaledNumerator = fromInteger (numeratorMagnitude `shiftR` numeratorShift)+          !scaledDenominator = fromInteger (denominatorMagnitude `shiftR` denominatorShift)+          !magnitude = scaleFloat (numeratorShift - denominatorShift) (scaledNumerator / scaledDenominator)+          !sameSign = (numerator < 0) == (denominator < 0)+       in if sameSign then magnitude else negate magnitude++integerBitLength :: Integer -> Int+integerBitLength = go 0+ where+  go !bits value+    | value <= 0xffffffff = bits + wordBitLength value+    | otherwise = go (bits + 32) (value `shiftR` 32)++  wordBitLength = count 0+  count :: Int -> Integer -> Int+  count !bits 0 = bits+  count !bits value = count (bits + 1) (value `shiftR` 1)++-- ---------------------------------------------------------------------------+-- Fixed-precision exact orient sign for Double.+--+-- The generic dyadic path answers every exact query with arbitrary-precision+-- Integers: six decodes, one alignment, and two multiplies, each allocating.+-- Practical inputs have an exponent spread small enough that the determinant's+-- exact sign is decided by 128-bit differences and 256-bit products in machine+-- words, without a single heap object. 'exactOrientSignDouble' takes that path+-- and falls back to 'exactOrientDet' the moment an operand is non-finite or an+-- alignment shift would outgrow the fixed width. The two agree by+-- construction: both compute the sign of the same integer determinant.+--+-- The fixed-width worker reads a Double as one machine word and aligns+-- mantissas across a 128-bit pair, so it is only meaningful where a machine+-- word is 64 bits wide. On a narrower target the same sign is taken from the+-- arbitrary-precision determinant directly, which is the branch this path+-- already falls back to whenever an alignment shift would outgrow the width.++#if WORD_SIZE_IN_BITS == 64++exactOrientSignDouble+  :: Double -> Double -> Double -> Double -> Double -> Double -> Ordering+exactOrientSignDouble ax ay bx by cx cy =+  case ax of+    D# axw ->+      case ay of+        D# ayw ->+          case bx of+            D# bxw ->+              case by of+                D# byw ->+                  case cx of+                    D# cxw ->+                      case cy of+                        D# cyw ->+                          case orientSignWorker axw ayw bxw byw cxw cyw of+                            2# -> compare (exactOrientDet ax ay bx by cx cy) 0+                            0# -> EQ+                            sign ->+                              case sign ># 0# of+                                1# -> GT+                                _ -> LT+{-# NOINLINE exactOrientSignDouble #-}++-- Decode a Double into sign bit (0/1), mantissa, and power-of-two exponent+-- with value = (-1)^sign * mantissa * 2^exponent. Zero decodes to a zero+-- mantissa; subnormals decode without a hidden bit. The fourth component is 1+-- when the value is finite and 0 when it is not.+decodeExact :: Double# -> (# Int#, Word#, Int#, Int# #)+decodeExact d =+  case word64ToWord# (castDoubleToWord64# d) of+    bits ->+      let neg = word2Int# (uncheckedShiftRL# bits 63#)+          exponentField = word2Int# (and# (uncheckedShiftRL# bits 52#) 2047##)+          mantissaField = and# bits 4503599627370495##+       in case exponentField of+            0# -> (# neg, mantissaField, -1074#, 1# #)+            2047# -> (# neg, mantissaField, 0#, 0# #)+            raw -> (# neg, or# mantissaField 4503599627370496##, raw -# 1075#, 1# #)++-- A mantissa of at most 53 bits shifted left by at most 73 bits: the pair+-- (high, low) of a value below 2^126.+shiftMantissa :: Word# -> Int# -> (# Word#, Word# #)+shiftMantissa mantissa k =+  case k >=# 64# of+    1# -> (# uncheckedShiftL# mantissa (k -# 64#), 0## #)+    _ ->+      case k ==# 0# of+        1# -> (# 0##, mantissa #)+        _ ->+          (#+            uncheckedShiftRL# mantissa (64# -# k),+            uncheckedShiftL# mantissa k+          #)++-- The exact sign and 128-bit magnitude of sa*ma*2^ea - sc*mc*2^ec, aligned+-- to the caller-supplied floor exponent, as (sign, high, low, status) with+-- sign in {-1, 0, 1} and status 1 when an alignment shift outgrows the fixed+-- width. The floor never exceeds the exponent of a nonzero operand, so every+-- shift is non-negative; one shared floor is what makes the four differences+-- of one determinant comparable after multiplication.+differenceExact+  :: Int# -> Word# -> Int# -> Int# -> Word# -> Int# -> Int# -> (# Int#, Word#, Word#, Int# #)+differenceExact nega ma ea negc mc ec emin =+  case ma of+    0## ->+      case mc of+        0## -> (# 0#, 0##, 0##, 0# #)+        _ -> aligned (negateSign (positiveSign negc)) mc (ec -# emin)+    _ ->+      case mc of+        0## -> aligned (positiveSign nega) ma (ea -# emin)+        _ ->+          case ea -# emin of+            da ->+              case da ># 73# of+                1# -> (# 0#, 0##, 0##, 1# #)+                _ ->+                  case ec -# emin of+                    dc ->+                      case dc ># 73# of+                        1# -> (# 0#, 0##, 0##, 1# #)+                        _ ->+                          case shiftMantissa ma da of+                            (# ahi, alo #) ->+                              case shiftMantissa mc dc of+                                (# chi, clo #) ->+                                  case nega ==# negc of+                                    1# ->+                                      -- Same operand signs: subtract magnitudes.+                                      case compareWord2 ahi alo chi clo of+                                        0# -> (# 0#, 0##, 0##, 0# #)+                                        1# ->+                                          case subtractWord2 ahi alo chi clo of+                                            (# hi, lo #) -> (# positiveSign nega, hi, lo, 0# #)+                                        _ ->+                                          case subtractWord2 chi clo ahi alo of+                                            (# hi, lo #) -> (# negateSign (positiveSign nega), hi, lo, 0# #)+                                    _ ->+                                      -- Opposite operand signs: add magnitudes.+                                      case addWord2 ahi alo chi clo of+                                        (# hi, lo #) -> (# positiveSign nega, hi, lo, 0# #)+  where+    aligned sign mantissa k =+      case k ># 73# of+        1# -> (# 0#, 0##, 0##, 1# #)+        _ ->+          case shiftMantissa mantissa k of+            (# hi, lo #) -> (# sign, hi, lo, 0# #)+    positiveSign neg = case neg of+      1# -> -1#+      _ -> 1#+    negateSign sign = case sign of+      1# -> -1#+      _ -> 1#++-- Lexicographic comparison of 128-bit magnitudes: 1, 0, or -1.+compareWord2 :: Word# -> Word# -> Word# -> Word# -> Int#+compareWord2 ahi alo chi clo =+  case eqWord# ahi chi of+    1# ->+      case eqWord# alo clo of+        1# -> 0#+        _ ->+          case gtWord# alo clo of+            1# -> 1#+            _ -> -1#+    _ ->+      case gtWord# ahi chi of+        1# -> 1#+        _ -> -1#++-- 128-bit difference of magnitudes, first operand at least the second.+subtractWord2 :: Word# -> Word# -> Word# -> Word# -> (# Word#, Word# #)+subtractWord2 ahi alo chi clo =+  case subWordC# alo clo of+    (# low, borrow #) ->+      case subWordC# ahi chi of+        (# high0, _ #) ->+          case subWordC# high0 (int2Word# borrow) of+            (# high, _ #) -> (# high, low #)++-- 128-bit sum of magnitudes each below 2^126: the total stays below 2^127 and+-- the final carry is empty by the shift bound.+addWord2 :: Word# -> Word# -> Word# -> Word# -> (# Word#, Word# #)+addWord2 ahi alo chi clo =+  case plusWord2# alo clo of+    (# carry0, low #) ->+      case plusWord2# ahi chi of+        (# _, high0 #) ->+          case plusWord2# high0 carry0 of+            (# _, high #) -> (# high, low #)++-- 128-bit by 128-bit exact product, (r3, r2, r1, r0), most significant first.+-- Each factor stays below 2^127, so the product stays below 2^254 and the top+-- accumulation cannot overflow.+multiplyWord2 :: Word# -> Word# -> Word# -> Word# -> (# Word#, Word#, Word#, Word# #)+multiplyWord2 ahi alo bhi blo =+  case timesWord2# alo blo of+    (# h00, l00 #) ->+      case timesWord2# alo bhi of+        (# h01, l01 #) ->+          case timesWord2# ahi blo of+            (# h10, l10 #) ->+              case timesWord2# ahi bhi of+                (# h11, l11 #) ->+                  case plusWord2# h00 l01 of+                    (# carryA, sumA #) ->+                      case plusWord2# sumA l10 of+                        (# carryB, r1 #) ->+                          case plusWord# carryA carryB of+                            carry2 ->+                              case plusWord2# h01 h10 of+                                (# carryC, sumC #) ->+                                  case plusWord2# sumC l11 of+                                    (# carryD, sumD #) ->+                                      case plusWord2# sumD carry2 of+                                        (# carryE, r2 #) ->+                                          case plusWord# (plusWord# carryC carryD) carryE of+                                            carry3 ->+                                              case plusWord# h11 carry3 of+                                                r3 -> (# r3, r2, r1, l00 #)++-- Lexicographic comparison of 256-bit magnitudes: 1, 0, or -1.+compareWord4+  :: Word# -> Word# -> Word# -> Word# -> Word# -> Word# -> Word# -> Word# -> Int#+compareWord4 a3 a2 a1 a0 b3 b2 b1 b0 =+  case compareWord2 a3 a2 b3 b2 of+    0# -> compareWord2 a1 a0 b1 b0+    answer -> answer++-- The exponent a mantissa contributes to the alignment floor: a zero+-- mantissa is exact at any floor and votes for the impossibly high sentinel.+floorExp :: Word# -> Int# -> Int#+floorExp mantissa power =+  case mantissa of+    0## -> 2000000#+    _ -> power++minExp :: Int# -> Int# -> Int#+minExp a b = if isTrue# (a <=# b) then a else b++orientSignWorker :: Double# -> Double# -> Double# -> Double# -> Double# -> Double# -> Int#+orientSignWorker ax ay bx by cx cy =+  case decodeExact ax of+    (# negax, max_, eax, okax #) ->+      case decodeExact ay of+        (# negay, may, eay, okay #) ->+          case decodeExact bx of+            (# negbx, mbx, ebx, okbx #) ->+              case decodeExact by of+                (# negby, mby, eby, okby #) ->+                  case decodeExact cx of+                    (# negcx, mcx, ecx, okcx #) ->+                      case decodeExact cy of+                        (# negcy, mcy, ecy, okcy #) ->+                          case okax +# okay +# okbx +# okby +# okcx +# okcy of+                            6# ->+                              -- The alignment floor is the least exponent+                              -- among nonzero mantissas; a zero mantissa is+                              -- exact at any floor and must not drag it down.+                              case floorExp max_ eax `minExp` floorExp may eay `minExp` floorExp mbx ebx `minExp` floorExp mby eby `minExp` floorExp mcx ecx `minExp` floorExp mcy ecy of+                                emin ->+                                  case differenceExact negax max_ eax negcx mcx ecx emin of+                                    (# s1, d1hi, d1lo, f1 #) ->+                                      case differenceExact negby mby eby negcy mcy ecy emin of+                                        (# s2, d2hi, d2lo, f2 #) ->+                                          case differenceExact negay may eay negcy mcy ecy emin of+                                            (# s3, d3hi, d3lo, f3 #) ->+                                              case differenceExact negbx mbx ebx negcx mcx ecx emin of+                                                (# s4, d4hi, d4lo, f4 #) ->+                                                  case f1 +# f2 +# f3 +# f4 of+                                                    0# ->+                                                      combineSigns+                                                        (s1 *# s2) d1hi d1lo d2hi d2lo+                                                        (s3 *# s4) d3hi d3lo d4hi d4lo+                                                    _ -> 2#+                            _ -> 2#+  where+    -- det = leftSign * leftProduct - rightSign * rightProduct+    combineSigns leftSign d1hi d1lo d2hi d2lo rightSign d3hi d3lo d4hi d4lo =+      case leftSign of+        0# ->+          case rightSign of+            0# -> 0#+            _ -> 0# -# rightSign+        _ ->+          case rightSign of+            0# -> leftSign+            _ ->+              case leftSign ==# rightSign of+                1# ->+                  case multiplyWord2 d1hi d1lo d2hi d2lo of+                    (# p3, p2, p1, p0 #) ->+                      case multiplyWord2 d3hi d3lo d4hi d4lo of+                        (# q3, q2, q1, q0 #) ->+                          case compareWord4 p3 p2 p1 p0 q3 q2 q1 q0 of+                            0# -> 0#+                            1# -> leftSign+                            _ -> 0# -# leftSign+                _ -> leftSign++#else++-- The narrow-word answer to the same question. 'exactOrientDet' is the+-- determinant the fixed-width worker exists to avoid allocating, not a+-- different quantity, so the two branches agree by construction.+exactOrientSignDouble+  :: Double -> Double -> Double -> Double -> Double -> Double -> Ordering+exactOrientSignDouble ax ay bx by cx cy =+  compare (exactOrientDet ax ay bx by cx cy) 0+{-# NOINLINE exactOrientSignDouble #-}++#endif
+ src-core/Moonlight/Triangulation/Internal/FaceQueue.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++-- | The set of faces still owed a refinement decision.+module Moonlight.Triangulation.Internal.FaceQueue+  ( FaceQueue+  , newFaceQueue+  , pushFace+  , popFace+  ) where++import Control.Monad.ST (ST)+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32)+import Moonlight.Triangulation.Internal.PackedIndex (packIndex)++-- A worst-first heap has to be told a score for every face it is offered, so+-- the caller derives one — circumradius, area, the encroachment verdict — for+-- faces that are then found acceptable and dropped. Ruppert's termination does+-- not rest on that order; it rests on every bad face being reached before the+-- run ends. So this only has to be a set with a discipline for draining it.+--+-- A stack is that, and it makes membership O(1) with nothing to compute. The+-- pending flags are what keep it a set: a face touched by several insertions+-- before it is drained is decided once, not once per touch.+--+-- The size lives in an unboxed cell for the reason the growable stack's does:+-- it is written on every push and every pop, and a boxed counter allocates a+-- box per write once the size leaves the shared small-'Int' range.+data FaceQueue s = FaceQueue+  { fqFaces :: !(MUV.MVector s Word32)+  , fqPending :: !(MUV.MVector s Bool)+  , fqSize :: !(MUV.MVector s Int)+  }++newFaceQueue :: Int -> ST s (FaceQueue s)+newFaceQueue capacity = do+  let size = max 1 capacity+  fqFaces <- MUV.new size+  fqPending <- MUV.replicate size False+  fqSize <- MUV.replicate 1 0+  pure FaceQueue{..}++-- The checked read of the pending flag is the one bound this module does not+-- establish itself: the face arrives from mesh topology. Once it succeeds,+-- uniqueness proves the stack write: at most one slot exists for each pending+-- flag, and the two vectors have the same length.+pushFace :: FaceQueue s -> Int -> ST s ()+pushFace FaceQueue{fqFaces, fqPending, fqSize} face = do+  pending <- MUV.read fqPending face+  if pending+    then pure ()+    else do+      size <- MUV.unsafeRead fqSize 0+      MUV.unsafeWrite fqFaces size (packIndex face)+      MUV.unsafeWrite fqPending face True+      MUV.unsafeWrite fqSize 0 (size + 1)++popFace :: FaceQueue s -> ST s (Maybe Int)+popFace FaceQueue{fqFaces, fqPending, fqSize} = do+  size <- MUV.unsafeRead fqSize 0+  if size == 0+    then pure Nothing+    else do+      let !index = size - 1+      face <- fromIntegral <$> MUV.unsafeRead fqFaces index+      MUV.unsafeWrite fqPending face False+      MUV.unsafeWrite fqSize 0 index+      pure (Just face)
+ src-core/Moonlight/Triangulation/Internal/Growable.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}++module Moonlight.Triangulation.Internal.Growable+  ( GrowableWord32+  , newGrowableWord32+  , clearGrowable+  , growableLength+  , pushGrowable+  , popGrowableOr+  , readGrowable+  , writeGrowable+  ) where++import Control.Monad (when)+import Control.Monad.ST (ST)+import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32)++-- | Transaction-local vector. It starts small and grows only with the local+-- frontier; no operation allocates scratch memory proportional to mesh size.+-- The size lives in an unboxed cell: the stack is popped and pushed inside+-- every legalization drain, and a boxed counter would allocate on each step.+data GrowableWord32 s = GrowableWord32+  { growableVector :: !(STRef s (MUV.MVector s Word32))+  , growableSize :: !(MUV.MVector s Int)+  }++newGrowableWord32 :: Int -> ST s (GrowableWord32 s)+newGrowableWord32 requested = do+  vector <- MUV.new (max 8 requested)+  growableVector <- newSTRef vector+  growableSize <- MUV.replicate 1 0+  pure GrowableWord32{growableVector, growableSize}++clearGrowable :: GrowableWord32 s -> ST s ()+clearGrowable GrowableWord32{growableSize} = MUV.unsafeWrite growableSize 0 0+{-# INLINE clearGrowable #-}++growableLength :: GrowableWord32 s -> ST s Int+growableLength GrowableWord32{growableSize} = MUV.unsafeRead growableSize 0+{-# INLINE growableLength #-}++pushGrowable :: GrowableWord32 s -> Word32 -> ST s ()+pushGrowable growable@GrowableWord32{growableSize} value = do+  index <- MUV.unsafeRead growableSize 0+  vector <- ensureCapacity growable (index + 1)+  MUV.unsafeWrite vector index value+  MUV.unsafeWrite growableSize 0 (index + 1)+{-# INLINE pushGrowable #-}++-- | Pop, answering the caller's sentinel on emptiness instead of allocating a+-- 'Maybe' per step. Sound only against a sentinel no push can store.+popGrowableOr :: Word32 -> GrowableWord32 s -> ST s Word32+popGrowableOr sentinel GrowableWord32{growableVector, growableSize} = do+  size <- MUV.unsafeRead growableSize 0+  if size <= 0+    then pure sentinel+    else do+      let !index = size - 1+      vector <- readSTRef growableVector+      value <- MUV.unsafeRead vector index+      MUV.unsafeWrite growableSize 0 index+      pure value+{-# INLINE popGrowableOr #-}++readGrowable :: GrowableWord32 s -> Int -> ST s Word32+readGrowable GrowableWord32{growableVector} index = do+  vector <- readSTRef growableVector+  MUV.unsafeRead vector index+{-# INLINE readGrowable #-}++writeGrowable :: GrowableWord32 s -> Int -> Word32 -> ST s ()+writeGrowable growable@GrowableWord32{growableSize} index value = do+  vector <- ensureCapacity growable (index + 1)+  MUV.unsafeWrite vector index value+  size <- MUV.unsafeRead growableSize 0+  when (index >= size) (MUV.unsafeWrite growableSize 0 (index + 1))+{-# INLINE writeGrowable #-}++-- Answering with the vector is what keeps a push to one cell read: the caller+-- would otherwise re-read the reference this just proved current.+ensureCapacity :: GrowableWord32 s -> Int -> ST s (MUV.MVector s Word32)+ensureCapacity GrowableWord32{growableVector} required = do+  vector <- readSTRef growableVector+  let !current = MUV.length vector+  if required <= current+    then pure vector+    else do+      let !next = until (>= required) (* 2) current+      grown <- MUV.grow vector (next - current)+      writeSTRef growableVector grown+      pure grown
+ src-core/Moonlight/Triangulation/Internal/PackedIndex.hs view
@@ -0,0 +1,34 @@+module Moonlight.Triangulation.Internal.PackedIndex+  ( noIndex+  , indexLimit+  , packIndex+  , unpackIndex+  , unpackOptionalIndex+  ) where++import Data.Word (Word32)++noIndex :: Word32+noIndex = maxBound++indexLimit :: Int+indexLimit = fromIntegral (maxBound - 1 :: Word32)++-- | Pack an admitted arena handle. The build boundary limits vertex capacity+-- so the mutable topology reservation, @8n + 16@, stays below 'indexLimit';+-- every caller supplies a non-negative handle or worklist position derived+-- from those arenas. Optional @-1@ handles are represented separately by+-- 'noIndex' before this function is reached.+packIndex :: Int -> Word32+packIndex = fromIntegral+{-# INLINE packIndex #-}++unpackIndex :: Word32 -> Int+unpackIndex = fromIntegral+{-# INLINE unpackIndex #-}++unpackOptionalIndex :: Word32 -> Maybe Int+unpackOptionalIndex value+  | value == noIndex = Nothing+  | otherwise = Just (unpackIndex value)+{-# INLINE unpackOptionalIndex #-}
+ src-core/Moonlight/Triangulation/Internal/PageDirectory.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | The map from page number to page, for the paged stores.+module Moonlight.Triangulation.Internal.PageDirectory+  ( PageDirectory+  , emptyDirectory+  , lookupDirectory+  , insertDirectory+  , directoryFromAscList+  , directoryToAscList+  , directorySize+  , directoryLookupMax+  , directoryRestrict+  ) where++import Control.DeepSeq (NFData)+import Data.Bits (shiftL, shiftR, (.&.))+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import GHC.Generics (Generic)++-- Page numbers are small, dense and non-negative, and the read path resolves+-- one on every field access that misses its owner's current page. An ordered+-- map answers that with a chain of prefix comparisons whose length grows with+-- the mesh; a 32-way radix answers it with two indexed loads at every size the+-- meshes reach, and the arithmetic is shifts and masks rather than branches.+--+-- Absence is representable because the boxed payload store leaves a page out+-- entirely when every slot in it still holds the fill.+data Slot a+  = Absent+  | Page !a+  | Fanout !(V.Vector (Slot a))+  deriving stock (Generic, Functor)+  deriving anyclass (NFData)++-- | @directoryHeight@ counts the fanout levels below the root: at height 0 the+-- root's children are pages, at height 1 they are fanouts of pages, and so on.+data PageDirectory a = PageDirectory+  { directoryHeight :: {-# UNPACK #-} !Int+  , directoryRoot :: !(Slot a)+  , directorySize :: {-# UNPACK #-} !Int+  }+  deriving stock (Generic, Functor)+  deriving anyclass (NFData)++fanout :: Int+fanout = 32+{-# INLINE fanout #-}++slotBits :: Int+slotBits = 5+{-# INLINE slotBits #-}++-- Path copying replaces one slot per level, and the bulk-update operator would+-- route that through a list of one pair. This is the copy the level needs and+-- nothing besides.+updateSlot :: V.Vector (Slot a) -> Int -> Slot a -> V.Vector (Slot a)+updateSlot children index child =+  V.modify (\node -> MV.unsafeWrite node index child) children+{-# INLINE updateSlot #-}++-- | The first page number a directory of this height cannot address.+capacity :: Int -> Int+capacity height = 1 `shiftL` (slotBits * (height + 1))+{-# INLINE capacity #-}++emptyDirectory :: PageDirectory a+emptyDirectory = PageDirectory 0 Absent 0++lookupDirectory :: Int -> PageDirectory a -> Maybe a+lookupDirectory key PageDirectory{directoryHeight, directoryRoot}+  | key < 0 || key >= capacity directoryHeight = Nothing+  | otherwise = go directoryHeight directoryRoot+ where+  go !height slot = case slot of+    Absent -> Nothing+    Page value -> Just value+    Fanout children ->+      go (height - 1) (V.unsafeIndex children ((key `shiftR` (slotBits * height)) .&. (fanout - 1)))+{-# INLINE lookupDirectory #-}++insertDirectory :: Int -> a -> PageDirectory a -> PageDirectory a+insertDirectory key value directory+  | key >= capacity (directoryHeight directory) = insertDirectory key value (grow directory)+  | otherwise =+      let (!root, !added) = write (directoryHeight directory) (directoryRoot directory)+       in directory+            { directoryRoot = root+            , directorySize = directorySize directory + if added then 1 else 0+            }+ where+  write !height slot+    | height < 0 = (Page value, case slot of Page _ -> False; _ -> True)+    | otherwise =+        let !index = (key `shiftR` (slotBits * height)) .&. (fanout - 1)+            !children = case slot of+              Fanout existing -> existing+              _ -> V.replicate fanout Absent+            (!child, !added) = write (height - 1) (V.unsafeIndex children index)+         in (Fanout (updateSlot children index child), added)++-- A directory that has run out of addressable pages gains a level, and its+-- whole former extent becomes child zero of the new root.+grow :: PageDirectory a -> PageDirectory a+grow directory@PageDirectory{directoryHeight, directoryRoot} =+  directory+    { directoryHeight = directoryHeight + 1+    , directoryRoot = case directoryRoot of+        Absent -> Absent+        occupied -> Fanout (updateSlot (V.replicate fanout Absent) 0 occupied)+    }++-- | Build from ascending, distinct page numbers in one descent.+--+-- Every dense transaction ends by publishing a whole directory, so this is on+-- the freeze path of bulk load, constraint recovery and refinement alike.+-- Folding 'insertDirectory' over the list would copy each root path once per+-- page; laying the levels down directly touches each node once.+directoryFromAscList :: [(Int, a)] -> PageDirectory a+directoryFromAscList [] = emptyDirectory+directoryFromAscList entries@((firstKey, _) : remainingEntries) =+  PageDirectory+    { directoryHeight = height+    , directoryRoot = fst (build height 0 entries)+    , directorySize = length entries+    }+ where+  !largest = foldl' (\largestKey (key, _) -> max largestKey key) firstKey remainingEntries+  !height = heightFor 0+  heightFor !candidate+    | largest < capacity candidate = candidate+    | otherwise = heightFor (candidate + 1)++  build :: Int -> Int -> [(Int, b)] -> (Slot b, [(Int, b)])+  build !level !base remaining = case remaining of+    [] -> (Absent, [])+    ((key, value) : rest)+      | key >= base + capacity level -> (Absent, remaining)+      | level < 0 -> (Page value, rest)+      | otherwise ->+          let !childSpan = capacity (level - 1)+              step (children, unconsumed) index =+                let (!child, !beyond) = build (level - 1) (base + index * childSpan) unconsumed+                 in (child : children, beyond)+              (!reversed, !left) = foldl' step ([], remaining) [0 .. fanout - 1]+           in (Fanout (V.fromListN fanout (reverse reversed)), left)++directoryToAscList :: PageDirectory a -> [(Int, a)]+directoryToAscList PageDirectory{directoryHeight, directoryRoot} = go directoryHeight 0 directoryRoot []+ where+  go :: Int -> Int -> Slot b -> [(Int, b)] -> [(Int, b)]+  go !height !prefix slot rest = case slot of+    Absent -> rest+    Page value -> (prefix, value) : rest+    Fanout children ->+      foldr+        (\index accumulated ->+          go+            (height - 1)+            (prefix + (index `shiftL` (slotBits * height)))+            (V.unsafeIndex children index)+            accumulated+        )+        rest+        [0 .. fanout - 1]++directoryLookupMax :: PageDirectory a -> Maybe (Int, a)+directoryLookupMax PageDirectory{directoryHeight, directoryRoot} = go directoryHeight 0 directoryRoot+ where+  go :: Int -> Int -> Slot b -> Maybe (Int, b)+  go !height !prefix slot = case slot of+    Absent -> Nothing+    Page value -> Just (prefix, value)+    Fanout children -> descend (fanout - 1)+     where+      descend !index+        | index < 0 = Nothing+        | otherwise =+            case go (height - 1) (prefix + (index `shiftL` (slotBits * height))) (V.unsafeIndex children index) of+              Nothing -> descend (index - 1)+              found -> found++-- | Keep only the pages a directory of the given page count can hold. The+-- common case is that every page is already within the count, and that is+-- settled by one descent rather than a rebuild.+directoryRestrict :: Int -> PageDirectory a -> PageDirectory a+directoryRestrict pageCount directory+  | pageCount <= 0 = emptyDirectory+  | otherwise = case directoryLookupMax directory of+      Nothing -> directory+      Just (largest, _)+        | largest < pageCount -> directory+        | otherwise ->+            directoryFromAscList (filter ((< pageCount) . fst) (directoryToAscList directory))
+ src-core/Moonlight/Triangulation/Internal/Paged.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE BangPatterns #-}++module Moonlight.Triangulation.Internal.Paged+  ( Paged+  , MutablePaged+  , emptyPaged+  , fromVector+  , fromLocalVector+  , toVector+  , pagedLength+  , pagedUnsafeIndex+  , pagedFoldl'+  , newMutablePaged+  , newLocalMutablePaged+  , TransactionShape (..)+  , thawPaged+  , thawPagedDense+  , thawPagedShaped+  , readPaged+  , writePaged+  , freezePaged+  ) where++import Control.DeepSeq (NFData (..))+import Control.Monad.ST (ST, runST)+import Data.Bits (shiftL, shiftR, (.&.))+import Data.STRef (STRef, modifySTRef', newSTRef, readSTRef)+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MUV++-- | One physical store with two lawful local sections. A bulk constructor+-- publishes one contiguous plane for hot traversal. A persistent edit derives+-- fixed-size shared pages from that plane without copying and republishes only+-- pages it wrote. Both constructors denote exactly the same indexed sequence;+-- equality, serialization, and compaction descend through that sequence.+data Paged a+  = FlatPaged {-# UNPACK #-} !Int {-# UNPACK #-} !Int !(U.Vector a)+  | SharedPaged {-# UNPACK #-} !Int {-# UNPACK #-} !Int !(V.Vector (U.Vector a))++-- | A fresh build owns a contiguous arena. A transaction over a published+-- value owns only its mutable page table and clones a page before its first+-- write. No mutable page or state token can escape this module.+data MutablePaged s a+  = MutableFlatPaged {-# UNPACK #-} !Int !(MUV.MVector s a)+  | MutableSharedPaged+      {-# UNPACK #-} !Int+      !(Paged a)+      !(V.Vector (U.Vector a))+      !(MV.MVector s (MUV.MVector s a))+      !(MUV.MVector s Bool)+      !(STRef s Int)++localPageBits :: Int+localPageBits = 8+{-# INLINE localPageBits #-}++-- A published plane's page geometry is the clone quantum of every+-- copy-on-write transaction opened on it. Full ladder 2026-08-06 on the+-- star-local excise (persistent-removal 10k/2.5k, min of 4 interleaved+-- rounds): 62.6ms at 12 bits, 57.2ms at 10, 83.2ms at 8 — reproducing the+-- 2026-08-05 finding that at 8 bits the per-transaction table build and+-- freeze scan outweigh the smaller clones (profiled there at 61% of the+-- lane), while at 12 the scattered-touch clones dominate instead. 10 is the+-- measured saddle between the two taxes.+traversalPageBits :: Int+traversalPageBits = 10+{-# INLINE traversalPageBits #-}++pageSize :: Int -> Int+pageSize bits = 1 `shiftL` bits+{-# INLINE pageSize #-}++pageOf :: Int -> Int -> Int+pageOf bits index = index `shiftR` bits+{-# INLINE pageOf #-}++offsetOf :: Int -> Int -> Int+offsetOf bits index = index .&. (pageSize bits - 1)+{-# INLINE offsetOf #-}++pagesFor :: Int -> Int -> Int+pagesFor bits count+  | count <= 0 = 0+  | otherwise = pageOf bits (count + pageSize bits - 1)+{-# INLINE pagesFor #-}++pagedLength :: Paged a -> Int+pagedLength paged =+  case paged of+    FlatPaged count _ _ -> count+    SharedPaged count _ _ -> count+{-# INLINE pagedLength #-}++pagedBits :: Paged a -> Int+pagedBits paged = case paged of+  FlatPaged _ bits _ -> bits+  SharedPaged _ bits _ -> bits+{-# INLINE pagedBits #-}++pageVector :: U.Unbox a => Paged a -> V.Vector (U.Vector a)+pageVector source = case source of+  FlatPaged count bits values ->+    V.generate+      (pagesFor bits count)+      (\index ->+         let !offset = index `shiftL` bits+             !width = min (pageSize bits) (count - offset)+          in U.unsafeSlice offset width values+      )+  SharedPaged _ _ pages -> pages+{-# INLINE pageVector #-}++instance (U.Unbox a, Eq a) => Eq (Paged a) where+  left == right =+    pagedLength left == pagedLength right+      && case (left, right) of+           (FlatPaged _ _ leftValues, FlatPaged _ _ rightValues) ->+             leftValues == rightValues+           _ -> pagedChunksEqual left right++-- Structural equality is a join shortcut and must not materialize either+-- operand. Chunks are compared over the overlap of the two page geometries,+-- so operands with different page widths still compare slice against slice.+pagedChunksEqual :: (U.Unbox a, Eq a) => Paged a -> Paged a -> Bool+pagedChunksEqual left right = walk 0+ where+  !count = pagedLength left+  !leftBits = pagedBits left+  !rightBits = pagedBits right+  leftPages = pageVector left+  rightPages = pageVector right+  walk !offset+    | offset >= count = True+    | otherwise =+        let !leftPage = V.unsafeIndex leftPages (pageOf leftBits offset)+            !leftOffset = offsetOf leftBits offset+            !rightPage = V.unsafeIndex rightPages (pageOf rightBits offset)+            !rightOffset = offsetOf rightBits offset+            !width =+              min+                (count - offset)+                ( min+                    (U.length leftPage - leftOffset)+                    (U.length rightPage - rightOffset)+                )+         in U.unsafeSlice leftOffset width leftPage+              == U.unsafeSlice rightOffset width rightPage+              && walk (offset + width)++instance (U.Unbox a, Show a) => Show (Paged a) where+  showsPrec precedence = showsPrec precedence . U.toList . toVector++instance NFData (Paged a) where+  rnf paged =+    case paged of+      FlatPaged count bits values -> count `seq` bits `seq` values `seq` ()+      SharedPaged count bits pages ->+        count `seq` bits `seq` V.foldl' (\() page -> page `seq` ()) () pages++emptyPaged :: Paged a+emptyPaged = SharedPaged 0 traversalPageBits V.empty++-- The padding belongs to page publication rather than dense ingress. A dense+-- plane stores exactly its live sequence and therefore needs no tail value.+fromVector :: U.Unbox a => a -> U.Vector a -> Paged a+fromVector _padding values = FlatPaged (U.length values) traversalPageBits values++-- | Dense ingress whose future edits are expected to be local. The value is+-- still one flat plane until a transaction publishes a changed leaf.+fromLocalVector :: U.Unbox a => a -> U.Vector a -> Paged a+fromLocalVector _padding values = FlatPaged (U.length values) localPageBits values++toVector :: U.Unbox a => Paged a -> U.Vector a+toVector paged =+  case paged of+    FlatPaged _ _ values -> values+    SharedPaged count bits pages+      | count <= 0 -> U.empty+      | otherwise -> runST $ do+          output <- MUV.new count+          let copyPage !pageIndex !offset+                | offset >= count = pure ()+                | otherwise = do+                    let !width = min (pageSize bits) (count - offset)+                    U.copy+                      (MUV.unsafeSlice offset width output)+                      (U.unsafeSlice 0 width (V.unsafeIndex pages pageIndex))+                    copyPage (pageIndex + 1) (offset + width)+          copyPage 0 0+          U.unsafeFreeze output++pagedUnsafeIndex :: U.Unbox a => Paged a -> Int -> a+pagedUnsafeIndex paged index =+  case paged of+    FlatPaged _ _ values -> U.unsafeIndex values index+    SharedPaged _ bits pages ->+      U.unsafeIndex (V.unsafeIndex pages (pageOf bits index)) (offsetOf bits index)+{-# INLINE pagedUnsafeIndex #-}++pagedFoldl' :: U.Unbox a => (b -> a -> b) -> b -> Paged a -> b+pagedFoldl' step initial paged =+  case paged of+    FlatPaged _ _ values -> U.foldl' step initial values+    SharedPaged count bits pages -> foldPages 0 0 initial+     where+      foldPages !pageIndex !offset !accumulated+        | offset >= count = accumulated+        | otherwise =+            let !width = min (pageSize bits) (count - offset)+                !next =+                  U.foldl'+                    step+                    accumulated+                    (U.unsafeSlice 0 width (V.unsafeIndex pages pageIndex))+             in foldPages (pageIndex + 1) (offset + width) next+{-# INLINE pagedFoldl' #-}++-- | Allocate the one contiguous mutable arena owned by a fresh constructor.+newMutablePaged :: U.Unbox a => Int -> ST s (MutablePaged s a)+newMutablePaged capacity = MutableFlatPaged traversalPageBits <$> MUV.new (max 0 capacity)++newLocalMutablePaged :: U.Unbox a => Int -> ST s (MutablePaged s a)+newLocalMutablePaged capacity = MutableFlatPaged localPageBits <$> MUV.new (max 0 capacity)++-- | Derive a copy-on-write page table from a published plane. Flat bases+-- become zero-copy slices of their one ByteArray; already shared bases reuse+-- their page vectors. Capacity-only tail pages all point to one empty sentinel+-- and acquire storage only when an append first writes them. Reads stay one+-- direct page-table access — 2026-08-05, measured: routing reads through a+-- dirty-map overlay instead taxed every walk and regressed the local verbs by+-- 2x, so the table is built eagerly and only publication consults ownership.+thawPaged :: U.Unbox a => Int -> Paged a -> ST s (MutablePaged s a)+thawPaged requestedCapacity paged = do+  let !count = pagedLength paged+      !capacity = max requestedCapacity count+      !bits = pagedBits paged+      !basePages = pageVector paged+      !basePageCount = V.length basePages+      !pageCount = pagesFor bits capacity+  pages <- MV.new pageCount+  owned <- MUV.replicate pageCount False+  ownedCount <- newSTRef 0+  sentinel <- MUV.new 0+  V.imapM_+    (\index immutablePage ->+       U.unsafeThaw immutablePage >>= MV.unsafeWrite pages index+    )+    basePages+  MV.set+    (MV.unsafeSlice basePageCount (pageCount - basePageCount) pages)+    sentinel+  pure (MutableSharedPaged bits paged basePages pages owned ownedCount)++-- | The two lawful physical sections of one transaction boundary. Both+-- publish the same canonical sequence; they differ in what the transaction+-- pays for. The choice belongs to the operation that knows its own edit+-- volume, never to a public caller.+data TransactionShape = DenseTransaction | LocalTransaction++thawPagedShaped :: U.Unbox a => TransactionShape -> Int -> Paged a -> ST s (MutablePaged s a)+thawPagedShaped shape = case shape of+  DenseTransaction -> thawPagedDense+  LocalTransaction -> thawPaged+{-# INLINE thawPagedShaped #-}++-- | Materialize one dense mutable arena from a published value. A batch+-- transaction amortizes this single copy over many edits and then reads and+-- writes flat storage with no page bookkeeping; the copy-on-write 'thawPaged'+-- remains the local-edit section whose publication is proportional to dirty+-- pages. Both freeze to the same canonical sequence.+thawPagedDense :: U.Unbox a => Int -> Paged a -> ST s (MutablePaged s a)+thawPagedDense requestedCapacity paged = do+  let !count = pagedLength paged+      !capacity = max requestedCapacity count+  values <- MUV.new capacity+  case paged of+    FlatPaged _ _ source ->+      U.copy (MUV.unsafeSlice 0 count values) source+    SharedPaged _ bits pages ->+      let copyPage !pageIndex !offset+            | offset >= count = pure ()+            | otherwise = do+                let !width = min (pageSize bits) (count - offset)+                U.copy+                  (MUV.unsafeSlice offset width values)+                  (U.unsafeSlice 0 width (V.unsafeIndex pages pageIndex))+                copyPage (pageIndex + 1) (offset + width)+       in copyPage 0 0+  pure (MutableFlatPaged (pagedBits paged) values)++readPaged :: U.Unbox a => MutablePaged s a -> Int -> ST s a+readPaged mutable index =+  case mutable of+    MutableFlatPaged _ values -> MUV.unsafeRead values index+    MutableSharedPaged bits _ _ pages _ _ -> do+      page <- MV.unsafeRead pages (pageOf bits index)+      MUV.unsafeRead page (offsetOf bits index)+{-# INLINE readPaged #-}++writePaged :: U.Unbox a => MutablePaged s a -> Int -> a -> ST s ()+writePaged mutable index value =+  case mutable of+    MutableFlatPaged _ values -> MUV.unsafeWrite values index value+    MutableSharedPaged bits _ _ pages owned ownedCount -> do+      let !slot = pageOf bits index+      mine <- MUV.unsafeRead owned slot+      page <-+        if mine+          then MV.unsafeRead pages slot+          else acquireSharedWritablePage (pageSize bits) pages owned ownedCount slot+      MUV.unsafeWrite page (offsetOf bits index) value+{-# INLINE writePaged #-}++-- Keep the once-per-page copy-on-write transition behind one compiled+-- boundary. Both steady-state write paths remain inline; dependent modules do+-- not repeatedly simplify page cloning into every element write.+acquireSharedWritablePage+  :: U.Unbox a+  => Int+  -> MV.MVector s (MUV.MVector s a)+  -> MUV.MVector s Bool+  -> STRef s Int+  -> Int+  -> ST s (MUV.MVector s a)+acquireSharedWritablePage width pages owned ownedCount slot = do+  shared <- MV.unsafeRead pages slot+  copy <-+    if MUV.length shared == width+      then MUV.clone shared+      else do+        copy <- MUV.new width+        MUV.copy (MUV.unsafeSlice 0 (MUV.length shared) copy) shared+        pure copy+  MV.unsafeWrite pages slot copy+  MUV.unsafeWrite owned slot True+  modifySTRef' ownedCount (+ 1)+  pure copy+{-# INLINE[0] acquireSharedWritablePage #-}++freezePaged :: U.Unbox a => Int -> MutablePaged s a -> ST s (Paged a)+freezePaged count mutable+  | count <= 0 = pure emptyPaged+  | otherwise =+      case mutable of+        -- 'U.take' is an O(1) slice, so freezing that way republishes the whole+        -- growth reservation and holds it for the lifetime of the value. The+        -- arena is deliberately loose during construction; carrying that slack+        -- past publication is not the same decision. Above an eighth the copy+        -- is paid once and the dead tail is released, which is also what the+        -- shared branch below already does by generating exactly its pages.+        MutableFlatPaged bits values+          | MUV.length values <= count + (count `quot` 8) ->+              FlatPaged count bits . U.take count <$> U.unsafeFreeze values+          | otherwise ->+              FlatPaged count bits <$> U.freeze (MUV.unsafeSlice 0 count values)+        MutableSharedPaged bits base basePages pages owned ownedCount -> do+          dirtyPages <- readSTRef ownedCount+          if dirtyPages == 0 && count == pagedLength base+            -- An untouched plane republishes as the value it opened on.+            then pure base+            else+              SharedPaged count bits+                <$> V.generateM+                  (pagesFor bits count)+                  (\index -> do+                     mine <- MUV.unsafeRead owned index+                     if mine+                       then MV.unsafeRead pages index >>= U.unsafeFreeze+                       else+                         if index >= V.length basePages+                           -- A clean slot past the base geometry still holds+                           -- the zero-length sentinel; publish allocated+                           -- storage instead, matching the flat arena's+                           -- answer to an unwritten tail.+                           then MUV.new (pageSize bits) >>= U.unsafeFreeze+                           else pure (V.unsafeIndex basePages index)+                  )
+ src-core/Moonlight/Triangulation/LineSideInfo.hs view
@@ -0,0 +1,55 @@+-- | Which side of a directed line a point falls on, as a total three-valued+-- answer that carries the collinear case rather than rounding it away.+module Moonlight.Triangulation.LineSideInfo+  ( LineSideInfo+  , fromDeterminant+  , fromOrdering+  , sideOrdering+  , isOnLeftSide+  , isOnRightSide+  , isOnLine+  , isOnLeftSideOrLine+  , isOnRightSideOrLine+  , reverseSide+  ) where++-- | A three-valued side: the collinear case is a value, not a rounding.+newtype LineSideInfo = LineSideInfo Ordering+  deriving stock (Show)+  deriving newtype (Eq, Ord)++-- | The side an orientation determinant's sign names.+fromDeterminant :: Double -> LineSideInfo+fromDeterminant value = LineSideInfo (compare value 0)+{-# INLINE fromDeterminant #-}++-- | The side an 'Ordering' names.+fromOrdering :: Ordering -> LineSideInfo+fromOrdering = LineSideInfo+{-# INLINE fromOrdering #-}++-- | The underlying 'Ordering'.+sideOrdering :: LineSideInfo -> Ordering+sideOrdering (LineSideInfo ordering) = ordering+{-# INLINE sideOrdering #-}++-- | The five side tests; the @OrLine@ pair admit the collinear case.+isOnLeftSide, isOnRightSide, isOnLine, isOnLeftSideOrLine, isOnRightSideOrLine :: LineSideInfo -> Bool+isOnLeftSide (LineSideInfo ordering) = ordering == GT+isOnRightSide (LineSideInfo ordering) = ordering == LT+isOnLine (LineSideInfo ordering) = ordering == EQ+isOnLeftSideOrLine side = not (isOnRightSide side)+isOnRightSideOrLine side = not (isOnLeftSide side)+{-# INLINE isOnLeftSide #-}+{-# INLINE isOnRightSide #-}+{-# INLINE isOnLine #-}+{-# INLINE isOnLeftSideOrLine #-}+{-# INLINE isOnRightSideOrLine #-}++-- | The same point, seen along the reversed line.+reverseSide :: LineSideInfo -> LineSideInfo+reverseSide (LineSideInfo ordering) = LineSideInfo $ case ordering of+  LT -> GT+  EQ -> EQ+  GT -> LT+{-# INLINE reverseSide #-}
+ src-core/Moonlight/Triangulation/Scalar.hs view
@@ -0,0 +1,127 @@+-- | The binary64 coordinate kernel and exact predicate boundary.+module Moonlight.Triangulation.Scalar+  ( scalarName+  , scalarByteSize+  , scalarBinaryFormat+  , scalarEpsilon+  , scalarUnitRoundoff+  , scalarCcwErrorBound+  , scalarInCircleErrorBound+  , orient2dCoordinates+  , inCircleCoordinates+  , BinaryFormat+  , formatRadix+  , formatMantissaDigits+  , formatExponentRange+  , minimumAllowedCoordinate+  , maximumAllowedCoordinate+  , canonicalScalarZero+  ) where++import Moonlight.Triangulation.Internal.Dyadic (exactInCircleDet, exactOrientSignDouble)++-- | The coordinate component of canonical point identity. IEEE signed zeros+-- compare equal but hash differently by bits; every coordinate-keyed owner+-- therefore normalizes them before storage or hashing.+canonicalScalarZero :: Double -> Double+canonicalScalarZero value+  | value == 0 = 0+  | otherwise = value+{-# INLINE canonicalScalarZero #-}++data BinaryFormat = BinaryFormat+  { formatRadix :: !Integer+  , formatMantissaDigits :: !Int+  , formatExponentRange :: !(Int, Int)+  }+  deriving stock (Eq, Show)++scalarName :: String+scalarName = "binary64"++scalarByteSize :: Int+scalarByteSize = 8++scalarBinaryFormat :: BinaryFormat+scalarBinaryFormat =+  BinaryFormat+    { formatRadix = floatRadix (0 :: Double)+    , formatMantissaDigits = floatDigits (0 :: Double)+    , formatExponentRange = floatRange (0 :: Double)+    }++scalarEpsilon :: Double+scalarEpsilon = 2.220446049250313e-16++scalarUnitRoundoff :: Double+scalarUnitRoundoff = 1.1102230246251565e-16++scalarCcwErrorBound :: Double+scalarCcwErrorBound = 3.3306690738754716e-16++scalarInCircleErrorBound :: Double+scalarInCircleErrorBound = 1.1102230246251577e-15++orient2dCoordinates+  :: Double -> Double -> Double -> Double -> Double -> Double+  -> Ordering+orient2dCoordinates = filteredOrient2dDouble++inCircleCoordinates+  :: Double -> Double -> Double -> Double+  -> Double -> Double -> Double -> Double+  -> Ordering+inCircleCoordinates = filteredInCircle scalarInCircleErrorBound++-- The binary64 kernel pairs the approximation test with the+-- fixed-precision exact sign, which answers the dyadic determinant's sign in+-- machine words rather than allocated Integers whenever the exponent spread+-- allows, and defers to the dyadic determinant when it does not.+filteredOrient2dDouble+  :: Double -> Double -> Double -> Double -> Double -> Double -> Ordering+filteredOrient2dDouble ax ay bx by cx cy+  | abs determinant > errorBound * determinantSum = compare determinant 0+  | otherwise = exactOrientSignDouble ax ay bx by cx cy+ where+  errorBound = 3.3306690738754716e-16+  !left = (ax - cx) * (by - cy)+  !right = (ay - cy) * (bx - cx)+  !determinant = left - right+  !determinantSum = abs left + abs right+{-# INLINE filteredOrient2dDouble #-}++filteredInCircle+  :: Double+  -> Double -> Double -> Double -> Double+  -> Double -> Double -> Double -> Double+  -> Ordering+filteredInCircle errorBound ax ay bx by cx cy dx dy+  | abs determinant > errorBound * permanent = compare determinant 0+  | otherwise = compare (exactInCircleDet ax ay bx by cx cy dx dy) 0+ where+  !adx = ax - dx+  !ady = ay - dy+  !bdx = bx - dx+  !bdy = by - dy+  !cdx = cx - dx+  !cdy = cy - dy+  !abdet = adx * bdy - bdx * ady+  !bcdet = bdx * cdy - cdx * bdy+  !cadet = cdx * ady - adx * cdy+  !alift = adx * adx + ady * ady+  !blift = bdx * bdx + bdy * bdy+  !clift = cdx * cdx + cdy * cdy+  !determinant = alift * bcdet + blift * cadet + clift * abdet+  !permanent =+    (abs (bdx * cdy) + abs (cdx * bdy)) * alift+      + (abs (cdx * ady) + abs (adx * cdy)) * blift+      + (abs (adx * bdy) + abs (bdx * ady)) * clift+{-# INLINE filteredInCircle #-}++-- | The smallest coordinate magnitude the exact predicates accept.+minimumAllowedCoordinate :: Double+minimumAllowedCoordinate = 1.793662034335766e-43++-- | The largest coordinate magnitude the exact predicates accept.+maximumAllowedCoordinate :: Double+maximumAllowedCoordinate = 3.2138760885179806e60
+ src-dcel/Moonlight/Triangulation/Dcel.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}++-- | Constant-time observations and persistent payload updates over the+-- immutable DCEL.+module Moonlight.Triangulation.Dcel+  ( outerFace+  , numVertices+  , numDirectedEdges+  , numUndirectedEdges+  , numFaces+  , numInnerFaces+  , vertexPoint+  , vertexPoints+  , vertexData+  , directedEdgeData+  , undirectedEdgeData+  , faceData+  , setVertexData+  , setDirectedEdgeData+  , setUndirectedEdgeData+  , setFaceData+  , mapVertices+  , mapDirectedEdges+  , mapUndirectedEdges+  , mapFaces+  , vertexOutEdge+  , adjacentEdge+  , origin+  , destination+  , next+  , previous+  , incidentFace+  , isOuterDirectedEdge+  , isBoundaryEdge+  , isConstraintEdge+  , numConstraints+  , undirectedEndpoints+  , faceDirectedEdges+  , faceVertices+  , innerFaceDirectedEdges+  , innerFaceVertices+  , innerFaceVertexTriples+  , vertexOutgoingEdges+  , clockwise+  , counterClockwise+  , foldFaceDirectedEdges'+  , foldVertexOutgoingEdges'+  , topologyIndexBytes+  , geometryTopologyBytes+  ) where++import qualified Data.Vector as V+import Data.Word (Word8)+import GHC.Exts (build)+import Moonlight.Triangulation.Internal.BoxedPaged (boxedUnsafeIndex, boxedUpdate)+import Moonlight.Triangulation.Internal.Paged (pagedLength, pagedUnsafeIndex)+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Internal.PackedIndex (unpackOptionalIndex)+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Scalar (scalarByteSize)++-- | The unique unbounded face, always stored at index zero.+outerFace :: FaceId+outerFace = FaceId 0++-- | Number of vertices in the mesh.+numVertices :: Triangulation mode vertex directed undirected face -> Int+numVertices = pagedLength . triPointX+{-# INLINE numVertices #-}++numDirectedEdges :: Triangulation mode vertex directed undirected face -> Int+numDirectedEdges = (`quot` 4) . pagedLength . triHalfTopology+{-# INLINE numDirectedEdges #-}++-- | Number of twin pairs in the mesh.+numUndirectedEdges :: Triangulation mode vertex directed undirected face -> Int+numUndirectedEdges triangulation = numDirectedEdges triangulation `quot` 2+{-# INLINE numUndirectedEdges #-}++-- | Number of faces, including 'outerFace'.+numFaces :: Triangulation mode vertex directed undirected face -> Int+numFaces = pagedLength . triFaceEdge+{-# INLINE numFaces #-}++numInnerFaces :: Triangulation mode vertex directed undirected face -> Int+numInnerFaces triangulation = max 0 (numFaces triangulation - 1)+{-# INLINE numInnerFaces #-}++-- | Authoritative geometric position of an admitted vertex handle.+vertexPoint :: Triangulation mode vertex directed undirected face -> VertexId -> Point+vertexPoint triangulation (VertexId vertex) =+  let !index = fromIntegral vertex+   in Point (pagedUnsafeIndex (triPointX triangulation) index) (pagedUnsafeIndex (triPointY triangulation) index)+{-# INLINE vertexPoint #-}++vertexPoints :: Triangulation mode vertex directed undirected face -> V.Vector Point+vertexPoints triangulation =+  V.generate (numVertices triangulation) (vertexPoint triangulation . VertexId . fromIntegral)+{-# INLINE vertexPoints #-}++-- | Annotation carried by an admitted vertex handle.+vertexData :: Triangulation mode vertex directed undirected face -> VertexId -> vertex+vertexData triangulation (VertexId vertex) =+  boxedUnsafeIndex (triVertexData triangulation) (fromIntegral vertex)+{-# INLINE vertexData #-}++directedEdgeData :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> directed+directedEdgeData triangulation (DirectedEdgeId edge) =+  boxedUnsafeIndex (triDirectedData triangulation) (fromIntegral edge)+{-# INLINE directedEdgeData #-}++undirectedEdgeData :: Triangulation mode vertex directed undirected face -> UndirectedEdgeId -> undirected+undirectedEdgeData triangulation (UndirectedEdgeId edge) =+  boxedUnsafeIndex (triUndirectedData triangulation) (fromIntegral edge)+{-# INLINE undirectedEdgeData #-}++faceData :: Triangulation mode vertex directed undirected face -> FaceId -> face+faceData triangulation (FaceId face) =+  boxedUnsafeIndex (triFaceData triangulation) (fromIntegral face)+{-# INLINE faceData #-}++-- | Replace one vertex annotation without changing geometry or topology.+setVertexData+  :: Triangulation mode vertex directed undirected face+  -> VertexId+  -> vertex+  -> Triangulation mode vertex directed undirected face+setVertexData triangulation (VertexId vertex) payload =+  triangulation{triVertexData = boxedUpdate (fromIntegral vertex) payload (triVertexData triangulation)}++setDirectedEdgeData+  :: Triangulation mode vertex directed undirected face+  -> DirectedEdgeId+  -> directed+  -> Triangulation mode vertex directed undirected face+setDirectedEdgeData triangulation (DirectedEdgeId edge) payload =+  triangulation{triDirectedData = boxedUpdate (fromIntegral edge) payload (triDirectedData triangulation)}++setUndirectedEdgeData+  :: Triangulation mode vertex directed undirected face+  -> UndirectedEdgeId+  -> undirected+  -> Triangulation mode vertex directed undirected face+setUndirectedEdgeData triangulation (UndirectedEdgeId edge) payload =+  triangulation{triUndirectedData = boxedUpdate (fromIntegral edge) payload (triUndirectedData triangulation)}++setFaceData+  :: Triangulation mode vertex directed undirected face+  -> FaceId+  -> face+  -> Triangulation mode vertex directed undirected face+setFaceData triangulation (FaceId face) payload =+  triangulation{triFaceData = boxedUpdate (fromIntegral face) payload (triFaceData triangulation)}++vertexOutEdge :: Triangulation mode vertex directed undirected face -> VertexId -> Maybe DirectedEdgeId+vertexOutEdge triangulation (VertexId vertex) =+  DirectedEdgeId . fromIntegral <$> unpackOptionalIndex (pagedUnsafeIndex (triVertexOut triangulation) (fromIntegral vertex))+{-# INLINE vertexOutEdge #-}++adjacentEdge :: Triangulation mode vertex directed undirected face -> FaceId -> Maybe DirectedEdgeId+adjacentEdge triangulation (FaceId face) =+  DirectedEdgeId . fromIntegral <$> unpackOptionalIndex (pagedUnsafeIndex (triFaceEdge triangulation) (fromIntegral face))+{-# INLINE adjacentEdge #-}++-- | Origin vertex of an admitted directed edge.+origin :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> VertexId+origin triangulation (DirectedEdgeId edge) =+  VertexId (pagedUnsafeIndex (triHalfTopology triangulation) (4 * fromIntegral edge))+{-# INLINE origin #-}++-- | Destination vertex of an admitted directed edge.+destination :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> VertexId+destination triangulation = origin triangulation . reverseEdge+{-# INLINE destination #-}++next :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> DirectedEdgeId+next triangulation (DirectedEdgeId edge) =+  DirectedEdgeId (pagedUnsafeIndex (triHalfTopology triangulation) (4 * fromIntegral edge + 1))+{-# INLINE next #-}++previous :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> DirectedEdgeId+previous triangulation (DirectedEdgeId edge) =+  DirectedEdgeId (pagedUnsafeIndex (triHalfTopology triangulation) (4 * fromIntegral edge + 2))+{-# INLINE previous #-}++-- | Face on the left of an admitted directed edge.+incidentFace :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> FaceId+incidentFace triangulation (DirectedEdgeId edge) =+  FaceId (pagedUnsafeIndex (triHalfTopology triangulation) (4 * fromIntegral edge + 3))+{-# INLINE incidentFace #-}++isOuterDirectedEdge :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> Bool+isOuterDirectedEdge triangulation edge = incidentFace triangulation edge == outerFace+{-# INLINE isOuterDirectedEdge #-}++-- | Whether either orientation is incident to the outer face.+isBoundaryEdge :: Triangulation mode vertex directed undirected face -> UndirectedEdgeId -> Bool+isBoundaryEdge triangulation edge =+  let (forward, backward) = directedPair edge+   in isOuterDirectedEdge triangulation forward || isOuterDirectedEdge triangulation backward+{-# INLINE isBoundaryEdge #-}++-- | Whether the edge belongs to the constrained-edge section.+isConstraintEdge :: Triangulation mode vertex directed undirected face -> UndirectedEdgeId -> Bool+isConstraintEdge triangulation (UndirectedEdgeId edge) =+  pagedUnsafeIndex (triConstraint triangulation) (fromIntegral edge) /= (0 :: Word8)+{-# INLINE isConstraintEdge #-}++numConstraints :: Triangulation mode vertex directed undirected face -> Int+numConstraints = triConstraintCount+{-# INLINE numConstraints #-}++-- | Endpoints in the normalized orientation.+undirectedEndpoints :: Triangulation mode vertex directed undirected face -> UndirectedEdgeId -> (VertexId, VertexId)+undirectedEndpoints triangulation edge =+  let forward = normalizedDirected edge+   in (origin triangulation forward, destination triangulation forward)+{-# INLINE undirectedEndpoints #-}++-- | Boundary cycle of a face in traversal order.+faceDirectedEdges :: Triangulation mode vertex directed undirected face -> FaceId -> [DirectedEdgeId]+faceDirectedEdges triangulation face =+  case adjacentEdge triangulation face of+    Nothing -> []+    Just start -> circularWalk triangulation start (next triangulation)+{-# INLINE faceDirectedEdges #-}++-- | Origins along a face boundary cycle, in traversal order.+faceVertices :: Triangulation mode vertex directed undirected face -> FaceId -> [VertexId]+faceVertices triangulation = map (origin triangulation) . faceDirectedEdges triangulation+{-# INLINE faceVertices #-}++innerFaceDirectedEdges :: Triangulation mode vertex directed undirected face -> FaceId -> Maybe (DirectedEdgeId, DirectedEdgeId, DirectedEdgeId)+innerFaceDirectedEdges triangulation face+  | face == outerFace = Nothing+  | otherwise = do+      e0 <- adjacentEdge triangulation face+      let !e1 = next triangulation e0+          !e2 = next triangulation e1+      if next triangulation e2 == e0+        then Just (e0, e1, e2)+        else Nothing+{-# INLINE innerFaceDirectedEdges #-}++innerFaceVertices :: Triangulation mode vertex directed undirected face -> FaceId -> Maybe (VertexId, VertexId, VertexId)+innerFaceVertices triangulation face = do+  (e0, e1, e2) <- innerFaceDirectedEdges triangulation face+  pure (origin triangulation e0, origin triangulation e1, origin triangulation e2)+{-# INLINE innerFaceVertices #-}++innerFaceVertexTriples+  :: Triangulation mode vertex directed undirected face+  -> V.Vector (VertexId, VertexId, VertexId)+innerFaceVertexTriples triangulation =+  V.generate (numInnerFaces triangulation) $ \innerFaceIndex ->+    let !faceIndex = innerFaceIndex + 1+        !firstEdge =+          DirectedEdgeId+            (pagedUnsafeIndex (triFaceEdge triangulation) faceIndex)+        !secondEdge = next triangulation firstEdge+        !thirdEdge = next triangulation secondEdge+     in ( origin triangulation firstEdge+        , origin triangulation secondEdge+        , origin triangulation thirdEdge+        )+{-# INLINE innerFaceVertexTriples #-}++-- | Counter-clockwise ring of directed edges originating at a vertex.+vertexOutgoingEdges :: Triangulation mode vertex directed undirected face -> VertexId -> [DirectedEdgeId]+vertexOutgoingEdges triangulation vertex =+  case vertexOutEdge triangulation vertex of+    Nothing -> []+    Just start -> circularWalk triangulation start (counterClockwise triangulation)+{-# INLINE vertexOutgoingEdges #-}++clockwise :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> DirectedEdgeId+clockwise triangulation edge = next triangulation (reverseEdge edge)+{-# INLINE clockwise #-}++counterClockwise :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> DirectedEdgeId+counterClockwise triangulation edge = reverseEdge (previous triangulation edge)+{-# INLINE counterClockwise #-}++foldFaceDirectedEdges'+  :: Triangulation mode vertex directed undirected face -> FaceId+  -> (a -> DirectedEdgeId -> a)+  -> a+  -> a+foldFaceDirectedEdges' triangulation face step initial =+  case adjacentEdge triangulation face of+    Nothing -> initial+    Just start -> circularFold triangulation start (next triangulation) step initial+{-# INLINE foldFaceDirectedEdges' #-}++foldVertexOutgoingEdges'+  :: Triangulation mode vertex directed undirected face -> VertexId+  -> (a -> DirectedEdgeId -> a)+  -> a+  -> a+foldVertexOutgoingEdges' triangulation vertex step initial =+  case vertexOutEdge triangulation vertex of+    Nothing -> initial+    Just start -> circularFold triangulation start (counterClockwise triangulation) step initial+{-# INLINE foldVertexOutgoingEdges' #-}++-- Constraint bytes are intentionally reported separately by the CDT layer.+topologyIndexBytes :: Triangulation mode vertex directed undirected face -> Integer+topologyIndexBytes triangulation =+  4 * toInteger+    ( pagedLength (triVertexOut triangulation)+        + pagedLength (triHalfTopology triangulation)+        + pagedLength (triFaceEdge triangulation)+    )++geometryTopologyBytes :: Triangulation mode vertex directed undirected face -> Integer+geometryTopologyBytes triangulation =+  2 * toInteger scalarByteSize * toInteger (numVertices triangulation)+    + topologyIndexBytes triangulation++-- | The cycle reached from an edge by repeated advance, in visit order.+--+-- Emitted forwards. Consing in reverse and reversing at the end is the right+-- shape for a strict accumulator, and the wrong one for a producer: it built+-- the ring twice and handed back a list no consumer could fuse with. The+-- guard bound is on the steps taken, which is what it was before — the two+-- forms stop after the same edges.+circularWalk+  :: Triangulation mode vertex directed undirected face -> DirectedEdgeId+  -> (DirectedEdgeId -> DirectedEdgeId)+  -> [DirectedEdgeId]+circularWalk triangulation start advance =+  build+    ( \link stop ->+        let go !remaining !current !visited+              | remaining <= 0 = stop+              | visited && current == start = stop+              | otherwise = link current (go (remaining - 1) (advance current) True)+         in go (numDirectedEdges triangulation + 1) start False+    )+{-# INLINE circularWalk #-}++circularFold+  :: Triangulation mode vertex directed undirected face -> DirectedEdgeId+  -> (DirectedEdgeId -> DirectedEdgeId)+  -> (a -> DirectedEdgeId -> a)+  -> a+  -> a+circularFold triangulation start advance step =+  go (numDirectedEdges triangulation + 1) start False+ where+  go !remaining !current !visited !accumulator+    | remaining <= 0 = accumulator+    | visited && current == start = accumulator+    | otherwise =+        let !nextAccumulator = step accumulator current+         in go (remaining - 1) (advance current) True nextAccumulator+{-# INLINE circularFold #-}
+ src-dcel/Moonlight/Triangulation/FloodFillIterator.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE FlexibleInstances #-}++module Moonlight.Triangulation.FloodFillIterator+  ( DistanceMetric (..)+  , CircleMetric+  , CircleMetricError (..)+  , RectangleMetric+  , RectangleMetricError (..)+  , circleMetric+  , rectangleMetric+  , edgesInShape+  , verticesInShape+  , edgesInCircle+  , verticesInCircle+  , edgesInRectangle+  , verticesInRectangle+  , floodFillFaces+  , outerFaceFloodFill+  , facesAtEvenBarrierDepth+  ) where++import qualified Data.IntSet as IntSet+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (undirectedEdges)+import Moonlight.Triangulation.Math+import Moonlight.Triangulation.PointLocation+import Moonlight.Triangulation.Types+class DistanceMetric metric where+  metricContainsPoint :: metric -> Point -> Bool+  metricIntersectsEdge :: metric -> Point -> Point -> Bool+  metricStartPoint :: metric -> QueryPoint++data CircleMetric = CircleMetric !(QueryPoint) !Double+  deriving stock (Eq, Ord, Show)++data CircleMetricError+  = InvalidCircleCenter !PointValidationError+  | NonFiniteRadiusSquared !NonFiniteValue+  | NegativeRadiusSquared !Double+  deriving stock (Eq, Ord, Show)++data RectangleMetric = RectangleMetric !(QueryPoint) !(QueryPoint) !(QueryPoint)+  deriving stock (Eq, Ord, Show)++data RectangleMetricError+  = InvalidRectangleLower !PointValidationError+  | InvalidRectangleUpper !PointValidationError+  | InvalidRectangleCenter !PointValidationError+  deriving stock (Eq, Ord, Show)++-- | A circle metric, or why the radius is unusable.+circleMetric :: Point -> Double -> Either CircleMetricError CircleMetric+circleMetric center radiusSquared = do+  queryCenter <- either (Left . InvalidCircleCenter) Right (mkQueryPoint center)+  case classifyNonFinite radiusSquared of+    Just nonFinite -> Left (NonFiniteRadiusSquared nonFinite)+    Nothing+      | radiusSquared < 0 -> Left (NegativeRadiusSquared radiusSquared)+      | otherwise -> Right (CircleMetric queryCenter radiusSquared)++-- | An axis-aligned rectangle metric, or why the corners are unusable.+rectangleMetric :: Point -> Point -> Either RectangleMetricError RectangleMetric+rectangleMetric lower@(Point lowerX lowerY) upper@(Point upperX upperY) = do+  queryLower <- either (Left . InvalidRectangleLower) Right (mkQueryPoint lower)+  queryUpper <- either (Left . InvalidRectangleUpper) Right (mkQueryPoint upper)+  queryCenter <-+    either+      (Left . InvalidRectangleCenter)+      Right+      (mkQueryPoint (Point ((lowerX + upperX) * 0.5) ((lowerY + upperY) * 0.5)))+  Right (RectangleMetric queryLower queryUpper queryCenter)++instance DistanceMetric CircleMetric where+  metricContainsPoint (CircleMetric center radiusSquared) point =+    squaredDistanceWide (queryPointValue center) point <= radiusSquared+  metricIntersectsEdge (CircleMetric center radiusSquared) from to =+    segmentDistanceSquaredWide from to (queryPointValue center) <= radiusSquared+  metricStartPoint (CircleMetric center _) = center++instance DistanceMetric RectangleMetric where+  metricContainsPoint (RectangleMetric lower upper _) (Point x y) =+    lowerX <= upperX && lowerY <= upperY && x >= lowerX && x <= upperX && y >= lowerY && y <= upperY+   where+    Point lowerX lowerY = queryPointValue lower+    Point upperX upperY = queryPointValue upper+  metricIntersectsEdge rectangle from to =+    metricContainsPoint rectangle from+      || metricContainsPoint rectangle to+      || segmentRectangleIntersection rectangle from to+  metricStartPoint (RectangleMetric _ _ center) = center++-- | Edges meeting a circle.+edgesInCircle :: Triangulation mode vertex directed undirected face -> Point -> Double -> Either CircleMetricError [UndirectedEdgeId]+edgesInCircle triangulation center radiusSquared =+  edgesInShape triangulation <$> circleMetric center radiusSquared++-- | Vertices inside a circle.+verticesInCircle :: Triangulation mode vertex directed undirected face -> Point -> Double -> Either CircleMetricError [VertexId]+verticesInCircle triangulation center radiusSquared =+  verticesInShape triangulation <$> circleMetric center radiusSquared++-- | Edges meeting an axis-aligned rectangle.+edgesInRectangle :: Triangulation mode vertex directed undirected face -> Point -> Point -> Either RectangleMetricError [UndirectedEdgeId]+edgesInRectangle triangulation lower upper = edgesInShape triangulation <$> rectangleMetric lower upper++-- | Vertices inside an axis-aligned rectangle.+verticesInRectangle :: Triangulation mode vertex directed undirected face -> Point -> Point -> Either RectangleMetricError [VertexId]+verticesInRectangle triangulation lower upper = verticesInShape triangulation <$> rectangleMetric lower upper++-- | Edges meeting any metric shape.+edgesInShape :: DistanceMetric metric => Triangulation mode vertex directed undirected face -> metric -> [UndirectedEdgeId]+edgesInShape triangulation metric+  | numVertices triangulation <= 1 = []+  | numInnerFaces triangulation == 0 =+      [edge | edge <- undirectedEdges triangulation, edgeInside edge]+  | otherwise =+      let starts = shapeStartFaces triangulation metric+          (_, accepted) = floodFillFacesWithEdges triangulation starts edgeInside+       in map (UndirectedEdgeId . fromIntegral) (IntSet.toAscList accepted)+ where+  edgeInside edge =+    let (fromVertex, toVertex) = undirectedEndpoints triangulation edge+     in metricIntersectsEdge metric (vertexPoint triangulation fromVertex) (vertexPoint triangulation toVertex)++-- | Vertices inside any metric shape.+verticesInShape :: DistanceMetric metric => Triangulation mode vertex directed undirected face -> metric -> [VertexId]+verticesInShape triangulation metric =+  [ vertex+  | vertex <- candidateVertices+  , metricContainsPoint metric (vertexPoint triangulation vertex)+  ]+ where+  edges = edgesInShape triangulation metric+  set = foldl' addEndpoints IntSet.empty edges+  addEndpoints acc edge =+    let (VertexId from, VertexId to) = undirectedEndpoints triangulation edge+     in IntSet.insert (fromIntegral from) (IntSet.insert (fromIntegral to) acc)+  candidateVertices+    | numVertices triangulation == 1 = [VertexId 0]+    | otherwise = map (VertexId . fromIntegral) (IntSet.toAscList set)++floodFillFaces+  :: Triangulation mode vertex directed undirected face -> [FaceId]+  -> (UndirectedEdgeId -> Bool)+  -> [FaceId]+floodFillFaces triangulation starts canCross =+  fst (floodFillFacesWithEdges triangulation starts canCross)++floodFillFacesWithEdges+  :: Triangulation mode vertex directed undirected face -> [FaceId]+  -> (UndirectedEdgeId -> Bool)+  -> ([FaceId], IntSet.IntSet)+floodFillFacesWithEdges triangulation starts canCross =+  let (faces, accepted, _) = go initialStack initialVisited IntSet.empty IntSet.empty []+   in (reverse faces, accepted)+ where+  valid face@(FaceId value) = face /= outerFace && fromIntegral value < numFaces triangulation+  (initialStack, initialVisited) = foldl' enqueueStart ([], IntSet.empty) starts++  enqueueStart state face+    | valid face = enqueue face state+    | otherwise = state++  go [] _ accepted rejected result = (result, accepted, rejected)+  go (face : stack) visited accepted rejected result =+    let (stack', visited', accepted', rejected') =+          foldl' expand (stack, visited, accepted, rejected) (faceDirectedEdges triangulation face)+     in go stack' visited' accepted' rejected' (face : result)++  expand (stack, visited, accepted, rejected) edge =+    let undirected@(UndirectedEdgeId raw) = asUndirected edge+        edgeIndex = fromIntegral raw+        adjacent = incidentFace triangulation (reverseEdge edge)+        edgeAdmission+          | IntSet.member edgeIndex accepted = (True, accepted, rejected)+          | IntSet.member edgeIndex rejected = (False, accepted, rejected)+          | canCross undirected = (True, IntSet.insert edgeIndex accepted, rejected)+          | otherwise = (False, accepted, IntSet.insert edgeIndex rejected)+        (crosses, accepted', rejected') = edgeAdmission+        (stack', visited') =+          if crosses && valid adjacent+            then enqueue adjacent (stack, visited)+            else (stack, visited)+     in (stack', visited', accepted', rejected')++  enqueue face@(FaceId value) (stack, visited)+    | IntSet.member index visited = (stack, visited)+    | otherwise = (face : stack, IntSet.insert index visited)+   where+    index = fromIntegral value++-- | Inner faces separated from the outer face by an even minimum number of+-- barriers. A 0–1 BFS floods freely within one depth before crossing a barrier,+-- so a free-ended barrier can be walked around at depth zero while nested+-- closed barriers alternate outside and inside.+facesAtEvenBarrierDepth+  :: Triangulation mode vertex directed undirected face+  -> (UndirectedEdgeId -> Bool)+  -> [FaceId]+facesAtEvenBarrierDepth triangulation isBarrier =+  concat (evenLayers (barrierDepthLayers triangulation isBarrier))+ where+  evenLayers :: [[FaceId]] -> [[FaceId]]+  evenLayers (outsideLayer : _insideLayer : deeper) =+    outsideLayer : evenLayers deeper+  evenLayers shallow = shallow++barrierDepthLayers+  :: Triangulation mode vertex directed undirected face+  -> (UndirectedEdgeId -> Bool)+  -> [[FaceId]]+barrierDepthLayers triangulation isBarrier =+  map (filter (/= outerFace)) (layers IntSet.empty [outerFace])+ where+  known (FaceId value) = fromIntegral value < numFaces triangulation+  key :: FaceId -> Int+  key (FaceId value) = fromIntegral value++  layers visited frontier = case flood visited [] frontier of+    ([], _) -> []+    (layer, visited') -> layer : layers visited' (concatMap (neighbours isBarrier) layer)++  flood visited acc [] = (reverse acc, visited)+  flood visited acc (face : rest)+    | not (known face) || IntSet.member (key face) visited = flood visited acc rest+    | otherwise =+        flood+          (IntSet.insert (key face) visited)+          (face : acc)+          (neighbours (not . isBarrier) face <> rest)++  neighbours admit face =+    [ incidentFace triangulation (reverseEdge edge)+    | edge <- faceDirectedEdges triangulation face+    , admit (asUndirected edge)+    ]++-- | Faces reachable from the outer face without crossing a barrier edge.+outerFaceFloodFill :: Triangulation mode vertex directed undirected face -> (UndirectedEdgeId -> Bool) -> [FaceId]+outerFaceFloodFill triangulation canCross = floodFillFaces triangulation starts canCross+ where+  starts =+    [ face+    | outerEdge <- faceDirectedEdges triangulation outerFace+    , let edge = asUndirected outerEdge+    , canCross edge+    , let face = incidentFace triangulation (reverseEdge outerEdge)+    , face /= outerFace+    ]++-- | The faces a shape's start point lands in.+shapeStartFaces :: DistanceMetric metric => Triangulation mode vertex directed undirected face -> metric -> [FaceId]+shapeStartFaces triangulation metric =+  case locatePoint triangulation (metricStartPoint metric) of+    InFace face -> [face]+    OnEdge edge -> filter (/= outerFace) [incidentFace triangulation edge, incidentFace triangulation (reverseEdge edge)]+    OnVertex vertex ->+      intSetToFaces+        (foldl' (\set edge -> let FaceId value = incidentFace triangulation edge in if value == 0 then set else IntSet.insert (fromIntegral value) set) IntSet.empty (vertexOutgoingEdges triangulation vertex))+    OutsideConvexHull _ ->+      [ incidentFace triangulation (reverseEdge edge)+      | edge <- faceDirectedEdges triangulation outerFace+      , let from = vertexPoint triangulation (origin triangulation edge)+      , let to = vertexPoint triangulation (destination triangulation edge)+      , metricIntersectsEdge metric from to+      , incidentFace triangulation (reverseEdge edge) /= outerFace+      ]+    EmptyTriangulation -> []+ where+  intSetToFaces = map (FaceId . fromIntegral) . IntSet.toAscList++segmentRectangleIntersection :: RectangleMetric -> Point -> Point -> Bool+segmentRectangleIntersection (RectangleMetric lowerQuery upperQuery _) from to+  | lx > ux || ly > uy = False+  | lower == upper = onClosedSegment from to lower+  | otherwise = any (uncurry (segmentsIntersect from to)) boundaries+ where+  lower@(Point lx ly) = queryPointValue lowerQuery+  upper@(Point ux uy) = queryPointValue upperQuery+  boundaries =+    [ (Point lx ly, Point lx uy)+    , (Point lx uy, Point ux uy)+    , (Point ux uy, Point ux ly)+    , (Point ux ly, Point lx ly)+    ]
+ src-dcel/Moonlight/Triangulation/Handles.hs view
@@ -0,0 +1,11 @@+-- | The handle surface as one import: identifiers, their dynamic views, and+-- the iterator family.+module Moonlight.Triangulation.Handles+  ( module Moonlight.Triangulation.Handles.HandleDefs+  , module Moonlight.Triangulation.Handles.Dynamic+  , module Moonlight.Triangulation.Handles.Iterators+  ) where++import Moonlight.Triangulation.Handles.Dynamic+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Handles.Iterators
+ src-dcel/Moonlight/Triangulation/Handles/Dynamic.hs view
@@ -0,0 +1,380 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RoleAnnotations #-}++module Moonlight.Triangulation.Handles.Dynamic+  ( InnerTag+  , PossiblyOuterTag+  , FixedFaceHandle+  , asPossiblyOuter+  , fixedFaceId+  , VertexHandle+  , DirectedEdgeHandle+  , UndirectedEdgeHandle+  , FaceHandle+  , vertexHandle+  , directedEdgeHandle+  , undirectedEdgeHandle+  , faceHandle+  , innerFaceHandle+  , outerFaceHandle+  , fixVertex+  , fixDirectedEdge+  , fixUndirectedEdge+  , fixFace+  , vertexHandleData+  , vertexHandlePosition+  , vertexHandleOutEdge+  , vertexHandleOutEdges+  , directedEdgeDataH+  , directedEdgeFrom+  , directedEdgeTo+  , directedEdgeVertices+  , directedEdgePositions+  , directedEdgeReverse+  , directedEdgeNext+  , directedEdgePrevious+  , directedEdgeClockwise+  , directedEdgeCounterClockwise+  , directedEdgeFace+  , directedEdgeAsUndirected+  , directedEdgeIsOuter+  , directedEdgeSideQuery+  , directedEdgeOppositeVertex+  , directedEdgeOppositePosition+  , directedEdgeProjectionFactor+  , directedEdgeNearestPoint+  , undirectedEdgeDataH+  , undirectedEdgeAsDirected+  , undirectedEdgeVertices+  , undirectedEdgeIsConstraint+  , undirectedEdgeIsBoundary+  , faceDataH+  , faceIsOuter+  , faceAsInner+  , faceAdjacentEdge+  , faceAdjacentEdges+  , innerFaceVertices+  , innerFaceCircumcenter+  , innerFacePositions+  , innerFaceBarycentric+  ) where++import Moonlight.Triangulation.Dcel qualified as Dcel+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.LineSideInfo (LineSideInfo)+import Moonlight.Triangulation.Math qualified as Math+import Moonlight.Triangulation.Types++-- | A face handle that is statically known not to denote the outer face.+data InnerTag++-- | A face handle that may denote the unique outer face.+data PossiblyOuterTag++type role FixedFaceHandle nominal+newtype FixedFaceHandle tag = FixedFaceHandle { unFixedFaceHandle :: FaceId }+  deriving stock (Show)+  deriving newtype (Eq, Ord)++asPossiblyOuter :: FixedFaceHandle InnerTag -> FixedFaceHandle PossiblyOuterTag+asPossiblyOuter (FixedFaceHandle face) = FixedFaceHandle face+{-# INLINE asPossiblyOuter #-}++fixedFaceId :: FixedFaceHandle tag -> FaceId+fixedFaceId (FixedFaceHandle face) = face+{-# INLINE fixedFaceId #-}++data VertexHandle mode vertex directed undirected face = VertexHandle+  !(Triangulation mode vertex directed undirected face)+  !VertexId++data DirectedEdgeHandle mode vertex directed undirected face = DirectedEdgeHandle+  !(Triangulation mode vertex directed undirected face)+  !DirectedEdgeId++data UndirectedEdgeHandle mode vertex directed undirected face = UndirectedEdgeHandle+  !(Triangulation mode vertex directed undirected face)+  !UndirectedEdgeId++data FaceHandle tag mode vertex directed undirected face = FaceHandle+  !(Triangulation mode vertex directed undirected face)+  !(FixedFaceHandle tag)++instance Show (VertexHandle mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixVertex++instance Show (DirectedEdgeHandle mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixDirectedEdge++instance Show (UndirectedEdgeHandle mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixUndirectedEdge++instance Show (FaceHandle tag mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixFace++vertexHandle+  :: Triangulation mode vertex directed undirected face+  -> VertexId+  -> Maybe (VertexHandle mode vertex directed undirected face)+vertexHandle triangulation vertex@(VertexId raw)+  | fromIntegral raw < Dcel.numVertices triangulation = Just (VertexHandle triangulation vertex)+  | otherwise = Nothing++directedEdgeHandle+  :: Triangulation mode vertex directed undirected face+  -> DirectedEdgeId+  -> Maybe (DirectedEdgeHandle mode vertex directed undirected face)+directedEdgeHandle triangulation edge@(DirectedEdgeId raw)+  | fromIntegral raw < Dcel.numDirectedEdges triangulation = Just (DirectedEdgeHandle triangulation edge)+  | otherwise = Nothing++undirectedEdgeHandle+  :: Triangulation mode vertex directed undirected face+  -> UndirectedEdgeId+  -> Maybe (UndirectedEdgeHandle mode vertex directed undirected face)+undirectedEdgeHandle triangulation edge@(UndirectedEdgeId raw)+  | fromIntegral raw < Dcel.numUndirectedEdges triangulation = Just (UndirectedEdgeHandle triangulation edge)+  | otherwise = Nothing++faceHandle+  :: Triangulation mode vertex directed undirected face+  -> FaceId+  -> Maybe (FaceHandle PossiblyOuterTag mode vertex directed undirected face)+faceHandle triangulation face@(FaceId raw)+  | fromIntegral raw < Dcel.numFaces triangulation = Just (FaceHandle triangulation (FixedFaceHandle face))+  | otherwise = Nothing++innerFaceHandle+  :: Triangulation mode vertex directed undirected face+  -> FaceId+  -> Maybe (FaceHandle InnerTag mode vertex directed undirected face)+innerFaceHandle triangulation face+  | face == Dcel.outerFace = Nothing+  | otherwise = do+      FaceHandle _ (FixedFaceHandle valid) <- faceHandle triangulation face+      pure (FaceHandle triangulation (FixedFaceHandle valid))++outerFaceHandle+  :: Triangulation mode vertex directed undirected face+  -> FaceHandle PossiblyOuterTag mode vertex directed undirected face+outerFaceHandle triangulation = FaceHandle triangulation (FixedFaceHandle Dcel.outerFace)++fixVertex :: VertexHandle mode vertex directed undirected face -> VertexId+fixVertex (VertexHandle _ vertex) = vertex+{-# INLINE fixVertex #-}++fixDirectedEdge :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeId+fixDirectedEdge (DirectedEdgeHandle _ edge) = edge+{-# INLINE fixDirectedEdge #-}++fixUndirectedEdge :: UndirectedEdgeHandle mode vertex directed undirected face -> UndirectedEdgeId+fixUndirectedEdge (UndirectedEdgeHandle _ edge) = edge+{-# INLINE fixUndirectedEdge #-}++fixFace :: FaceHandle tag mode vertex directed undirected face -> FixedFaceHandle tag+fixFace (FaceHandle _ face) = face+{-# INLINE fixFace #-}++vertexHandleData :: VertexHandle mode vertex directed undirected face -> vertex+vertexHandleData (VertexHandle triangulation vertex) = Dcel.vertexData triangulation vertex+{-# INLINE vertexHandleData #-}++vertexHandlePosition+  :: VertexHandle mode vertex directed undirected face+  -> Point+vertexHandlePosition (VertexHandle triangulation vertex) = (Dcel.vertexPoint triangulation vertex)+{-# INLINE vertexHandlePosition #-}++vertexHandleOutEdge+  :: VertexHandle mode vertex directed undirected face+  -> Maybe (DirectedEdgeHandle mode vertex directed undirected face)+vertexHandleOutEdge (VertexHandle triangulation vertex) = DirectedEdgeHandle triangulation <$> Dcel.vertexOutEdge triangulation vertex++vertexHandleOutEdges+  :: VertexHandle mode vertex directed undirected face+  -> [DirectedEdgeHandle mode vertex directed undirected face]+vertexHandleOutEdges (VertexHandle triangulation vertex) = map (DirectedEdgeHandle triangulation) (Dcel.vertexOutgoingEdges triangulation vertex)++directedEdgeDataH :: DirectedEdgeHandle mode vertex directed undirected face -> directed+directedEdgeDataH (DirectedEdgeHandle triangulation edge) = Dcel.directedEdgeData triangulation edge+{-# INLINE directedEdgeDataH #-}++directedEdgeFrom :: DirectedEdgeHandle mode vertex directed undirected face -> VertexHandle mode vertex directed undirected face+directedEdgeFrom (DirectedEdgeHandle triangulation edge) = VertexHandle triangulation (Dcel.origin triangulation edge)+{-# INLINE directedEdgeFrom #-}++directedEdgeTo :: DirectedEdgeHandle mode vertex directed undirected face -> VertexHandle mode vertex directed undirected face+directedEdgeTo (DirectedEdgeHandle triangulation edge) = VertexHandle triangulation (Dcel.destination triangulation edge)+{-# INLINE directedEdgeTo #-}++directedEdgeVertices+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> (VertexHandle mode vertex directed undirected face, VertexHandle mode vertex directed undirected face)+directedEdgeVertices edge = (directedEdgeFrom edge, directedEdgeTo edge)++directedEdgePositions+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> (Point, Point)+directedEdgePositions edge = (vertexHandlePosition (directedEdgeFrom edge), vertexHandlePosition (directedEdgeTo edge))+{-# INLINE directedEdgePositions #-}++directedEdgeReverse :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeHandle mode vertex directed undirected face+directedEdgeReverse (DirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (reverseEdge edge)+{-# INLINE directedEdgeReverse #-}++directedEdgeNext :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeHandle mode vertex directed undirected face+directedEdgeNext (DirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (Dcel.next triangulation edge)+{-# INLINE directedEdgeNext #-}++directedEdgePrevious :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeHandle mode vertex directed undirected face+directedEdgePrevious (DirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (Dcel.previous triangulation edge)+{-# INLINE directedEdgePrevious #-}++directedEdgeClockwise :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeHandle mode vertex directed undirected face+directedEdgeClockwise (DirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (Dcel.clockwise triangulation edge)+{-# INLINE directedEdgeClockwise #-}++directedEdgeCounterClockwise :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeHandle mode vertex directed undirected face+directedEdgeCounterClockwise (DirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (Dcel.counterClockwise triangulation edge)+{-# INLINE directedEdgeCounterClockwise #-}++directedEdgeFace+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> FaceHandle PossiblyOuterTag mode vertex directed undirected face+directedEdgeFace (DirectedEdgeHandle triangulation edge) = FaceHandle triangulation (FixedFaceHandle (Dcel.incidentFace triangulation edge))++directedEdgeAsUndirected+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> UndirectedEdgeHandle mode vertex directed undirected face+directedEdgeAsUndirected (DirectedEdgeHandle triangulation edge) = UndirectedEdgeHandle triangulation (asUndirected edge)++directedEdgeIsOuter :: DirectedEdgeHandle mode vertex directed undirected face -> Bool+directedEdgeIsOuter = faceIsOuter . directedEdgeFace++directedEdgeSideQuery+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> Point+  -> LineSideInfo+directedEdgeSideQuery edge query =+  let (from, to) = directedEdgePositions edge+   in Math.sideQuery from to query++undirectedEdgeDataH :: UndirectedEdgeHandle mode vertex directed undirected face -> undirected+undirectedEdgeDataH (UndirectedEdgeHandle triangulation edge) = Dcel.undirectedEdgeData triangulation edge+{-# INLINE undirectedEdgeDataH #-}++undirectedEdgeAsDirected+  :: UndirectedEdgeHandle mode vertex directed undirected face+  -> DirectedEdgeHandle mode vertex directed undirected face+undirectedEdgeAsDirected (UndirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (normalizedDirected edge)++undirectedEdgeVertices+  :: UndirectedEdgeHandle mode vertex directed undirected face+  -> (VertexHandle mode vertex directed undirected face, VertexHandle mode vertex directed undirected face)+undirectedEdgeVertices = directedEdgeVertices . undirectedEdgeAsDirected++faceDataH :: FaceHandle tag mode vertex directed undirected face -> face+faceDataH (FaceHandle triangulation (FixedFaceHandle face)) = Dcel.faceData triangulation face+{-# INLINE faceDataH #-}++faceIsOuter :: FaceHandle tag mode vertex directed undirected face -> Bool+faceIsOuter (FaceHandle _ (FixedFaceHandle face)) = face == Dcel.outerFace+{-# INLINE faceIsOuter #-}++faceAsInner+  :: FaceHandle PossiblyOuterTag mode vertex directed undirected face+  -> Maybe (FaceHandle InnerTag mode vertex directed undirected face)+faceAsInner handle@(FaceHandle triangulation (FixedFaceHandle face))+  | faceIsOuter handle = Nothing+  | otherwise = Just (FaceHandle triangulation (FixedFaceHandle face))++faceAdjacentEdge+  :: FaceHandle tag mode vertex directed undirected face+  -> Maybe (DirectedEdgeHandle mode vertex directed undirected face)+faceAdjacentEdge (FaceHandle triangulation (FixedFaceHandle face)) = DirectedEdgeHandle triangulation <$> Dcel.adjacentEdge triangulation face++faceAdjacentEdges+  :: FaceHandle tag mode vertex directed undirected face+  -> [DirectedEdgeHandle mode vertex directed undirected face]+faceAdjacentEdges (FaceHandle triangulation (FixedFaceHandle face)) = map (DirectedEdgeHandle triangulation) (Dcel.faceDirectedEdges triangulation face)++innerFaceVertices+  :: FaceHandle InnerTag mode vertex directed undirected face+  -> Maybe+       ( VertexHandle mode vertex directed undirected face+       , VertexHandle mode vertex directed undirected face+       , VertexHandle mode vertex directed undirected face+       )+innerFaceVertices (FaceHandle triangulation (FixedFaceHandle face)) =+  (\(a, b, c) -> (VertexHandle triangulation a, VertexHandle triangulation b, VertexHandle triangulation c))+    <$> Dcel.innerFaceVertices triangulation face++innerFaceCircumcenter+  :: FaceHandle InnerTag mode vertex directed undirected face+  -> Maybe (Point)+innerFaceCircumcenter face = do+  (a, b, c) <- innerFaceVertices face+  Math.circumcenter (vertexHandlePosition a) (vertexHandlePosition b) (vertexHandlePosition c)++directedEdgeOppositeVertex+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> Maybe (VertexHandle mode vertex directed undirected face)+directedEdgeOppositeVertex (DirectedEdgeHandle triangulation edge)+  | Dcel.incidentFace triangulation edge == Dcel.outerFace = Nothing+  | otherwise =+      Just (VertexHandle triangulation (Dcel.destination triangulation (Dcel.next triangulation edge)))++directedEdgeOppositePosition+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> Maybe (Point)+directedEdgeOppositePosition = fmap vertexHandlePosition . directedEdgeOppositeVertex+{-# INLINE directedEdgeOppositePosition #-}++directedEdgeProjectionFactor+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> Point+  -> Double+directedEdgeProjectionFactor edge query =+  let (from, to) = directedEdgePositions edge+   in Math.projectionFactor from to query++directedEdgeNearestPoint+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> Point+  -> Point+directedEdgeNearestPoint edge query =+  let (from@(Point ax ay), to@(Point bx by)) = directedEdgePositions edge+      factor = max 0 (min 1 (Math.projectionFactor from to query))+   in Point (ax + factor * (bx - ax)) (ay + factor * (by - ay))++undirectedEdgeIsConstraint+  :: UndirectedEdgeHandle mode vertex directed undirected face+  -> Bool+undirectedEdgeIsConstraint (UndirectedEdgeHandle triangulation edge) =+  Dcel.isConstraintEdge triangulation edge++undirectedEdgeIsBoundary+  :: UndirectedEdgeHandle mode vertex directed undirected face+  -> Bool+undirectedEdgeIsBoundary (UndirectedEdgeHandle triangulation edge) =+  Dcel.isBoundaryEdge triangulation edge++innerFacePositions+  :: FaceHandle InnerTag mode vertex directed undirected face+  -> Maybe (Point, Point, Point)+innerFacePositions face = do+  (a, b, c) <- innerFaceVertices face+  pure (vertexHandlePosition a, vertexHandlePosition b, vertexHandlePosition c)+{-# INLINE innerFacePositions #-}++innerFaceBarycentric+  :: FaceHandle InnerTag mode vertex directed undirected face+  -> Point+  -> Maybe (Double, Double, Double)+innerFaceBarycentric face query = do+  (a, b, c) <- innerFacePositions face+  Math.barycentricCoordinates a b c query
+ src-dcel/Moonlight/Triangulation/Handles/HandleDefs.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | The identifier family and the arithmetic on it: a directed edge's twin is+-- its index complement, so orientation is a bit rather than a lookup.+module Moonlight.Triangulation.Handles.HandleDefs+  ( VertexId (..)+  , FaceId (..)+  , DirectedEdgeId (..)+  , UndirectedEdgeId (..)+  , reverseEdge+  , asUndirected+  , normalizedDirected+  , reversedDirected+  , directedPair+  , isNormalized+  ) where++import Control.DeepSeq (NFData)+import Data.Bits (shiftL, shiftR, xor, (.&.))+import Data.Word (Word32)++-- | Index of a vertex in the immutable DCEL.+newtype VertexId = VertexId { unVertexId :: Word32 }+  deriving stock (Show)+  deriving newtype (Eq, Ord, NFData)++-- | Index of a face in the immutable DCEL; zero denotes the outer face.+newtype FaceId = FaceId { unFaceId :: Word32 }+  deriving stock (Show)+  deriving newtype (Eq, Ord, NFData)++-- | Oriented half-edge index. Twin orientations differ only in the low bit.+newtype DirectedEdgeId = DirectedEdgeId { unDirectedEdgeId :: Word32 }+  deriving stock (Show)+  deriving newtype (Eq, Ord, NFData)++-- | Index of a twin pair, with orientation forgotten.+newtype UndirectedEdgeId = UndirectedEdgeId { unUndirectedEdgeId :: Word32 }+  deriving stock (Show)+  deriving newtype (Eq, Ord, NFData)++-- | Select the opposite orientation of the same undirected edge.+reverseEdge :: DirectedEdgeId -> DirectedEdgeId+reverseEdge (DirectedEdgeId edge) = DirectedEdgeId (edge `xor` 1)+{-# INLINE reverseEdge #-}++-- | Forget a directed edge's orientation.+asUndirected :: DirectedEdgeId -> UndirectedEdgeId+asUndirected (DirectedEdgeId edge) = UndirectedEdgeId (edge `shiftR` 1)+{-# INLINE asUndirected #-}++-- | Select the even-indexed orientation of an undirected edge.+normalizedDirected :: UndirectedEdgeId -> DirectedEdgeId+normalizedDirected (UndirectedEdgeId edge) = DirectedEdgeId (edge `shiftL` 1)+{-# INLINE normalizedDirected #-}++-- | Select the odd-indexed orientation of an undirected edge.+reversedDirected :: UndirectedEdgeId -> DirectedEdgeId+reversedDirected edge = reverseEdge (normalizedDirected edge)+{-# INLINE reversedDirected #-}++-- | Both orientations, normalized first and reversed second.+directedPair :: UndirectedEdgeId -> (DirectedEdgeId, DirectedEdgeId)+directedPair edge = (normalizedDirected edge, reversedDirected edge)+{-# INLINE directedPair #-}++-- | Whether a directed edge is the normalized orientation of its pair.+isNormalized :: DirectedEdgeId -> Bool+isNormalized (DirectedEdgeId edge) = edge .&. 1 == 0+{-# INLINE isNormalized #-}
+ src-dcel/Moonlight/Triangulation/Handles/Iterators.hs view
@@ -0,0 +1,13 @@+-- | The iterator family over a mesh: whole-mesh ranges, incidence fans, the+-- circular walk they are built from, and the hull.+module Moonlight.Triangulation.Handles.Iterators+  ( module Moonlight.Triangulation.Handles.Iterators.CircularIterator+  , module Moonlight.Triangulation.Handles.Iterators.DynamicIterators+  , module Moonlight.Triangulation.Handles.Iterators.FixedIterators+  , module Moonlight.Triangulation.Handles.Iterators.HullIterator+  ) where++import Moonlight.Triangulation.Handles.Iterators.CircularIterator+import Moonlight.Triangulation.Handles.Iterators.DynamicIterators+import Moonlight.Triangulation.Handles.Iterators.FixedIterators+import Moonlight.Triangulation.Handles.Iterators.HullIterator
+ src-dcel/Moonlight/Triangulation/Handles/Iterators/CircularIterator.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE BangPatterns #-}++module Moonlight.Triangulation.Handles.Iterators.CircularIterator+  ( circularList+  , foldCircular'+  ) where++import GHC.Exts (build)++-- | The cycle reached from a start by repeated advance, in visit order.+--+-- Emitted forwards, for the reason 'Moonlight.Triangulation.Dcel.circularWalk'+-- is: accumulating in reverse and reversing at the end builds the ring twice+-- and hands back a list no consumer can fuse with.+circularList :: Eq a => Int -> (a -> a) -> a -> [a]+circularList limit advance start =+  build+    ( \link stop ->+        let go !remaining !current !visited+              | remaining <= 0 = stop+              | visited && current == start = stop+              | otherwise = link current (go (remaining - 1) (advance current) True)+         in go limit start False+    )+{-# INLINE circularList #-}++foldCircular' :: Eq a => Int -> (a -> a) -> a -> (b -> a -> b) -> b -> b+foldCircular' limit advance start step = go limit start False+ where+  go !remaining !current !visited !accumulator+    | remaining <= 0 = accumulator+    | visited && current == start = accumulator+    | otherwise = go (remaining - 1) (advance current) True (step accumulator current)
+ src-dcel/Moonlight/Triangulation/Handles/Iterators/DynamicIterators.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++module Moonlight.Triangulation.Handles.Iterators.DynamicIterators+  ( vertexHandles+  , directedEdgeHandles+  , undirectedEdgeHandles+  , allFaceHandles+  , innerFaceHandles+  , hullEdgeHandles+  , hullVertexHandles+  , foldVertexHandles'+  , foldDirectedEdgeHandles'+  , foldUndirectedEdgeHandles'+  , foldAllFaceHandles'+  , foldInnerFaceHandles'+  , foldHullEdgeHandles'+  , foldHullVertexHandles'+  ) where++import Moonlight.Triangulation.Handles.Dynamic+import Moonlight.Triangulation.Handles.Iterators.FixedIterators qualified as Fixed+import Moonlight.Triangulation.Handles.Iterators.HullIterator qualified as Hull+import Moonlight.Triangulation.Types++-- | Dynamic handles in fixed-index order. The list spine is lazy; use the+-- strict folds below for allocation-free traversal in hot paths.+vertexHandles+  :: Triangulation mode vertex directed undirected face+  -> [VertexHandle mode vertex directed undirected face]+vertexHandles triangulation =+  mapValid (vertexHandle triangulation) (Fixed.vertices triangulation)++directedEdgeHandles+  :: Triangulation mode vertex directed undirected face+  -> [DirectedEdgeHandle mode vertex directed undirected face]+directedEdgeHandles triangulation =+  mapValid (directedEdgeHandle triangulation) (Fixed.directedEdges triangulation)++undirectedEdgeHandles+  :: Triangulation mode vertex directed undirected face+  -> [UndirectedEdgeHandle mode vertex directed undirected face]+undirectedEdgeHandles triangulation =+  mapValid (undirectedEdgeHandle triangulation) (Fixed.undirectedEdges triangulation)++allFaceHandles+  :: Triangulation mode vertex directed undirected face+  -> [FaceHandle PossiblyOuterTag mode vertex directed undirected face]+allFaceHandles triangulation =+  mapValid (faceHandle triangulation) (Fixed.allFaces triangulation)++innerFaceHandles+  :: Triangulation mode vertex directed undirected face+  -> [FaceHandle InnerTag mode vertex directed undirected face]+innerFaceHandles triangulation =+  mapValid (innerFaceHandle triangulation) (Fixed.innerFaces triangulation)++hullEdgeHandles+  :: Triangulation mode vertex directed undirected face+  -> [DirectedEdgeHandle mode vertex directed undirected face]+hullEdgeHandles triangulation =+  mapValid (directedEdgeHandle triangulation) (Hull.hullEdges triangulation)++hullVertexHandles+  :: Triangulation mode vertex directed undirected face+  -> [VertexHandle mode vertex directed undirected face]+hullVertexHandles triangulation =+  map directedEdgeFrom (hullEdgeHandles triangulation)++foldVertexHandles'+  :: Triangulation mode vertex directed undirected face+  -> (accumulator -> VertexHandle mode vertex directed undirected face -> accumulator)+  -> accumulator+  -> accumulator+foldVertexHandles' triangulation step =+  Fixed.foldVertices' triangulation (applyValid (vertexHandle triangulation) step)++foldDirectedEdgeHandles'+  :: Triangulation mode vertex directed undirected face+  -> (accumulator -> DirectedEdgeHandle mode vertex directed undirected face -> accumulator)+  -> accumulator+  -> accumulator+foldDirectedEdgeHandles' triangulation step =+  Fixed.foldDirectedEdges' triangulation (applyValid (directedEdgeHandle triangulation) step)++foldUndirectedEdgeHandles'+  :: Triangulation mode vertex directed undirected face+  -> (accumulator -> UndirectedEdgeHandle mode vertex directed undirected face -> accumulator)+  -> accumulator+  -> accumulator+foldUndirectedEdgeHandles' triangulation step =+  Fixed.foldUndirectedEdges' triangulation (applyValid (undirectedEdgeHandle triangulation) step)++foldAllFaceHandles'+  :: Triangulation mode vertex directed undirected face+  -> (accumulator -> FaceHandle PossiblyOuterTag mode vertex directed undirected face -> accumulator)+  -> accumulator+  -> accumulator+foldAllFaceHandles' triangulation step =+  Fixed.foldAllFaces' triangulation (applyValid (faceHandle triangulation) step)++foldInnerFaceHandles'+  :: Triangulation mode vertex directed undirected face+  -> (accumulator -> FaceHandle InnerTag mode vertex directed undirected face -> accumulator)+  -> accumulator+  -> accumulator+foldInnerFaceHandles' triangulation step =+  Fixed.foldInnerFaces' triangulation (applyValid (innerFaceHandle triangulation) step)++foldHullEdgeHandles'+  :: Triangulation mode vertex directed undirected face+  -> (accumulator -> DirectedEdgeHandle mode vertex directed undirected face -> accumulator)+  -> accumulator+  -> accumulator+foldHullEdgeHandles' triangulation step =+  Hull.foldHullEdges' triangulation (applyValid (directedEdgeHandle triangulation) step)++foldHullVertexHandles'+  :: Triangulation mode vertex directed undirected face+  -> (accumulator -> VertexHandle mode vertex directed undirected face -> accumulator)+  -> accumulator+  -> accumulator+foldHullVertexHandles' triangulation step =+  foldHullEdgeHandles' triangulation (\accumulator edge -> step accumulator (directedEdgeFrom edge))++mapValid :: (fixed -> Maybe dynamic) -> [fixed] -> [dynamic]+mapValid make = foldr collect []+ where+  collect fixed rest = case make fixed of+    Just dynamic -> dynamic : rest+    Nothing -> rest++applyValid+  :: (fixed -> Maybe dynamic)+  -> (accumulator -> dynamic -> accumulator)+  -> accumulator+  -> fixed+  -> accumulator+applyValid make step !accumulator fixed = case make fixed of+  Just dynamic -> step accumulator dynamic+  Nothing -> accumulator
+ src-dcel/Moonlight/Triangulation/Handles/Iterators/FixedIterators.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE BangPatterns #-}++-- | Whole-mesh traversal by identifier range, each range paired with the+-- strict fold that consumes it.+module Moonlight.Triangulation.Handles.Iterators.FixedIterators+  ( vertices+  , directedEdges+  , undirectedEdges+  , allFaces+  , innerFaces+  , foldVertices'+  , foldDirectedEdges'+  , foldUndirectedEdges'+  , foldAllFaces'+  , foldInnerFaces'+  ) where++import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Types++-- | Every vertex identifier, ascending.+--+-- The enumerators are producers, so their bodies have to reach the consumer's+-- module: a fold over one of these should be a loop over an index, not a walk+-- over cons cells built by a call it could not see into.+vertices :: Triangulation mode vertex directed undirected face -> [VertexId]+vertices triangulation = [VertexId (fromIntegral index) | index <- [0 .. numVertices triangulation - 1]]+{-# INLINE vertices #-}++-- | Every directed-edge identifier, ascending.+directedEdges :: Triangulation mode vertex directed undirected face -> [DirectedEdgeId]+directedEdges triangulation = [DirectedEdgeId (fromIntegral index) | index <- [0 .. numDirectedEdges triangulation - 1]]+{-# INLINE directedEdges #-}++-- | Every undirected-edge identifier, ascending.+undirectedEdges :: Triangulation mode vertex directed undirected face -> [UndirectedEdgeId]+undirectedEdges triangulation = [UndirectedEdgeId (fromIntegral index) | index <- [0 .. numUndirectedEdges triangulation - 1]]+{-# INLINE undirectedEdges #-}++-- | Every face identifier, the outer face first.+allFaces :: Triangulation mode vertex directed undirected face -> [FaceId]+allFaces triangulation = [FaceId (fromIntegral index) | index <- [0 .. numFaces triangulation - 1]]+{-# INLINE allFaces #-}++-- | Every face identifier except the outer face.+innerFaces :: Triangulation mode vertex directed undirected face -> [FaceId]+innerFaces triangulation = [FaceId (fromIntegral index) | index <- [1 .. numFaces triangulation - 1]]+{-# INLINE innerFaces #-}++-- | Strict fold over 'vertices'; the rest of the family follows.+foldVertices' :: Triangulation mode vertex directed undirected face -> (a -> VertexId -> a) -> a -> a+foldVertices' triangulation step = foldRange (numVertices triangulation) (VertexId . fromIntegral) step+{-# INLINE foldVertices' #-}++foldDirectedEdges' :: Triangulation mode vertex directed undirected face -> (a -> DirectedEdgeId -> a) -> a -> a+foldDirectedEdges' triangulation step = foldRange (numDirectedEdges triangulation) (DirectedEdgeId . fromIntegral) step+{-# INLINE foldDirectedEdges' #-}++foldUndirectedEdges' :: Triangulation mode vertex directed undirected face -> (a -> UndirectedEdgeId -> a) -> a -> a+foldUndirectedEdges' triangulation step = foldRange (numUndirectedEdges triangulation) (UndirectedEdgeId . fromIntegral) step+{-# INLINE foldUndirectedEdges' #-}++foldAllFaces' :: Triangulation mode vertex directed undirected face -> (a -> FaceId -> a) -> a -> a+foldAllFaces' triangulation step = foldRange (numFaces triangulation) (FaceId . fromIntegral) step+{-# INLINE foldAllFaces' #-}++foldInnerFaces' :: Triangulation mode vertex directed undirected face -> (a -> FaceId -> a) -> a -> a+foldInnerFaces' triangulation step initial = go 1 initial+ where+  !end = numFaces triangulation+  go !index !accumulator+    | index >= end = accumulator+    | otherwise = go (index + 1) (step accumulator (FaceId (fromIntegral index)))+{-# INLINE foldInnerFaces' #-}++foldRange :: Int -> (Int -> b) -> (a -> b -> a) -> a -> a+foldRange end make step = go 0+ where+  go !index !accumulator+    | index >= end = accumulator+    | otherwise = go (index + 1) (step accumulator (make index))+{-# INLINE foldRange #-}
+ src-dcel/Moonlight/Triangulation/Handles/Iterators/HullIterator.hs view
@@ -0,0 +1,29 @@+-- | The convex hull, walked as its edges or as its vertices.+module Moonlight.Triangulation.Handles.Iterators.HullIterator+  ( hullEdges+  , hullVertices+  , foldHullEdges'+  , foldHullVertices'+  ) where++import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Types++-- | The convex hull as directed edges, in order.+hullEdges :: Triangulation mode vertex directed undirected face -> [DirectedEdgeId]+hullEdges triangulation = faceDirectedEdges triangulation outerFace+{-# INLINE hullEdges #-}++-- | The convex hull as vertices, in order.+hullVertices :: Triangulation mode vertex directed undirected face -> [VertexId]+hullVertices triangulation = map (origin triangulation) (hullEdges triangulation)+{-# INLINE hullVertices #-}++-- | Strict fold over 'hullEdges'.+foldHullEdges' :: Triangulation mode vertex directed undirected face -> (a -> DirectedEdgeId -> a) -> a -> a+foldHullEdges' triangulation = foldFaceDirectedEdges' triangulation outerFace++-- | Strict fold over 'hullVertices'.+foldHullVertices' :: Triangulation mode vertex directed undirected face -> (a -> VertexId -> a) -> a -> a+foldHullVertices' triangulation step = foldHullEdges' triangulation (\acc edge -> step acc (origin triangulation edge))
+ src-dcel/Moonlight/Triangulation/Internal/Canonical.hs view
@@ -0,0 +1,307 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Canonical publication: the same triangulation, renumbered so that its+-- representation is a function of its geometry alone.+module Moonlight.Triangulation.Internal.Canonical+  ( canonicalize+  ) where++import Control.Monad (when)+import Control.Monad.ST (runST)+import qualified Data.Vector.Algorithms.Intro as Intro+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MUV+import Moonlight.Triangulation.Dcel (numFaces, numUndirectedEdges, numVertices, vertexData)+import Moonlight.Triangulation.Handles.HandleDefs (VertexId (..))+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.Paged (Paged, pagedUnsafeIndex)+import Moonlight.Triangulation.Internal.Representation (Triangulation (..))+import Moonlight.Triangulation.Internal.Types (BuildError)++-- | Renumber a triangulation into its canonical representation.+--+-- Two triangulations of the same sites are the same triangulation — Delaunay+-- uniqueness says so, and the tie-break on an exactly cocircular quadrilateral+-- is keyed on coordinates rather than on identifiers so that it stays true.+-- What differs between two builds of one site set is only /numbering/: which+-- vertex got index 0, which half-edge got the even slot, where a face's cycle+-- was anchored. All of that records the schedule the value was constructed by,+-- and none of it is geometry.+--+-- This is what removes it. Every identifier is assigned from the geometry:+--+--     * vertices in lexicographic coordinate rank;+--     * undirected edges in lexicographic rank of their endpoint pair, each+--       taken low first, so the pair is an unordered pair by construction;+--     * of a pair's two half-edges, the even slot is the one leaving the+--       lower-ranked endpoint, which keeps twinning an @xor@ with one;+--     * inner faces in order of the least half-edge on their boundary, which+--       is a single index rather than a vertex tuple and so needs no special+--       case for a cycle that is not a triangle;+--     * every anchor — each vertex's outgoing edge, each face's edge — set to+--       the least admissible half-edge.+--+-- Construction therefore need not run in canonical order. Local insertion and+-- seam fusion may preserve their cheaper schedule-specific numbering; callers+-- invoke this operation only when they require the construction-independent+-- physical representative used to observe the finite-set laws.+--+-- Element payloads are @()@ because a renumbering is a bijection and could+-- carry them, but nothing that wants that exists; the writers a general form+-- would need were retired when their last caller went. Vertex payloads travel+-- with their vertices, and constraint flags with their edges, so a constrained+-- triangulation canonicalizes as readily as an unconstrained one.+canonicalize+  :: Triangulation mode vertex () () ()+  -> Either BuildError (Triangulation mode vertex () () ())+canonicalize source = runST $ do+  mutable <- newMutableDcel (triElementDefaults source) (max 1 vertexTotal)+  forRange 0 vertexTotal $ \canonical -> do+    let !old = vertexOrder `U.unsafeIndex` canonical+    _ <-+      appendVertexCoordinates+        mutable+        (coordinateX `pagedUnsafeIndex` old)+        (coordinateY `pagedUnsafeIndex` old)+        (vertexData source (VertexId (fromIntegral old)))+    pure ()+  _ <- addEdgeBlock mutable edgeTotal+  _ <- addFaceBlock mutable (faceTotal - 1)+  forRange 0 directedTotal $ \canonical -> do+    let !old = directedFromCanonical `U.unsafeIndex` canonical+    writeOrigin mutable canonical (vertexRank `U.unsafeIndex` originOf old)+    writeNext mutable canonical (directedToCanonical `U.unsafeIndex` topology (4 * old + 1))+    writePrevious mutable canonical (directedToCanonical `U.unsafeIndex` topology (4 * old + 2))+    writeFace mutable canonical (faceRank `U.unsafeIndex` topology (4 * old + 3))+  forRange 0 vertexTotal $ \canonical -> do+    let !least = leastOutgoing `U.unsafeIndex` canonical+    if least == absent+      then writeVertexOut mutable canonical (-1)+      else markConnected mutable canonical least+  forRange 0 faceTotal $ \canonical -> do+    let !least = leastOnFace `U.unsafeIndex` oldFaceOf canonical+    writeFaceEdge mutable canonical (if least == absent then -1 else least)+  forRange 0 edgeTotal $ \canonicalUndirected ->+    when (constraintFlag `pagedUnsafeIndex` (edgeOrder `U.unsafeIndex` canonicalUndirected) /= 0) $+      () <$ setConstraint mutable (2 * canonicalUndirected)+  freezeTriangulation mutable+ where+  !vertexTotal = numVertices source+  !edgeTotal = numUndirectedEdges source+  !faceTotal = numFaces source+  !directedTotal = 2 * edgeTotal++  -- Read the arenas rather than the handle accessors. Every one of these is+  -- indexed a few times per element, and the accessors would box a t'Point' or+  -- an identifier newtype at each of them.+  !coordinateX = triPointX source+  !coordinateY = triPointY source+  !topologyArena = triHalfTopology source+  !constraintFlag = triConstraint source+  topology slot = fromIntegral (topologyArena `pagedUnsafeIndex` slot) :: Int+  originOf directed = topology (4 * directed)++  -- Vertices, in lexicographic coordinate rank. Sorting a vector of keys with+  -- the type's own ordering rather than an index vector under a closure: the+  -- comparison then specializes instead of being an unknown call per step.+  --+  -- Sortedness is checked first, because a great many of the meshes handed to+  -- this function already have it and the check costs one linear scan against a+  -- sort's @n log n@. A seam merge is the reason: it copies two canonically+  -- numbered operands into one arena, lower abscissa first, and the sites of+  -- the result are then already in rank order by construction. Nothing about+  -- the schedule is assumed here — the coordinates are simply read and+  -- believed, so a mesh that arrives sorted for any other reason is served just+  -- as well.+  !alreadyRanked = coordinatesAscend vertexTotal coordinateX coordinateY+  !vertexOrder+    | alreadyRanked = U.enumFromN 0 vertexTotal+    | otherwise =+        thirdColumn $+          sortedVector+            ( U.generate+                vertexTotal+                ( \index ->+                    ( coordinateX `pagedUnsafeIndex` index+                    , coordinateY `pagedUnsafeIndex` index+                    , index+                    )+                )+            )+  !vertexRank+    | alreadyRanked = vertexOrder+    | otherwise = invertPermutation vertexTotal vertexOrder++  -- Undirected edges, in lexicographic rank of their endpoint pair.+  --+  -- Both components of the key are vertex ranks, so they are already dense+  -- indices into a range this function knows: comparing them is a counting+  -- sort's job, not a comparison sort's. Two stable passes — the high endpoint+  -- first, then the low one — leave the pairs in lexicographic order, in time+  -- linear in the edges and the vertices rather than @E log E@.+  !edgeLow =+    U.generate edgeTotal $ \index ->+      min+        (vertexRank `U.unsafeIndex` originOf (2 * index))+        (vertexRank `U.unsafeIndex` originOf (2 * index + 1))+  !edgeHigh =+    U.generate edgeTotal $ \index ->+      max+        (vertexRank `U.unsafeIndex` originOf (2 * index))+        (vertexRank `U.unsafeIndex` originOf (2 * index + 1))+  !edgeOrder =+    countingSortOn vertexTotal edgeLow $+      countingSortOn vertexTotal edgeHigh (U.enumFromN 0 edgeTotal)++  -- The even half of each canonical pair leaves the lower-ranked endpoint.+  !directedFromCanonical =+    U.generate directedTotal $ \canonical ->+      let !oldEdge = edgeOrder `U.unsafeIndex` (canonical `quot` 2)+          !evenHalf = 2 * oldEdge+          !leavesLower =+            vertexRank `U.unsafeIndex` originOf evenHalf+              <= vertexRank `U.unsafeIndex` originOf (evenHalf + 1)+       in if even canonical == leavesLower then evenHalf else evenHalf + 1+  !directedToCanonical = invertPermutation directedTotal directedFromCanonical++  -- The least canonical half-edge on each old face and leaving each canonical+  -- vertex, in one pass. Anchors have to be a function of the geometry too, or+  -- two builds of one site set would publish the same cycles anchored in+  -- different places.+  (!leastOnFace, !leastOutgoing) = runST $ do+    faces <- MUV.replicate (max 1 faceTotal) absent+    vertices <- MUV.replicate (max 1 vertexTotal) absent+    forRange 0 directedTotal $ \canonical -> do+      let !old = directedFromCanonical `U.unsafeIndex` canonical+          !face = topology (4 * old + 3)+          !rank = vertexRank `U.unsafeIndex` originOf old+      onFace <- MUV.unsafeRead faces face+      when (canonical < onFace) (MUV.unsafeWrite faces face canonical)+      leaving <- MUV.unsafeRead vertices rank+      when (canonical < leaving) (MUV.unsafeWrite vertices rank canonical)+    (,) <$> U.unsafeFreeze faces <*> U.unsafeFreeze vertices++  -- Inner faces, in order of the least canonical half-edge on their boundary.+  -- The outer face keeps index zero, which the arena reserves for it anyway.+  --+  -- No two faces share a least half-edge, so this key is injective and the+  -- ordering can be read off by inverting it: mark each face at its own least+  -- half-edge, then scan the half-edges in order. That is one linear pass and+  -- no comparisons at all. A face the scan never reaches has no boundary — only+  -- reachable in a mesh with no edges — and follows in old index order so that+  -- the result stays a permutation whatever it is handed.+  !innerFaceOrder = U.create $ do+    owner <- MUV.replicate (max 1 directedTotal) absent+    forRange 1 faceTotal $ \face -> do+      let !least = leastOnFace `U.unsafeIndex` face+      when (least /= absent) (MUV.unsafeWrite owner least face)+    emitted <- MUV.replicate (max 1 faceTotal) False+    out <- MUV.new (max 0 (faceTotal - 1))+    let scan !slot !filled+          | slot >= directedTotal = pure filled+          | otherwise = do+              !face <- MUV.unsafeRead owner slot+              if face == absent+                then scan (slot + 1) filled+                else do+                  MUV.unsafeWrite out filled face+                  MUV.unsafeWrite emitted face True+                  scan (slot + 1) (filled + 1)+        sweep !face !filled+          | face >= faceTotal = pure ()+          | otherwise = do+              !done <- MUV.unsafeRead emitted face+              if done+                then sweep (face + 1) filled+                else do+                  MUV.unsafeWrite out filled face+                  sweep (face + 1) (filled + 1)+    scan 0 0 >>= sweep 1+    pure out+  !faceRank = U.create $ do+    ranks <- MUV.replicate (max 1 faceTotal) 0+    U.iforM_ innerFaceOrder $ \rank old -> MUV.unsafeWrite ranks old (rank + 1)+    pure ranks+  oldFaceOf canonical+    | canonical == 0 = 0+    | otherwise = innerFaceOrder `U.unsafeIndex` (canonical - 1)+++-- | No half-edge reaches this face or vertex. A one-site mesh has such a+-- vertex and an edgeless outer face; the arena spells the same absence as a+-- packed sentinel, which is not a value an index may take.+absent :: Int+absent = maxBound++-- | @[from, to)@, without materializing the range as a list.+forRange :: Monad m => Int -> Int -> (Int -> m ()) -> m ()+forRange from to action = go from+ where+  go !index+    | index >= to = pure ()+    | otherwise = action index >> go (index + 1)+{-# INLINE forRange #-}++sortedVector :: (U.Unbox key, Ord key) => U.Vector key -> U.Vector key+sortedVector = U.modify Intro.sort+{-# INLINE sortedVector #-}++-- | Stably reorder @items@ by a key that is already a dense index below+-- @range@, in time linear in both.+--+-- Applied least-significant key first, repeated application leaves the items in+-- lexicographic order of the whole key — which is what makes a two-component+-- ordering over vertex ranks cost @O(V + E)@ instead of @O(E log E)@.+countingSortOn :: Int -> U.Vector Int -> U.Vector Int -> U.Vector Int+countingSortOn range keys items = U.create $ do+  counts <- MUV.replicate (range + 1) 0+  U.forM_ items $ \item ->+    MUV.unsafeModify counts (+ 1) (keys `U.unsafeIndex` item)+  let prefix !key !running+        | key > range = pure ()+        | otherwise = do+            !count <- MUV.unsafeRead counts key+            MUV.unsafeWrite counts key running+            prefix (key + 1) (running + count)+  prefix 0 0+  out <- MUV.new (max 1 (U.length items))+  U.forM_ items $ \item -> do+    let !key = keys `U.unsafeIndex` item+    !slot <- MUV.unsafeRead counts key+    MUV.unsafeWrite counts key (slot + 1)+    MUV.unsafeWrite out slot item+  pure (MUV.slice 0 (U.length items) out)++thirdColumn :: (U.Unbox a, U.Unbox b) => U.Vector (a, b, Int) -> U.Vector Int+thirdColumn = U.map (\(_, _, index) -> index)+{-# INLINE thirdColumn #-}++-- | Whether the stored sites are already in strict lexicographic order, in+-- which case ranking them is the identity and both permutations are free.+--+-- Strict rather than non-strict: a triangulation stores each site once, so+-- equal adjacent coordinates would mean a mesh this function has no ordering+-- for, and it is the sort's business to say so rather than this predicate's.+coordinatesAscend :: Int -> Paged Double -> Paged Double -> Bool+coordinatesAscend total x y = go 1+ where+  go !index+    | index >= total = True+    | otherwise =+        let !previousX = x `pagedUnsafeIndex` (index - 1)+            !currentX = x `pagedUnsafeIndex` index+         in case compare previousX currentX of+              LT -> go (index + 1)+              GT -> False+              EQ ->+                y `pagedUnsafeIndex` (index - 1) < y `pagedUnsafeIndex` index+                  && go (index + 1)++-- | @inverse ! (order ! i) == i@: the rank each element was given.+invertPermutation :: Int -> U.Vector Int -> U.Vector Int+invertPermutation count order = U.create $ do+  inverse <- MUV.replicate (max 1 count) 0+  U.iforM_ order $ \rank element -> MUV.unsafeWrite inverse element rank+  pure inverse
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | The topology-mutating primitives, gathered from their role modules.+module Moonlight.Triangulation.Internal.DcelOperations+  ( setupFirstVertex+  , setupSecondVertex+  , splitLineEdge+  , extendLine+  , lineToArea+  , insertIntoFace+  , insertOnEdge+  , insertOutsideHull+  , insertOutsideHullBetween+  , closeOuterTurn+  , fixHullConvexity+  , flipEdge+  , legalizeScratch+  , legalizeEdges+  , legalizeCavityFanScratch+  , LegalizationLaw (..)+  , seedStarScratch+  , seedGenericEdges+  , drainLegalization+  , noStarVertex+  , isFlippableEdge+  , collectLineChain+  ) where++import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena+  ( noStarVertex+  , seedGenericEdges+  , seedStarScratch+  )+import Moonlight.Triangulation.Internal.DcelOperations.Chain+  ( collectLineChain+  , extendLine+  , lineToArea+  , setupFirstVertex+  , setupSecondVertex+  , splitLineEdge+  )+import Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite (flipEdge)+import Moonlight.Triangulation.Internal.DcelOperations.FlipRule+  ( LegalizationLaw (..)+  , isFlippableEdge+  )+import Moonlight.Triangulation.Internal.DcelOperations.Hull+  ( closeOuterTurn+  , fixHullConvexity+  , insertOutsideHull+  , insertOutsideHullBetween+  )+import Moonlight.Triangulation.Internal.DcelOperations.Legalize+  ( legalizeCavityFanScratch+  , legalizeEdges+  , legalizeScratch+  )+import Moonlight.Triangulation.Internal.DcelOperations.Normalize (drainLegalization)+import Moonlight.Triangulation.Internal.DcelOperations.Subdivide+  ( insertIntoFace+  , insertOnEdge+  )
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/CandidateArena.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | The legalization candidate stack: tagging, growth, and seeding.+module Moonlight.Triangulation.Internal.DcelOperations.CandidateArena+  ( starCandidate+  , genericCandidate+  , growLegalizationArena+  , seedStarScratch+  , seedGenericEdges+  , noStarVertex+  ) where++import Control.Monad (forM_, when)+import Control.Monad.ST (ST)+import Data.Word (Word32)+import qualified Data.Vector.Unboxed.Mutable as MUV+import Moonlight.Triangulation.Internal.OperationState+  ( OperationState+  , legalizationArena+  , readScratch+  , storeLegalizationArena+  )+import Moonlight.Triangulation.Internal.PackedIndex (packIndex)++-- A candidate carries the discipline under which it must be tested. One+-- seeded from an insertion star names an edge that has to be re-oriented so+-- the inserted vertex is opposite it; one seeded generically already names the+-- edge to test. Building a geometric patch used to start and drain the work+-- stack once per primitive because the two could not share it — the fan, then+-- every closed hull turn separately, each re-reading the same neighbourhood.+-- With the discipline travelling on the candidate they share one drain.+starCandidate :: Int -> Int+starCandidate edge = edge * 2+{-# INLINE starCandidate #-}++genericCandidate :: Int -> Int+genericCandidate edge = edge * 2 + 1+{-# INLINE genericCandidate #-}++-- | Seed candidates from the scratch arena, returning the new stack top.+-- Transaction-sized preallocation covers the normal path; rare adversarial+-- overflow grows the operation-owned vector without changing LIFO order.+seedStarScratch :: OperationState s -> Int -> Int -> ST s Int+seedStarScratch operation top candidateCount = do+  initialArena <- legalizationArena operation+  arena <- growLegalizationArena initialArena (top + candidateCount)+  when (MUV.length arena /= MUV.length initialArena) (storeLegalizationArena operation arena)+  forM_ [0 .. candidateCount - 1] $ \index -> do+    edge <- readScratch operation index+    MUV.unsafeWrite arena (top + index) (packIndex (starCandidate edge))+  pure (top + candidateCount)++-- | Seed generic candidates from a list, returning the new stack top.+seedGenericEdges :: OperationState s -> Int -> [Int] -> ST s Int+seedGenericEdges operation top edges = do+  initialArena <- legalizationArena operation+  let !count = length edges+  arena <- growLegalizationArena initialArena (top + count)+  when (MUV.length arena /= MUV.length initialArena) (storeLegalizationArena operation arena)+  forM_ (zip [0 ..] edges) $ \(!index, !edge) ->+    MUV.unsafeWrite arena (top + index) (packIndex (genericCandidate edge))+  pure (top + count)++growLegalizationArena :: MUV.MVector s Word32 -> Int -> ST s (MUV.MVector s Word32)+growLegalizationArena arena required+  | required <= current = pure arena+  | otherwise = MUV.grow arena (max (required - current) (max 1 current))+ where+  !current = MUV.length arena+{-# INLINE growLegalizationArena #-}++-- | No star candidate can be seeded against this, so a drain given it must+-- have been seeded generically throughout.+noStarVertex :: Int+noStarVertex = -1+
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Chain.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | The degenerate dimensions: a point, a segment chain, and its promotion.+module Moonlight.Triangulation.Internal.DcelOperations.Chain+  ( setupFirstVertex+  , setupSecondVertex+  , splitLineEdge+  , extendLine+  , collectLineChain+  , lineToArea+  ) where++import Control.Monad (forM_, when)+import Control.Monad.ST (ST)+import Data.STRef (writeSTRef)+import Moonlight.Triangulation.Handles.HandleDefs (VertexId (..))+import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeScratch)+import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex)+import Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel (..)+  , addEdge+  , addEdgeBlock+  , addFaceBlock+  , directedEdgeCount+  , edgeOriginPoint+  , ensureCellCapacity+  , isConnected+  , linkEdges+  , markConnected+  , pointAt+  , pointCount+  , readConstraint+  , readNext+  , readOrigin+  , readPrevious+  , readVertexOut+  , resetEdgeData+  , setConstraint+  , setCycle3+  , writeFace+  , writeFaceEdge+  , writeOrigin+  , writeVertexOut+  )+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , readScratch+  , writeScratch+  )+import Moonlight.Triangulation.Internal.Probe (KnownProbe)+import Moonlight.Triangulation.Internal.Types (BuildError (..))+import Moonlight.Triangulation.Math (orient2d)++setupFirstVertex :: MutableDcel s vertex directed undirected face -> Int -> ST s ()+setupFirstVertex mutable vertex = markConnected mutable vertex (-1)++setupSecondVertex :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError ())+setupSecondVertex mutable vertex = do+  vertices <- pointCount mutable+  connected <- findConnected mutable vertices 0+  case connected of+    Left obstruction -> pure (Left obstruction)+    Right first -> do+      capacity <- ensureCellCapacity mutable 1 0+      case capacity of+        Left obstruction -> pure (Left obstruction)+        Right () -> do+          (edge, reverseEdgeEdge) <- addEdge mutable first vertex+          linkEdges mutable edge reverseEdgeEdge+          linkEdges mutable reverseEdgeEdge edge+          writeFace mutable edge 0+          writeFace mutable reverseEdgeEdge 0+          writeFaceEdge mutable 0 edge+          writeVertexOut mutable first edge+          markConnected mutable vertex reverseEdgeEdge+          pure (Right ())++splitLineEdge :: MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())+splitLineEdge mutable operation edge vertex = do+  capacity <- ensureCellCapacity mutable 1 0+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> do+      protected <- readConstraint mutable edge+      let !reverseEdgeEdge = reverseIndex edge+      destinationVertex <- readOrigin mutable reverseEdgeEdge+      oldNextEdge <- readNext mutable edge+      oldPreviousTwin <- readPrevious mutable reverseEdgeEdge+      oldNextTwin <- readNext mutable reverseEdgeEdge+      writeOrigin mutable reverseEdgeEdge vertex+      (newEdge, newTwin) <- addEdge mutable vertex destinationVertex+      writeFace mutable newEdge 0+      writeFace mutable newTwin 0+      if oldNextEdge == reverseEdgeEdge+        then do+          -- The split segment reaches a line endpoint. Its forward edge and twin+          -- are adjacent, so the replacement is one contiguous four-edge run.+          -- This also covers the initial two-vertex topology.+          linkEdges mutable edge newEdge+          linkEdges mutable newEdge newTwin+          linkEdges mutable newTwin reverseEdgeEdge+          linkEdges mutable reverseEdgeEdge oldNextTwin+        else do+          -- Replace the two occurrences independently: [edge] becomes+          -- [edge,newEdge], while [twin] becomes [newTwin,twin].+          linkEdges mutable edge newEdge+          linkEdges mutable newEdge oldNextEdge+          linkEdges mutable oldPreviousTwin newTwin+          linkEdges mutable newTwin reverseEdgeEdge+      writeVertexOut mutable destinationVertex newTwin+      markConnected mutable vertex newEdge+      -- AB became AV. The new half is a fresh slot and already carries the+      -- default; the truncated half is a different edge in an old slot.+      resetEdgeData mutable (edge `quot` 2)+      when protected $ do+        _ <- setConstraint mutable newEdge+        pure ()+      addCounter operation CounterLineSplits 1+      pure (Right ())++extendLine :: MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())+extendLine mutable operation endpoint vertex = do+  outgoing <- readVertexOut mutable endpoint+  if outgoing < 0+    then pure (Left (DegenerateLineEndpointMissingOutgoing (VertexId (fromIntegral endpoint))))+    else do+      capacity <- ensureCellCapacity mutable 1 0+      case capacity of+        Left obstruction -> pure (Left obstruction)+        Right () -> do+          let !incoming = reverseIndex outgoing+          (newEdge, newTwin) <- addEdge mutable endpoint vertex+          writeFace mutable newEdge 0+          writeFace mutable newTwin 0+          linkEdges mutable incoming newEdge+          linkEdges mutable newEdge newTwin+          linkEdges mutable newTwin outgoing+          writeVertexOut mutable endpoint newEdge+          markConnected mutable vertex newTwin+          addCounter operation CounterLineExtensions 1+          pure (Right ())++collectLineChain :: MutableDcel s vertex directed undirected face -> OperationState s -> ST s (Either BuildError Int)+collectLineChain mutable operation = do+  halfEdges <- directedEdgeCount mutable+  turn <- findTurn halfEdges 0+  case turn of+    Left obstruction -> pure (Left obstruction)+    Right incoming -> do+      let !first = reverseIndex incoming+          go !count !edge = do+            writeScratch operation count edge+            edgeNext <- readNext mutable edge+            if edgeNext == reverseIndex edge+              then pure (Right (count + 1))+              else go (count + 1) edgeNext+      go 0 first+ where+  findTurn halfEdges !edge+    | edge >= halfEdges = pure (Left (DegenerateLineEndpointTurnMissing halfEdges))+    | otherwise = do+        edgeNext <- readNext mutable edge+        if edgeNext == reverseIndex edge then pure (Right edge) else findTurn halfEdges (edge + 1)++lineToArea :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> ST s (Either BuildError ())+lineToArea mutable operation vertex = do+  collected <- collectLineChain mutable operation+  case collected of+    Left obstruction -> pure (Left obstruction)+    Right segmentCount -> lineToAreaCollected @p mutable operation vertex segmentCount++lineToAreaCollected :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())+lineToAreaCollected mutable@MutableDcel{mdLastFace} operation vertex segmentCount = do+  capacity <- ensureCellCapacity mutable (segmentCount + 1) segmentCount+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> lineToAreaWithCapacity+ where+  lineToAreaWithCapacity = do+   firstSegment <- readScratch operation 0+   lastSegment <- readScratch operation (segmentCount - 1)+   firstPoint <- edgeOriginPoint mutable firstSegment+   lastPoint <- edgeOriginPoint mutable (reverseIndex lastSegment)+   insertedPoint <- pointAt mutable vertex+   when (orient2d firstPoint lastPoint insertedPoint == LT) $ reverseScratchDirections operation segmentCount+   spokeBase <- addEdgeBlock mutable (segmentCount + 1)+   faceBase <- addFaceBlock mutable segmentCount+   forM_ [0 .. segmentCount] $ \index -> do+    chainVertex <-+      if index < segmentCount+        then readScratch operation index >>= readOrigin mutable+        else readScratch operation (segmentCount - 1) >>= readOrigin mutable . reverseIndex+    let !forward = spokeBase + 2 * index+        !backward = forward + 1+    writeOrigin mutable forward chainVertex+    writeOrigin mutable backward vertex+   forM_ [0 .. segmentCount - 1] $ \index -> do+    segment <- readScratch operation index+    let !face = faceBase + index+        !nextSpoke = spokeBase + 2 * (index + 1)+        !previousSpoke = spokeBase + 2 * index + 1+    setCycle3 mutable face segment nextSpoke previousSpoke+   lastInnerSegment <- readScratch operation (segmentCount - 1)+   let !outerStart = reverseIndex lastInnerSegment+       !firstOuterSpoke = spokeBase+       !lastOuterSpoke = spokeBase + 2 * segmentCount + 1+   linkOuterTwins mutable operation segmentCount+   firstInnerSegment <- readScratch operation 0+   linkEdges mutable (reverseIndex firstInnerSegment) firstOuterSpoke+   linkEdges mutable firstOuterSpoke lastOuterSpoke+   linkEdges mutable lastOuterSpoke outerStart+   writeFace mutable firstOuterSpoke 0+   writeFace mutable lastOuterSpoke 0+   writeFaceEdge mutable 0 outerStart+   forM_ [0 .. segmentCount - 1] $ \index -> do+    segment <- readScratch operation index+    chainVertex <- readOrigin mutable segment+    writeVertexOut mutable chainVertex segment+   finalVertex <- readOrigin mutable (reverseIndex lastInnerSegment)+   writeVertexOut mutable finalVertex (spokeBase + 2 * segmentCount)+   markConnected mutable vertex (spokeBase + 1)+   writeSTRef mdLastFace faceBase+   addCounter operation CounterLineToAreaTransitions 1+   legalizeScratch @p mutable operation vertex segmentCount+   pure (Right ())++  linkOuterTwins :: MutableDcel s vertex directed undirected face -> OperationState s -> Int -> ST s ()+  linkOuterTwins target ops count =+    let go !index+          | index <= 0 = pure ()+          | otherwise = do+              right <- readScratch ops index+              left <- readScratch ops (index - 1)+              linkEdges target (reverseIndex right) (reverseIndex left)+              writeFace target (reverseIndex right) 0+              go (index - 1)+     in do+          go (count - 1)+          first <- readScratch ops 0+          writeFace target (reverseIndex first) 0++reverseScratchDirections :: OperationState s -> Int -> ST s ()+reverseScratchDirections operation count = do+  forM_ [0 .. count `quot` 2 - 1] $ \left -> do+    let !right = count - 1 - left+    leftEdge <- readScratch operation left+    rightEdge <- readScratch operation right+    writeScratch operation left (reverseIndex rightEdge)+    writeScratch operation right (reverseIndex leftEdge)+  when (odd count) $ do+    let !middle = count `quot` 2+    edge <- readScratch operation middle+    writeScratch operation middle (reverseIndex edge)++findConnected :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s (Either BuildError Int)+findConnected mutable limit !vertex+  | vertex >= limit = pure (Left (DegenerateLineConnectedVertexMissing limit))+  | otherwise = do+      connected <- isConnected mutable vertex+      if connected then pure (Right vertex) else findConnected mutable limit (vertex + 1)
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRewrite.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | The flip rewrite itself, on a quadrilateral.+module Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite+  ( flipEdge+  , applyFlip+  ) where++import Control.Monad (unless)+import Control.Monad.ST (ST)+import Moonlight.Triangulation.Handles.HandleDefs (UndirectedEdgeId (..))+import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex)+import Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel+  , payloadsPristine+  , readConstraint+  , readFace+  , readNext+  , readOrigin+  , readPrevious+  , resetEdgeData+  , resetFaceData+  , setCycle3+  , writeOrigin+  , writeVertexOut+  )+import Moonlight.Triangulation.Internal.Types (BuildError (ConstrainedEdgeFlipRefused))++flipEdge :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError ())+flipEdge mutable edge = do+  protected <- readConstraint mutable edge+  if protected+    then pure (Left (ConstrainedEdgeFlipRefused (UndirectedEdgeId (fromIntegral (edge `quot` 2)))))+    else do+      let !twin = reverseIndex edge+      edgeNext <- readNext mutable edge+      edgePrevious <- readPrevious mutable edge+      twinNext <- readNext mutable twin+      twinPrevious <- readPrevious mutable twin+      leftFace <- readFace mutable edge+      rightFace <- readFace mutable twin+      a <- readOrigin mutable edge+      b <- readOrigin mutable twin+      c <- readOrigin mutable edgePrevious+      d <- readOrigin mutable twinPrevious+      applyFlip mutable edge twin edgeNext edgePrevious twinNext twinPrevious leftFace rightFace a b c d+      pure (Right ())++-- | The rewrite itself, from a quadrilateral the caller already holds. The+-- decision that licenses a flip reads the same two half-edge records the+-- rewrite consumes, so the drain hands its neighbourhood straight here rather+-- than making 'flipEdge' fetch it a second time; 'flipEdge' is that fetch, for+-- callers arriving with nothing but an index.+applyFlip+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> ST s ()+applyFlip mutable edge twin edgeNext edgePrevious twinNext twinPrevious leftFace rightFace a b c d = do+  writeOrigin mutable edge c+  writeOrigin mutable twin d+  setCycle3 mutable leftFace edge twinPrevious edgeNext+  setCycle3 mutable rightFace twin edgePrevious twinNext+  -- The diagonal AB is gone and CD stands in its slot; both triangles have+  -- swapped a corner. Three elements changed what they are, so three labels go.+  -- Each reset carries the same test; a site doing several states it once.+  unless (payloadsPristine mutable) $ do+    resetEdgeData mutable (edge `quot` 2)+    resetFaceData mutable leftFace+    resetFaceData mutable rightFace+  writeVertexOut mutable a twinNext+  writeVertexOut mutable b edgeNext+  writeVertexOut mutable c edge+  writeVertexOut mutable d twin+{-# INLINE applyFlip #-}
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRule.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | The firing condition of the flip rule, and the laws restricting it.+module Moonlight.Triangulation.Internal.DcelOperations.FlipRule+  ( LegalizationLaw (..)+  , diagonalFires+  , illegalDiagonal+  , isFlippableEdge+  , orderedPair+  ) where++import Control.Monad.ST (ST)+import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex)+import Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel+  , readConstraint+  , readFace+  , readOrigin+  , readPointX+  , readPointY+  , readPrevious+  )+import Moonlight.Triangulation.Scalar (inCircleCoordinates, orient2dCoordinates)++-- | Whether the flip rule may fire on a quadrilateral @a b c d@ under a law,+-- where @ab@ is the diagonal and @c@, @d@ the apexes opposite it. The+-- coordinates arrive raw, in the order the mutable accessors carry.+--+-- '&&' gives 'ValidMesh' its short-circuit past the incircle determinant, and+-- 'CavityRepair' never names the convexity test whose premise it denies. The+-- drain reaches this with the quadrilateral already in hand; the firing+-- condition itself has one owner.+diagonalFires+  :: LegalizationLaw+  -> Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double+  -> Bool+diagonalFires law ax ay bx by cx cy dx dy =+  case law of+    ValidMesh ->+      orient2dCoordinates cx cy dx dy bx by == GT+        && orient2dCoordinates dx dy cx cy ax ay == GT+        && illegalDiagonal ax ay bx by cx cy dx dy+    CavityRepair _ -> illegalDiagonal ax ay bx by cx cy dx dy+{-# INLINE diagonalFires #-}++-- | Whether a diagonal is locally illegal — the firing condition of the flip+-- rule @drainLegalization@ normalizes under, and the step at which its+-- potential strictly decreases.+--+-- Lift the quadrilateral to @z = x² + y²@ and the in-circle sign is the+-- orientation of the lifted tetrahedron: 'GT' says the fourth point is below+-- the plane of the other three, so the current diagonal spans a fold the flip+-- pushes downward. 'EQ' says the four lifted points are coplanar and the flip+-- changes nothing about the surface — so the ordering on diagonal keys stands+-- in as the potential, and the rule fires only downward in it. That tie-break+-- is not a convention for picking among equals; it is what stops a cocircular+-- quadrilateral from flipping forever.+illegalDiagonal+  :: Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double -> Bool+illegalDiagonal ax ay bx by cx cy dx dy =+  case inCircleCoordinates ax ay bx by cx cy dx dy of+    GT -> True+    LT -> False+    EQ -> orderedPair (cx, cy) (dx, dy) < orderedPair (ax, ay) (bx, by)+{-# INLINE illegalDiagonal #-}++isFlippableEdge :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool+isFlippableEdge mutable edge = do+  protected <- readConstraint mutable edge+  if protected+    then pure False+    else do+      let !reverseEdgeEdge = reverseIndex edge+      leftFace <- readFace mutable edge+      rightFace <- readFace mutable reverseEdgeEdge+      if leftFace == 0 || rightFace == 0+        then pure False+        else do+          edgePrevious <- readPrevious mutable edge+          reverseEdgePrevious <- readPrevious mutable reverseEdgeEdge+          a <- readOrigin mutable edge+          b <- readOrigin mutable reverseEdgeEdge+          c <- readOrigin mutable edgePrevious+          d <- readOrigin mutable reverseEdgePrevious+          ax <- readPointX mutable a+          ay <- readPointY mutable a+          bx <- readPointX mutable b+          by <- readPointY mutable b+          cx <- readPointX mutable c+          cy <- readPointY mutable c+          dx <- readPointX mutable d+          dy <- readPointY mutable d+          pure+            ( orient2dCoordinates cx cy dx dy bx by == GT+                && orient2dCoordinates dx dy cx cy ax ay == GT+            )+{-# INLINE isFlippableEdge #-}++-- | The rewrite strategy: which candidates the flip rule is allowed to fire+-- on. Both laws leave the normal form alone — they restrict where the rule may+-- be applied, never what a legal diagonal is.+--+-- 'ValidMesh' legalizes a mesh that is already a triangulation. There a+-- non-convex quadrilateral's diagonal is necessarily locally Delaunay, so+-- testing convexity first is a free short-circuit around the incircle+-- determinant — it can only decline flips the determinant would have declined.+--+-- 'CavityRepair' legalizes the fan that fills a removed vertex's hole, which is+-- not yet a triangulation. That implication fails on an inverted quadrilateral,+-- and the inverted one is exactly the one that must flip, so the short-circuit+-- becomes a refusal to perform the repair. The carried index is the undirected+-- edge count taken before the fan was built: every edge at or above it was+-- appended by the fan, and only those may flip, so a transiently inverted+-- neighbourhood cannot flip the cavity's border away.+data LegalizationLaw+  = ValidMesh+  | CavityRepair {-# UNPACK #-} !Int++orderedPair :: Ord a => a -> a -> (a, a)+orderedPair left right+  | left <= right = (left, right)+  | otherwise = (right, left)+{-# INLINE orderedPair #-}
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Hull.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Growth outside the hull: visible ranges, turn closure, and convexity repair.+module Moonlight.Triangulation.Internal.DcelOperations.Hull+  ( insertOutsideHull+  , insertOutsideHullBetween+  , closeOuterTurn+  , fixHullConvexity+  ) where++import Control.Monad (forM_)+import Control.Monad.ST (ST)+import Data.STRef (writeSTRef)+import Moonlight.Triangulation.Handles.HandleDefs (DirectedEdgeId (..), FaceId (..))+import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena+  ( noStarVertex+  , seedGenericEdges+  )+import Moonlight.Triangulation.Internal.DcelOperations.FlipRule (LegalizationLaw (..))+import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeScratch)+import Moonlight.Triangulation.Internal.DcelOperations.Normalize (drainLegalization)+import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex)+import Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel (..)+  , addEdge+  , addEdgeBlock+  , addFaceBlock+  , directedEdgeCount+  , ensureCellCapacity+  , linkEdges+  , markConnected+  , pointAt+  , readFace+  , readFaceEdge+  , readNext+  , readOrigin+  , readPointX+  , readPointY+  , readPrevious+  , setCycle3+  , writeFace+  , writeFaceEdge+  , writeOrigin+  , writeVertexOut+  )+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , readScratch+  , writeScratch+  )+import Moonlight.Triangulation.Internal.Probe (KnownProbe)+import Moonlight.Triangulation.Types (BuildError (..), Point (..))+import Moonlight.Triangulation.Scalar (orient2dCoordinates)++insertOutsideHull :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())+insertOutsideHull mutable operation start vertex = do+  query <- pointAt mutable vertex+  visibleStart <- visibleOuter mutable start query+  if not visibleStart+    then pure (Left (HullStartNotVisible (DirectedEdgeId (fromIntegral start))))+    else do+      halfEdges <- directedEdgeCount mutable+      left <- expandPrevious halfEdges start start query+      right <- expandNext halfEdges start left query+      collected <- collectOuterChain mutable operation left right+      case collected of+        Left obstruction -> pure (Left obstruction)+        Right chainCount -> do+          inserted <- insertOutsideHullCollected @p mutable operation vertex chainCount+          case inserted of+            Left obstruction -> pure (Left obstruction)+            Right _ -> do+              -- The regular insertion path owns its own hull-insertion count; the sweep+              -- path through 'insertOutsideHullBetween' counts its own instead.+              addCounter operation CounterHullInsertions 1+              pure (Right ())+ where+  expandPrevious !bound !stopAt !current !query+    | bound <= 0 = pure current+    | otherwise = do+        candidate <- readPrevious mutable current+        if candidate == stopAt+          then pure current+          else do+            visible <- visibleOuter mutable candidate query+            if visible then expandPrevious (bound - 1) stopAt candidate query else pure current++  expandNext !bound !current !left !query+    | bound <= 0 = pure current+    | otherwise = do+        candidate <- readNext mutable current+        if candidate == left+          then pure current+          else do+            visible <- visibleOuter mutable candidate query+            if visible then expandNext (bound - 1) candidate left query else pure current++-- | Insert a vertex outside an explicitly selected contiguous outer-face range.+-- The range, rather than a convexity policy, is the primitive: regular+-- insertion supplies the complete visible range, while circle sweep may supply+-- one edge and defer the remaining hull turns. Topology mutation has one owner.+insertOutsideHullBetween+  :: forall p s vertex directed undirected face+   . KnownProbe p+  => MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> Int+  -> ST s (Either BuildError (Int, Int))+insertOutsideHullBetween mutable operation left right vertex = do+  collected <- collectOuterChain mutable operation left right+  case collected of+    Left obstruction -> pure (Left obstruction)+    Right chainCount -> insertOutsideHullCollected @p mutable operation vertex chainCount++collectOuterChain+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> ST s (Either BuildError Int)+collectOuterChain mutable operation left right = do+  halfEdges <- directedEdgeCount mutable+  go (halfEdges + 1) left 0+ where+  go !remaining !current !count+    | remaining <= 0 =+        pure+          ( Left+              ( OuterRangeDidNotTerminate+                  (DirectedEdgeId (fromIntegral left))+                  (DirectedEdgeId (fromIntegral right))+                  count+              )+          )+    | otherwise = do+        incident <- readFace mutable current+        if incident /= 0+          then+            pure+              ( Left+                  ( OuterRangeContainsInnerEdge+                      (DirectedEdgeId (fromIntegral current))+                      (FaceId (fromIntegral incident))+                  )+              )+          else do+            writeScratch operation count current+            if current == right+              then pure (Right (count + 1))+              else readNext mutable current >>= \following -> go (remaining - 1) following (count + 1)++insertOutsideHullCollected+  :: forall p s vertex directed undirected face+   . KnownProbe p+  => MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> ST s (Either BuildError (Int, Int))+insertOutsideHullCollected mutable@MutableDcel{mdLastFace} operation vertex chainCount = do+  capacity <- ensureCellCapacity mutable (chainCount + 1) chainCount+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> Right <$> insertOutsideHullWithCapacity+ where+  insertOutsideHullWithCapacity = do+    left <- readScratch operation 0+    right <- readScratch operation (chainCount - 1)+    oldPrevious <- readPrevious mutable left+    oldNext <- readNext mutable right+    edgeBase <- addEdgeBlock mutable (chainCount + 1)+    faceBase <- addFaceBlock mutable chainCount+    forM_ [0 .. chainCount] $ \index -> do+      chainVertex <-+        if index == 0+          then readScratch operation 0 >>= readOrigin mutable+          else readScratch operation (index - 1) >>= readOrigin mutable . reverseIndex+      let !forward = edgeBase + 2 * index+          !backward = forward + 1+      writeOrigin mutable forward chainVertex+      writeOrigin mutable backward vertex+    forM_ [0 .. chainCount - 1] $ \index -> do+      outerEdge <- readScratch operation index+      let !face = faceBase + index+          !nextSpoke = edgeBase + 2 * (index + 1)+          !previousSpoke = edgeBase + 2 * index + 1+      setCycle3 mutable face outerEdge nextSpoke previousSpoke+    let !firstOuterSpoke = edgeBase+        !lastOuterSpoke = edgeBase + 2 * chainCount + 1+    writeFace mutable firstOuterSpoke 0+    writeFace mutable lastOuterSpoke 0+    linkEdges mutable oldPrevious firstOuterSpoke+    linkEdges mutable firstOuterSpoke lastOuterSpoke+    linkEdges mutable lastOuterSpoke oldNext+    writeFaceEdge mutable 0 firstOuterSpoke+    forM_ [0 .. chainCount - 1] $ \index -> do+      chainEdge <- readScratch operation index+      chainVertex <- readOrigin mutable chainEdge+      writeVertexOut mutable chainVertex chainEdge+    lastChain <- readScratch operation (chainCount - 1)+    lastVertex <- readOrigin mutable (reverseIndex lastChain)+    writeVertexOut mutable lastVertex (edgeBase + 2 * chainCount)+    markConnected mutable vertex lastOuterSpoke+    writeSTRef mdLastFace faceBase+    legalizeScratch @p mutable operation vertex chainCount+    pure (firstOuterSpoke, lastOuterSpoke)++-- | Replace two consecutive outer edges @a->b, b->c@ by @a->c@ and+-- materialize the triangle they bound. The returned edge is the new outer+-- diagonal. This is the sole turn-closing primitive used both by deferred+-- circle sweep and the final Graham repair. Topology mutation only: the+-- caller owns the legalization epoch, and seeds the two closed edges itself+-- once the replacement's links are in place.+closeOuterTurn+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> ST s (Either BuildError Int)+closeOuterTurn mutable first = do+  capacity <- ensureCellCapacity mutable 1 1+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> do+      second <- readNext mutable first+      oldPrevious <- readPrevious mutable first+      oldNext <- readNext mutable second+      from <- readOrigin mutable first+      to <- readOrigin mutable (reverseIndex second)+      (outer, inner) <- addEdge mutable from to+      newFace <- addFaceBlock mutable 1+      writeFace mutable outer 0+      setCycle3 mutable newFace first second inner+      linkEdges mutable oldPrevious outer+      linkEdges mutable outer oldNext+      writeFaceEdge mutable 0 outer+      writeVertexOut mutable from outer+      writeVertexOut mutable to inner+      pure (Right outer)+{-# INLINE closeOuterTurn #-}++-- | Close every remaining left turn of the star-shaped sweep hull in one+-- Graham-style pass. Each closure strictly decreases the outer-edge count, so+-- the pass is linear in the visited hull plus the local Delaunay legalization+-- work it causes. Turn closures are seeded into one shared epoch as they+-- happen and drained once at the end: closure never deletes an edge and never+-- touches the outer cycle's legality, so which turns close does not depend on+-- when the interior is repaired. The pass counts its own closures and returns+-- the drain's tallies; nothing is reported behind its back.+fixHullConvexity+  :: forall p s vertex directed undirected face+   . KnownProbe p+  => MutableDcel s vertex directed undirected face+  -> OperationState s+  -> ST s (Either BuildError (Int, Int, Int))+fixHullConvexity mutable operation = do+  start <- readFaceEdge mutable 0+  if start < 0+    then pure (Right (0, 0, 0))+    else do+      walked <- walk start start 0 0 0 0+      case walked of+        Left obstruction -> pure (Left obstruction)+        Right (top, closures) -> do+          (flips, maxDepth) <- drainLegalization @p mutable operation top noStarVertex ValidMesh+          pure (Right (closures, flips, maxDepth))+ where+  walk !start !current !stackSize !steps !top !closures = do+    halfEdges <- directedEdgeCount mutable+    if steps > halfEdges + 2+      then+        pure+          ( Left+              ( OuterCycleDidNotTerminate+                  (DirectedEdgeId (fromIntegral start))+                  (DirectedEdgeId (fromIntegral current))+                  steps+              )+          )+      else do+        following <- readNext mutable current+        writeScratch operation stackSize current+        reduction <- reduce (stackSize + 1) top closures+        case reduction of+          Left obstruction -> pure (Left obstruction)+          Right (reduced, nextTop, nextClosures) -> do+            finished <-+              if reduced < 2+                then pure False+                else (== following) <$> readScratch operation 1+            if finished+              then pure (Right (nextTop, nextClosures))+              else walk start following reduced (steps + 1) nextTop nextClosures++  reduce !count !top !closures+    | count < 2 = pure (Right (count, top, closures))+    | otherwise = do+        first <- readScratch operation (count - 2)+        second <- readScratch operation (count - 1)+        fromVertex <- readOrigin mutable first+        middleVertex <- readOrigin mutable (reverseIndex first)+        targetVertex <- readOrigin mutable (reverseIndex second)+        fromX <- readPointX mutable fromVertex+        fromY <- readPointY mutable fromVertex+        middleX <- readPointX mutable middleVertex+        middleY <- readPointY mutable middleVertex+        targetX <- readPointX mutable targetVertex+        targetY <- readPointY mutable targetVertex+        if orient2dCoordinates fromX fromY middleX middleY targetX targetY == GT+          then do+            closed <- closeOuterTurn mutable first+            case closed of+              Left obstruction -> pure (Left obstruction)+              Right replacement -> do+                writeScratch operation (count - 2) replacement+                nextTop <- seedGenericEdges operation top [first, second]+                reduce (count - 1) nextTop (closures + 1)+          else pure (Right (count, top, closures))++visibleOuter :: MutableDcel s vertex directed undirected face -> Int -> Point -> ST s Bool+visibleOuter mutable edge query = do+  fromVertex <- readOrigin mutable edge+  toVertex <- readOrigin mutable (reverseIndex edge)+  case query of+    Point queryX queryY -> do+      fromX <- readPointX mutable fromVertex+      fromY <- readPointY mutable fromVertex+      toX <- readPointX mutable toVertex+      toY <- readPointY mutable toVertex+      pure (orient2dCoordinates fromX fromY toX toY queryX queryY == GT)+{-# INLINE visibleOuter #-}
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Legalize.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | The seeding entry points that drive one legalization epoch.+module Moonlight.Triangulation.Internal.DcelOperations.Legalize+  ( legalizeScratch+  , legalizeEdges+  , legalizeCavityFanScratch+  ) where++import Control.Monad (when)+import Control.Monad.ST (ST)+import Data.Foldable (traverse_)+import qualified Data.Vector.Unboxed.Mutable as MUV+import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena+  ( genericCandidate+  , growLegalizationArena+  , noStarVertex+  , seedGenericEdges+  , seedStarScratch+  )+import Moonlight.Triangulation.Internal.DcelOperations.FlipRule (LegalizationLaw (..))+import Moonlight.Triangulation.Internal.DcelOperations.Normalize (drainLegalization)+import Moonlight.Triangulation.Internal.Mutable (MutableDcel)+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , legalizationArena+  , maxCounter+  , readScratch+  , storeLegalizationArena+  )+import Moonlight.Triangulation.Internal.PackedIndex (packIndex)+import Moonlight.Triangulation.Internal.Probe (KnownProbe, Probe (..))++legalizeEdges :: MutableDcel s vertex directed undirected face -> OperationState s -> [Int] -> ST s ()+legalizeEdges mutable operation initial = do+  top <- seedGenericEdges operation 0 initial+  (flips, maxDepth) <- drainLegalization @'ProbeOff mutable operation top noStarVertex ValidMesh+  addCounter operation CounterEdgeFlips flips+  maxCounter operation CounterLegalizationMaxStack maxDepth++-- | Repair the fan that fills a removed vertex's hole, draining cavity+-- candidates already written into the operation-owned scratch section. The+-- fan is a valid combinatorial filling but not yet a triangulation — a link+-- polygon that is non-convex at the fan origin yields an inverted triangle —+-- so this drain carries 'CavityRepair' rather than the insertion law: it+-- flips on the incircle determinant alone, and only the fan's own edges may+-- flip. Removal discovers and constructs the cavity inside that same+-- transaction; materializing a list merely to seed the legalization arena+-- would duplicate the local program.+legalizeCavityFanScratch+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> Int+  -> ST s ()+legalizeCavityFanScratch mutable operation cavityFloor scratchOffset candidateCount = do+  initialArena <- legalizationArena operation+  arena <- growLegalizationArena initialArena candidateCount+  when (MUV.length arena /= MUV.length initialArena) (storeLegalizationArena operation arena)+  traverse_+    (\index -> do+       edge <- readScratch operation (scratchOffset + index)+       MUV.unsafeWrite arena index (packIndex (genericCandidate edge))+    )+    [0 .. candidateCount - 1]+  (flips, maxDepth) <-+    drainLegalization+      @'ProbeOff+      mutable+      operation+      candidateCount+      noStarVertex+      (CavityRepair cavityFloor)+  addCounter operation CounterEdgeFlips flips+  maxCounter operation CounterLegalizationMaxStack maxDepth++legalizeScratch :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s ()+legalizeScratch mutable operation vertex candidateCount = do+  top <- seedStarScratch operation 0 candidateCount+  (flips, maxDepth) <- drainLegalization @p mutable operation top vertex ValidMesh+  addCounter operation CounterEdgeFlips flips+  maxCounter operation CounterLegalizationMaxStack maxDepth
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Normalize.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | The normalization procedure of the flip rewrite system.+module Moonlight.Triangulation.Internal.DcelOperations.Normalize+  ( drainLegalization+  ) where++import Control.Monad (when)+import Control.Monad.ST (ST)+import Data.Bits ((.&.), shiftR)+import Data.STRef (readSTRef)+import qualified Data.Vector.Unboxed.Mutable as MUV+import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena+  ( genericCandidate+  , growLegalizationArena+  , starCandidate+  )+import Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite (applyFlip)+import Moonlight.Triangulation.Internal.DcelOperations.FlipRule+  ( LegalizationLaw (..)+  , diagonalFires+  )+import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex)+import Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel (..)+  , readConstraint+  , readFace+  , readNext+  , readOrigin+  , readPointX+  , readPointY+  , readPrevious+  )+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , legalizationArena+  , storeLegalizationArena+  )+import Moonlight.Triangulation.Internal.PackedIndex (packIndex)+import Moonlight.Triangulation.Internal.Probe (KnownProbe (..))++-- | The normalization procedure of a confluent terminating rewrite system, and+-- one canonical legalization engine because a normalization procedure is what+-- it is.+--+-- The objects are the triangulations of a fixed point set. The single rule is+-- the Lawson flip: a locally illegal diagonal is replaced by the other+-- diagonal of its quadrilateral. A normal form is a mesh with no illegal+-- diagonal left to fire on.+--+-- /Termination/ is by the lifted-paraboloid potential. Send each point to+-- @(x, y, x² + y²)@ and read a triangulation as a piecewise-linear surface+-- over the point set; @illegalDiagonal@ is exactly the test that the flip+-- lowers that surface, so every rewrite strictly decreases it, and a finite+-- point set has finitely many triangulations. Exact cocircularity is the one+-- case where the surface does not move — the four lifted points are coplanar+-- and both diagonals give the same surface — so there the potential is the+-- diagonal's own key order, and the rule fires only downward in it. Without+-- that tie-break a cocircular quadrilateral flips forever.+--+-- /Confluence/ is Delaunay's theorem, in its strong form: a triangulation with+-- no locally illegal diagonal is globally Delaunay. Local normality is thus+-- global normality, the normal form is unique, and every rewrite order reaches+-- it. That is what licenses the arena below to be a LIFO stack rather than a+-- priority queue, and it is why callers may seed it in whatever order is+-- cheapest to produce — the fan first, or the hull turns first, or both+-- interleaved — without any of them changing the mesh that comes out.+--+-- All callers differ only in how they seed the arena; topology mutation and+-- propagation have exactly one owner.+-- The stack top, the maximum top, and the flip count are strict loop+-- variables, returned once when the drain finishes — the mesh reports nothing+-- per candidate, and 'applyFlip' reports nothing at all. The phantom+-- 'KnownProbe' parameter counts popped candidates for the instrumented lane+-- and is erased everywhere else.+--+-- A popped candidate is read once. Turning it against the star vertex, judging+-- it, and rewriting it are three questions about the same two half-edge+-- records, and the apex the turn looks for is the apex the judgement needs, so+-- one pass over the quadrilateral answers all three.+drainLegalization+  :: forall p s vertex directed undirected face+   . KnownProbe p+  => MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> LegalizationLaw+  -> ST s (Int, Int)+drainLegalization mutable operation seededTop starVertex law = do+  -- No constraint can appear during a drain, so a mesh holding none at entry+  -- never needs the per-candidate protection read.+  constrained <- readSTRef (mdConstraintCount mutable)+  initialArena <- legalizationArena operation+  -- A star candidate is turned so that the inserted vertex is the apex+  -- opposite the diagonal, so that apex is the same vertex on every star+  -- candidate the drain pops and its two coordinates are read once here+  -- instead of once per candidate.+  starX <- if starVertex < 0 then pure 0 else readPointX mutable starVertex+  starY <- if starVertex < 0 then pure 0 else readPointY mutable starVertex+  let !guarded = constrained /= 0+      -- Everything the cavity fan did not create is pinned. The border loop's+      -- legality is already decided by the outside triangle it keeps, and+      -- testing it against a neighbourhood that is still inverted could only+      -- produce a spurious verdict. 'ValidMesh' pins nothing, which is the+      -- floor no undirected index falls below.+      !floorPair = case law of+        ValidMesh -> 0+        CavityRepair floorEdge -> floorEdge++      loop !arena !top !maxTop !flips !candidates+        | top <= 0 = pure (flips, maxTop, candidates, arena)+        | otherwise = do+            let !nextTop = top - 1+            packedWord <- MUV.unsafeRead arena nextTop+            let !packed = fromIntegral packedWord :: Int+                !rawEdge = packed `shiftR` 1+                !isStar = packed .&. 1 == 0+            eligible <-+              if rawEdge `shiftR` 1 < floorPair+                then pure False+                else if guarded then not <$> readConstraint mutable rawEdge else pure True+            if not eligible+              then loop arena nextTop maxTop flips (probeBump @p candidates)+              else do+                let !rawTwin = reverseIndex rawEdge+                rawFace <- readFace mutable rawEdge+                rawTwinFace <- readFace mutable rawTwin+                if rawFace == 0 || rawTwinFace == 0+                  then loop arena nextTop maxTop flips (probeBump @p candidates)+                  else do+                    rawBefore <- readPrevious mutable rawEdge+                    rawTwinBefore <- readPrevious mutable rawTwin+                    rawApex <- readOrigin mutable rawBefore+                    rawTwinApex <- readOrigin mutable rawTwinBefore+                    -- A star candidate names an undirected edge and has to be+                    -- turned so the inserted vertex is the apex opposite it; a+                    -- generic one already names the direction to test. Both+                    -- want the same two apexes, so the one read that settles+                    -- the turn is also the one that supplies the quadrilateral.+                    let !turned = isStar && rawApex /= starVertex+                    if turned && rawTwinApex /= starVertex+                      then loop arena nextTop maxTop flips (probeBump @p candidates)+                      else do+                        let !edge = if turned then rawTwin else rawEdge+                            !twin = if turned then rawEdge else rawTwin+                            !leftFace = if turned then rawTwinFace else rawFace+                            !rightFace = if turned then rawFace else rawTwinFace+                            !edgePrevious = if turned then rawTwinBefore else rawBefore+                            !twinPrevious = if turned then rawBefore else rawTwinBefore+                            !c = if turned then rawTwinApex else rawApex+                            !d = if turned then rawApex else rawTwinApex+                        a <- readOrigin mutable edge+                        b <- readOrigin mutable twin+                        ax <- readPointX mutable a+                        ay <- readPointY mutable a+                        bx <- readPointX mutable b+                        by <- readPointY mutable b+                        cx <- if isStar then pure starX else readPointX mutable c+                        cy <- if isStar then pure starY else readPointY mutable c+                        dx <- readPointX mutable d+                        dy <- readPointY mutable d+                        if not (diagonalFires law ax ay bx by cx cy dx dy)+                          then loop arena nextTop maxTop flips (probeBump @p candidates)+                          else do+                            -- The neighbourhood is complete before the rewrite+                            -- consumes it, and the pushes carry the same edges+                            -- in the same order they always did.+                            edgeNext <- readNext mutable edge+                            twinNext <- readNext mutable twin+                            applyFlip+                              mutable+                              edge+                              twin+                              edgeNext+                              edgePrevious+                              twinNext+                              twinPrevious+                              leftFace+                              rightFace+                              a+                              b+                              c+                              d+                            if isStar+                              then do+                                let !addedTop = nextTop + 2+                                grown <- growLegalizationArena arena addedTop+                                MUV.unsafeWrite grown nextTop (packIndex (starCandidate twinPrevious))+                                MUV.unsafeWrite grown (nextTop + 1) (packIndex (starCandidate twinNext))+                                loop+                                  grown+                                  addedTop+                                  (max maxTop addedTop)+                                  (flips + 1)+                                  (probeBump @p candidates)+                              else do+                                let !addedTop = nextTop + 4+                                grown <- growLegalizationArena arena addedTop+                                MUV.unsafeWrite grown nextTop (packIndex (genericCandidate edgeNext))+                                MUV.unsafeWrite grown (nextTop + 1) (packIndex (genericCandidate edgePrevious))+                                MUV.unsafeWrite grown (nextTop + 2) (packIndex (genericCandidate twinNext))+                                MUV.unsafeWrite grown (nextTop + 3) (packIndex (genericCandidate twinPrevious))+                                loop+                                  grown+                                  addedTop+                                  (max maxTop addedTop)+                                  (flips + 1)+                                  (probeBump @p candidates)+  (flips, maxTop, candidates, finalArena) <-+    loop initialArena seededTop seededTop 0 (probeZero @p)+  when (MUV.length finalArena /= MUV.length initialArena) $+    storeLegalizationArena operation finalArena+  probeCharge @p operation CounterDiagLegalizationCandidates candidates+  pure (flips, maxTop)+{-# INLINE drainLegalization #-}
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Subdivide.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Insertion into an existing element: face split and edge split.+module Moonlight.Triangulation.Internal.DcelOperations.Subdivide+  ( insertIntoFace+  , insertOnEdge+  ) where++import Control.Monad (unless, when)+import Control.Monad.ST (ST)+import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeScratch)+import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex)+import Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel+  , addEdgeBlock+  , addFaceBlock+  , ensureCellCapacity+  , faceEdges+  , linkEdges+  , markConnected+  , payloadsPristine+  , readConstraint+  , readFace+  , readNext+  , readOrigin+  , readPrevious+  , resetEdgeData+  , resetFaceData+  , setConstraint+  , setCycle3+  , writeFace+  , writeFaceEdge+  , writeOrigin+  , writeVertexOut+  )+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , writeScratch+  )+import Moonlight.Triangulation.Internal.Probe (KnownProbe)+import Moonlight.Triangulation.Internal.Types (BuildError)++insertIntoFace :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())+insertIntoFace mutable operation face vertex = do+  capacity <- ensureCellCapacity mutable 3 2+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> do+      insertIntoFaceWithCapacity @p mutable operation face vertex+      pure (Right ())++insertIntoFaceWithCapacity :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s ()+insertIntoFaceWithCapacity mutable operation face vertex = do+  (eAB, eBC, eCA) <- faceEdges mutable face+  a <- readOrigin mutable eAB+  b <- readOrigin mutable eBC+  c <- readOrigin mutable eCA+  edgeBase <- addEdgeBlock mutable 3+  let !eAV = edgeBase+      !eVA = edgeBase + 1+      !eBV = edgeBase + 2+      !eVB = edgeBase + 3+      !eCV = edgeBase + 4+      !eVC = edgeBase + 5+  writeOrigin mutable eAV a+  writeOrigin mutable eVA vertex+  writeOrigin mutable eBV b+  writeOrigin mutable eVB vertex+  writeOrigin mutable eCV c+  writeOrigin mutable eVC vertex+  faceBase <- addFaceBlock mutable 2+  setCycle3 mutable face eAB eBV eVA+  setCycle3 mutable faceBase eBC eCV eVB+  setCycle3 mutable (faceBase + 1) eCA eAV eVC+  writeVertexOut mutable a eAB+  writeVertexOut mutable b eBC+  writeVertexOut mutable c eCA+  markConnected mutable vertex eVA+  -- ABC has become ABV; the other two thirds of it are fresh faces. The three+  -- boundary edges keep their endpoints and so keep their labels.+  resetFaceData mutable face+  writeScratch operation 0 eAB+  writeScratch operation 1 eBC+  writeScratch operation 2 eCA+  addCounter operation CounterFaceSplits 1+  legalizeScratch @p mutable operation vertex 3++insertOnEdge :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())+insertOnEdge mutable operation suppliedEdge vertex = do+  suppliedFace <- readFace mutable suppliedEdge+  reverseFace <- readFace mutable (reverseIndex suppliedEdge)+  if suppliedFace == 0 || reverseFace == 0+    then splitBoundaryEdge @p mutable operation suppliedEdge vertex+    else splitInteriorEdge @p mutable operation suppliedEdge vertex++splitInteriorEdge :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())+splitInteriorEdge mutable operation suppliedEdge vertex = do+  capacity <- ensureCellCapacity mutable 3 2+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> do+      splitInteriorEdgeWithCapacity @p mutable operation suppliedEdge vertex+      pure (Right ())++splitInteriorEdgeWithCapacity :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s ()+splitInteriorEdgeWithCapacity mutable operation suppliedEdge vertex = do+  protected <- readConstraint mutable suppliedEdge+  suppliedFace <- readFace mutable suppliedEdge+  let !edge = if suppliedFace == 0 then reverseIndex suppliedEdge else suppliedEdge+      !reverseEdgeEdge = reverseIndex edge+  leftFace <- readFace mutable edge+  rightFace <- readFace mutable reverseEdgeEdge+  eBC <- readNext mutable edge+  eCA <- readPrevious mutable edge+  eAD <- readNext mutable reverseEdgeEdge+  eDB <- readPrevious mutable reverseEdgeEdge+  a <- readOrigin mutable edge+  b <- readOrigin mutable reverseEdgeEdge+  c <- readOrigin mutable eCA+  d <- readOrigin mutable eDB+  writeOrigin mutable reverseEdgeEdge vertex+  edgeBase <- addEdgeBlock mutable 3+  let !eVB = edgeBase+      !eBV = edgeBase + 1+      !eVC = edgeBase + 2+      !eCV = edgeBase + 3+      !eVD = edgeBase + 4+      !eDV = edgeBase + 5+  writeOrigin mutable eVB vertex+  writeOrigin mutable eBV b+  writeOrigin mutable eVC vertex+  writeOrigin mutable eCV c+  writeOrigin mutable eVD vertex+  writeOrigin mutable eDV d+  faceBase <- addFaceBlock mutable 2+  setCycle3 mutable leftFace edge eVC eCA+  setCycle3 mutable faceBase eVB eBC eCV+  setCycle3 mutable rightFace eBV eVD eDB+  setCycle3 mutable (faceBase + 1) reverseEdgeEdge eAD eDV+  writeVertexOut mutable a edge+  writeVertexOut mutable b eBC+  writeVertexOut mutable c eCA+  writeVertexOut mutable d eDB+  markConnected mutable vertex reverseEdgeEdge+  -- AB became AV, and both incident triangles lost a corner to the new vertex.+  unless (payloadsPristine mutable) $ do+    resetEdgeData mutable (edge `quot` 2)+    resetFaceData mutable leftFace+    resetFaceData mutable rightFace+  when protected $ do+    _ <- setConstraint mutable eVB+    pure ()+  writeScratch operation 0 eCA+  writeScratch operation 1 eBC+  writeScratch operation 2 eDB+  writeScratch operation 3 eAD+  addCounter operation CounterInteriorEdgeSplits 1+  legalizeScratch @p mutable operation vertex 4++splitBoundaryEdge :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())+splitBoundaryEdge mutable operation suppliedEdge vertex = do+  capacity <- ensureCellCapacity mutable 2 1+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> do+      splitBoundaryEdgeWithCapacity @p mutable operation suppliedEdge vertex+      pure (Right ())++splitBoundaryEdgeWithCapacity :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s ()+splitBoundaryEdgeWithCapacity mutable operation suppliedEdge vertex = do+  protected <- readConstraint mutable suppliedEdge+  suppliedFace <- readFace mutable suppliedEdge+  let !edge = if suppliedFace == 0 then reverseIndex suppliedEdge else suppliedEdge+      !outerEdge = reverseIndex edge+  innerFace <- readFace mutable edge+  eBC <- readNext mutable edge+  eCA <- readPrevious mutable edge+  a <- readOrigin mutable edge+  b <- readOrigin mutable outerEdge+  c <- readOrigin mutable eCA+  oldOuterPrevious <- readPrevious mutable outerEdge+  oldOuterNext <- readNext mutable outerEdge+  writeOrigin mutable outerEdge vertex+  edgeBase <- addEdgeBlock mutable 2+  let !eVB = edgeBase+      !eBV = edgeBase + 1+      !eVC = edgeBase + 2+      !eCV = edgeBase + 3+  writeOrigin mutable eVB vertex+  writeOrigin mutable eBV b+  writeOrigin mutable eVC vertex+  writeOrigin mutable eCV c+  newFace <- addFaceBlock mutable 1+  setCycle3 mutable innerFace edge eVC eCA+  setCycle3 mutable newFace eVB eBC eCV+  writeFace mutable outerEdge 0+  writeFace mutable eBV 0+  linkEdges mutable oldOuterPrevious eBV+  linkEdges mutable eBV outerEdge+  linkEdges mutable outerEdge oldOuterNext+  writeFaceEdge mutable 0 outerEdge+  writeVertexOut mutable a edge+  writeVertexOut mutable b eBC+  writeVertexOut mutable c eCA+  markConnected mutable vertex eVB+  -- AB became AV and the one interior triangle lost a corner. The outer face+  -- is not an element and keeps nothing to lose.+  unless (payloadsPristine mutable) $ do+    resetEdgeData mutable (edge `quot` 2)+    resetFaceData mutable innerFace+  when protected $ do+    _ <- setConstraint mutable eVB+    pure ()+  writeScratch operation 0 eCA+  writeScratch operation 1 eBC+  addCounter operation CounterBoundaryEdgeSplits 1+  legalizeScratch @p mutable operation vertex 2
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Twin.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | The pairing involution on half-edge indices.+module Moonlight.Triangulation.Internal.DcelOperations.Twin+  ( reverseIndex+  ) where++import Data.Bits (xor)++reverseIndex :: Int -> Int+reverseIndex edge = edge `xor` 1+{-# INLINE reverseIndex #-}
+ src-dcel/Moonlight/Triangulation/Internal/FaceProbe.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE BangPatterns #-}++module Moonlight.Triangulation.Internal.FaceProbe+  ( BoundaryProbe (..)+  , probeBoundary+  ) where++import Moonlight.Triangulation.Math (onClosedSegment, orient2d)+import Moonlight.Triangulation.Types (Point)++-- | Classification of one oriented boundary of a triangular face. A+-- 'BoundaryCrossing' carries the half-edge whose incident face is the+-- destination of the walk; consumers must not reverse it again.+data BoundaryProbe edge vertex+  = BoundaryClear+  | BoundaryOnVertex !vertex+  | BoundaryOnEdge !edge+  | BoundaryCrossing !edge+  deriving stock (Eq, Ord, Show)++probeBoundary+  :: (edge -> edge)+  -> Point+  -> edge+  -> vertex+  -> Point+  -> vertex+  -> Point+  -> BoundaryProbe edge vertex+probeBoundary reverseBoundary query edge fromVertex from toVertex to+  | query == from = BoundaryOnVertex fromVertex+  | query == to = BoundaryOnVertex toVertex+  | otherwise =+      case orient2d from to query of+        EQ+          | onClosedSegment from to query -> BoundaryOnEdge edge+          | otherwise -> BoundaryClear+        LT -> BoundaryCrossing (reverseBoundary edge)+        GT -> BoundaryClear+{-# INLINE probeBoundary #-}
+ src-dcel/Moonlight/Triangulation/Internal/Mutable.hs view
@@ -0,0 +1,1060 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++module Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel (..)+  , newMutableDcel+  , thawTriangulation+  , thawTriangulationDense+  , freezeTriangulation+  , pointCapacity+  , halfEdgeCapacity+  , pointCount+  , connectedCount+  , directedEdgeCount+  , faceCount+  , pointAt+  , lookupPointVertex+  , activatePointIndex+  , activateBatchPointIndex+  , discardBatchPointIndex+  , identityIndexActive+  , readPointX+  , readPointY+  , writePoint+  , vertexDataAt+  , writeVertexData+  , payloadsPristine+  , resetEdgeData+  , resetFaceData+  , edgeOriginPoint+  , appendVertex+  , appendVertexCoordinates+  , ensurePointCapacity+  , markConnected+  , isConnected+  , addEdge+  , addEdgeBlock+  , addFace+  , addFaceBlock+  , ensureCellCapacity+  , truncatePoints+  , truncateDirectedEdges+  , truncateFaces+  , swapRemoveUndirectedEdge+  , swapRemoveFace+  , swapRemoveVertex+  , linkEdges+  , setCycle3+  , faceEdges+  , readOrigin+  , writeOrigin+  , readNext+  , writeNext+  , readPrevious+  , writePrevious+  , readFace+  , writeFace+  , readVertexOut+  , writeVertexOut+  , readFaceEdge+  , writeFaceEdge+  , readConstraint+  , setConstraint+  , clearConstraint+  ) where++import Control.Monad (foldM, forM_, unless, when)+import Data.Bits (xor)+import Control.Monad.ST (ST)+import qualified Data.IntSet as IntSet+import Data.STRef+  ( STRef+  , modifySTRef'+  , newSTRef+  , readSTRef+  , writeSTRef+  )+import Data.Word (Word8, Word32)+import Moonlight.Triangulation.Handles.HandleDefs+  ( DirectedEdgeId (..)+  , FaceId (..)+  , UndirectedEdgeId (..)+  , VertexId (..)+  )+import Moonlight.Triangulation.Internal.BoxedPaged+import Moonlight.Triangulation.Internal.PackedIndex (noIndex, packIndex)+import Moonlight.Triangulation.Internal.Paged+import Moonlight.Triangulation.Internal.PointIndex+  ( MutablePointIndex+  , MutablePointIndexUpdate (..)+  , PointIndex+  , buildPointIndex+  , emptyPointIndex+  , insertPointIndex+  , lookupMutablePoint+  , newMutablePointIndex+  , pointIndexCandidates+  , relocateMutablePoint+  , relocatePointIndex+  , removeMutablePoint+  , removePointIndex+  , seedMutablePointIndex+  )+import Moonlight.Triangulation.Math (canonicalPoint)+import Moonlight.Triangulation.Internal.Representation (Triangulation (..))+import Moonlight.Triangulation.Internal.Types (BuildError (..), ElementDefaults (..), Point (..))+-- | Dormant carries the inherited index through mutations as unforced pure+-- updates; persistent Active is the same index forced and kept strict because+-- a singleton lookup already proved someone is asking. Batch Active is the+-- existing open-addressed owner scoped to one dense identity program. Missing+-- means publication owes a lazy whole-mesh rebuild to any eventual asker.+data MutablePointIndexState s+  = DormantPointIndex PointIndex+  | ActivePersistentPointIndex !PointIndex+  | ActiveBatchPointIndex !(MutablePointIndex s)+  | MissingPointIndex++data MutableDcel s vertex directed undirected face = MutableDcel+  { mdPointX :: !(MutablePaged s Double)+  , mdPointY :: !(MutablePaged s Double)+  , mdPointIndex :: !(STRef s (MutablePointIndexState s))+  , mdVertexOut :: !(MutablePaged s Word32)+  , mdVertexData :: !(MutableBoxedPaged s vertex)+  , mdNewConnected :: !(MutablePaged s Word8)+  , mdRecycledNew :: !(STRef s IntSet.IntSet)+  , mdHalfTopology :: !(MutablePaged s Word32)+  , mdDirectedData :: !(MutableBoxedPaged s directed)+  , mdUndirectedData :: !(MutableBoxedPaged s undirected)+  , mdConstraint :: !(MutablePaged s Word8)+  , mdFaceEdge :: !(MutablePaged s Word32)+  , mdFaceData :: !(MutableBoxedPaged s face)+  , mdPointCount :: !(STRef s Int)+  , mdConnectedCount :: !(STRef s Int)+  , mdHalfCount :: !(STRef s Int)+  , mdFaceCount :: !(STRef s Int)+  , mdConstraintCount :: !(STRef s Int)+  , mdConstraintEdges :: !(STRef s IntSet.IntSet)+  , mdLastFace :: !(STRef s Int)+  , mdInitialPointCount :: {-# UNPACK #-} !Int+  , mdPointCapacity :: {-# UNPACK #-} !Int+  , mdHalfCapacity :: {-# UNPACK #-} !Int+  , mdFaceCapacity :: {-# UNPACK #-} !Int+  , -- | No element payload plane held a materialized page at thaw. Nothing+    -- inside a transaction can write one: the three planes are written only+    -- through the persistent setters, which run outside one, and both the+    -- rewrite reset and the swap-compaction relocation below are no-ops while+    -- this holds. So it is constant for the transaction's whole life, and a+    -- rewrite decides in a predictable branch that it has no label to move.+    mdPayloadsPristine :: !Bool+  , mdElementDefaults :: !(ElementDefaults directed undirected face)+  }++newMutableDcel :: ElementDefaults directed undirected face -> Int -> ST s (MutableDcel s vertex directed undirected face)+newMutableDcel defaults maximumVertices = newMutableDcelFrom DenseTransaction defaults maximumVertices Nothing++-- | Open a local-edit transaction: copy-on-write pages, publication+-- proportional to dirtied pages. The section for singleton persistent verbs.+thawTriangulation+  :: Int+  -> Triangulation mode vertex directed undirected face+  -> ST s (MutableDcel s vertex directed undirected face)+thawTriangulation maximumVertices triangulation =+  newMutableDcelFrom+    LocalTransaction+    (triElementDefaults triangulation)+    maximumVertices+    (Just triangulation)++-- | Open a batch transaction: one dense copy up front, flat reads and writes+-- thereafter. The section for sessions and every other many-edit operation.+thawTriangulationDense+  :: Int+  -> Triangulation mode vertex directed undirected face+  -> ST s (MutableDcel s vertex directed undirected face)+thawTriangulationDense maximumVertices triangulation =+  newMutableDcelFrom+    DenseTransaction+    (triElementDefaults triangulation)+    maximumVertices+    (Just triangulation)++newMutableDcelFrom+  :: TransactionShape+  -> ElementDefaults directed undirected face+  -> Int+  -> Maybe (Triangulation mode vertex directed undirected face)+  -> ST s (MutableDcel s vertex directed undirected face)+newMutableDcelFrom shape mdElementDefaults maximumVertices source = do+  let !existingVertices = maybe 0 (pagedLength . triPointX) source+      !existingHalfEdges = maybe 0 ((`quot` 4) . pagedLength . triHalfTopology) source+      !existingFaces = maybe 1 (pagedLength . triFaceEdge) source+      !growthVertexCapacity = max 1 (max existingVertices maximumVertices)+      !vertexCapacity = growthVertexCapacity+      -- Euler bounds a planar triangulation's LIVE cells at 3n - 6 undirected+      -- edges and 2n - 4 faces, but these arenas are append-only with no free+      -- list, so what must be reserved is CUMULATIVE allocation, not the live+      -- maximum. Measured: a complete 5-vertex triangulation (9 edges, 6 faces,+      -- V - E + F = 2) requests a seventh face without gaining a vertex, so+      -- some operation abandons a slot it will never reclaim. The slack below+      -- is headroom over that leakage, not a bound derived from it.+      !halfCapacity = max existingHalfEdges (max 2 (8 * growthVertexCapacity + 16))+      !faceCapacity = max existingFaces (max 1 (3 * growthVertexCapacity + 8))+      vertexDataBase = maybe (emptyBoxedPaged Nothing) triVertexData source+      directedDataBase = maybe (emptyBoxedPaged (Just (defaultDirectedEdgeData mdElementDefaults))) triDirectedData source+      undirectedDataBase = maybe (emptyBoxedPaged (Just (defaultUndirectedEdgeData mdElementDefaults))) triUndirectedData source+      faceDataBase = maybe (emptyBoxedPaged (Just (defaultFaceData mdElementDefaults))) triFaceData source+      constraintBaseCount = maybe 0 triConstraintCount source+      constraintBaseEdges = maybe IntSet.empty triConstraintEdges source+      pointIndexBase = maybe MissingPointIndex (DormantPointIndex . triPointIndex) source+  mdPointX <- maybe (newLocalMutablePaged vertexCapacity) (thawPagedShaped shape vertexCapacity . triPointX) source+  mdPointY <- maybe (newLocalMutablePaged vertexCapacity) (thawPagedShaped shape vertexCapacity . triPointY) source+  mdVertexOut <- maybe (newLocalMutablePaged vertexCapacity) (thawPagedShaped shape vertexCapacity . triVertexOut) source+  mdVertexData <- thawBoxedPaged vertexDataBase+  mdNewConnected <- newLocalMutablePaged (vertexCapacity - existingVertices)+  mdRecycledNew <- newSTRef IntSet.empty+  mdHalfTopology <- maybe (newMutablePaged (4 * halfCapacity)) (thawPagedShaped shape (4 * halfCapacity) . triHalfTopology) source+  mdDirectedData <- thawBoxedPaged directedDataBase+  mdUndirectedData <- thawBoxedPaged undirectedDataBase+  mdConstraint <- maybe (newMutablePaged (halfCapacity `quot` 2)) (thawPagedShaped shape (halfCapacity `quot` 2) . triConstraint) source+  mdFaceEdge <-+    case source of+      Just triangulation -> thawPagedShaped shape faceCapacity (triFaceEdge triangulation)+      Nothing -> do+        freshFaceEdges <- newLocalMutablePaged faceCapacity+        writePaged freshFaceEdges 0 noIndex+        pure freshFaceEdges+  mdFaceData <- thawBoxedPaged faceDataBase+  mdPointCount <- newSTRef existingVertices+  mdPointIndex <- newSTRef pointIndexBase+  mdConnectedCount <- newSTRef existingVertices+  mdHalfCount <- newSTRef existingHalfEdges+  mdFaceCount <- newSTRef existingFaces+  mdConstraintCount <- newSTRef constraintBaseCount+  mdConstraintEdges <- newSTRef constraintBaseEdges+  mdLastFace <- newSTRef (if existingFaces > 1 then 1 else 0)+  let !mdPayloadsPristine =+        boxedThawPristine mdDirectedData+          && boxedThawPristine mdUndirectedData+          && boxedThawPristine mdFaceData+  pure+    MutableDcel+      { mdInitialPointCount = existingVertices+      , mdPointCapacity = vertexCapacity+      , mdHalfCapacity = halfCapacity+      , mdFaceCapacity = faceCapacity+      , ..+      }++freezeTriangulation :: MutableDcel s vertex directed undirected face -> ST s (Either BuildError (Triangulation mode vertex directed undirected face))+freezeTriangulation MutableDcel+  { mdPointX+  , mdPointY+  , mdPointIndex+  , mdVertexOut+  , mdVertexData+  , mdHalfTopology+  , mdDirectedData+  , mdUndirectedData+  , mdConstraint+  , mdFaceEdge+  , mdFaceData+  , mdPointCount+  , mdHalfCount+  , mdFaceCount+  , mdConstraintCount+  , mdConstraintEdges+  , mdElementDefaults+  } = do+    vertices <- readSTRef mdPointCount+    halfEdges <- readSTRef mdHalfCount+    faces <- readSTRef mdFaceCount+    triConstraintCount <- readSTRef mdConstraintCount+    triConstraintEdges <- readSTRef mdConstraintEdges+    vertexDataOutcome <- freezeBoxedPaged vertices mdVertexData+    directedDataOutcome <- freezeBoxedPaged halfEdges mdDirectedData+    undirectedDataOutcome <- freezeBoxedPaged (halfEdges `quot` 2) mdUndirectedData+    faceDataOutcome <- freezeBoxedPaged faces mdFaceData+    case+        (,,,)+          <$> vertexDataOutcome+          <*> directedDataOutcome+          <*> undirectedDataOutcome+          <*> faceDataOutcome+      of+        Left obstruction -> pure (Left (PayloadStorageFailure obstruction))+        Right (triVertexData, triDirectedData, triUndirectedData, triFaceData) -> do+          triPointX <- freezePaged vertices mdPointX+          triPointY <- freezePaged vertices mdPointY+          pointIndexState <- readSTRef mdPointIndex+          let triPointIndex =+                case pointIndexState of+                  DormantPointIndex residentIndex -> residentIndex+                  ActivePersistentPointIndex residentIndex -> residentIndex+                  ActiveBatchPointIndex _ -> buildPointIndex triPointX triPointY+                  MissingPointIndex -> buildPointIndex triPointX triPointY+          triVertexOut <- freezePaged vertices mdVertexOut+          triHalfTopology <- freezePaged (4 * halfEdges) mdHalfTopology+          triConstraint <- freezePaged (halfEdges `quot` 2) mdConstraint+          triFaceEdge <- freezePaged faces mdFaceEdge+          let triElementDefaults = mdElementDefaults+          pure (Right Triangulation{..})++pointCapacity :: MutableDcel s vertex directed undirected face -> Int+pointCapacity = mdPointCapacity+{-# INLINE pointCapacity #-}++halfEdgeCapacity :: MutableDcel s vertex directed undirected face -> Int+halfEdgeCapacity = mdHalfCapacity+{-# INLINE halfEdgeCapacity #-}++pointCount :: MutableDcel s vertex directed undirected face -> ST s Int+pointCount = readSTRef . mdPointCount+{-# INLINE pointCount #-}++connectedCount :: MutableDcel s vertex directed undirected face -> ST s Int+connectedCount = readSTRef . mdConnectedCount+{-# INLINE connectedCount #-}++directedEdgeCount :: MutableDcel s vertex directed undirected face -> ST s Int+directedEdgeCount = readSTRef . mdHalfCount+{-# INLINE directedEdgeCount #-}++faceCount :: MutableDcel s vertex directed undirected face -> ST s Int+faceCount = readSTRef . mdFaceCount+{-# INLINE faceCount #-}++pointAt :: MutableDcel s vertex directed undirected face -> Int -> ST s (Point)+pointAt MutableDcel{mdPointX, mdPointY} index =+  Point <$> readPaged mdPointX index <*> readPaged mdPointY index+{-# INLINE pointAt #-}++-- | Resolve a canonical site through the derived handle index, confirming+-- every hash candidate against the authoritative coordinate planes. A mesh+-- created from scratch derives the index only if a caller actually asks; a+-- thawed published mesh inherits its structurally shared index.+lookupPointVertex+  :: MutableDcel s vertex directed undirected face+  -> Point+  -> ST s (Maybe Int)+lookupPointVertex mutable@MutableDcel{mdPointIndex} rawPoint = do+  indexState <- readSTRef mdPointIndex+  case canonicalPoint rawPoint of+    Point x y ->+      case indexState of+        ActiveBatchPointIndex table ->+          lookupMutablePoint table (readPointX mutable) (readPointY mutable) x y+        ActivePersistentPointIndex residentIndex ->+          resolvePersistent x y residentIndex+        DormantPointIndex residentIndex -> do+          writeSTRef mdPointIndex (ActivePersistentPointIndex residentIndex)+          resolvePersistent x y residentIndex+        MissingPointIndex -> do+          derived <- deriveMutablePointIndex mutable+          writeSTRef mdPointIndex (ActivePersistentPointIndex derived)+          resolvePersistent x y derived+ where+  resolvePersistent x y pointIndex =+    foldM+      (confirmCandidate mutable x y)+      Nothing+      (pointIndexCandidates x y pointIndex)++-- | Whether the transaction has already committed to incremental identity+-- transport. Answering does not force a dormant index's lazy rebuild, which+-- is the point: a per-question caller must not buy a whole-mesh build.+identityIndexActive :: MutableDcel s vertex directed undirected face -> ST s Bool+identityIndexActive MutableDcel{mdPointIndex} = do+  indexState <- readSTRef mdPointIndex+  pure $ case indexState of+    ActivePersistentPointIndex _ -> True+    ActiveBatchPointIndex _ -> True+    _ -> False+{-# INLINE identityIndexActive #-}++-- | Declare that a singleton handle-keyed rewrite must transport the resident+-- immutable identity section strictly. Dense point-keyed removal uses+-- 'activateBatchPointIndex' instead, so it neither forces nor incrementally+-- allocates the published 'PointIndex'.+activatePointIndex+  :: MutableDcel s vertex directed undirected face+  -> ST s ()+activatePointIndex mutable@MutableDcel{mdPointIndex} = do+  indexState <- readSTRef mdPointIndex+  case indexState of+    ActivePersistentPointIndex _ -> pure ()+    ActiveBatchPointIndex _ -> pure ()+    DormantPointIndex residentIndex ->+      writeSTRef mdPointIndex (ActivePersistentPointIndex residentIndex)+    MissingPointIndex -> do+      derived <- deriveMutablePointIndex mutable+      writeSTRef mdPointIndex (ActivePersistentPointIndex derived)++-- | Open an identity section for one dense removal program. The table derives+-- only from coordinate authority, and its extent is deliberately narrower+-- than the surrounding session: publication returns to the lazy immutable+-- derivation instead of retaining a second mutable identity owner.+activateBatchPointIndex+  :: MutableDcel s vertex directed undirected face+  -> ST s (Either BuildError ())+activateBatchPointIndex mutable@MutableDcel{mdPointIndex} = do+  vertices <- pointCount mutable+  table <- newMutablePointIndex vertices+  seeded <-+    seedMutablePointIndex+      table+      vertices+      (readPointX mutable)+      (readPointY mutable)+  case seeded of+    Left failure -> pure (Left failure)+    Right () -> do+      writeSTRef mdPointIndex (ActiveBatchPointIndex table)+      pure (Right ())+-- | Close the batch-local identity section after its removal program. Its+-- contents cannot escape @ST@; marking the cache missing makes freeze glue a+-- lazy immutable derivation from the final coordinate arenas.+discardBatchPointIndex+  :: MutableDcel s vertex directed undirected face+  -> ST s ()+discardBatchPointIndex MutableDcel{mdPointIndex} =+  modifySTRef'+    mdPointIndex+    (\indexState ->+       case indexState of+         ActiveBatchPointIndex _ -> MissingPointIndex+         retained -> retained+    )++deriveMutablePointIndex+  :: MutableDcel s vertex directed undirected face+  -> ST s PointIndex+deriveMutablePointIndex mutable = do+  vertices <- pointCount mutable+  foldM insertResident emptyPointIndex [0 .. vertices - 1]+ where+  insertResident pointIndex vertex = do+    x <- readPointX mutable vertex+    y <- readPointY mutable vertex+    pure (insertPointIndex x y vertex pointIndex)++confirmCandidate+  :: MutableDcel s vertex directed undirected face+  -> Double+  -> Double+  -> Maybe Int+  -> Int+  -> ST s (Maybe Int)+confirmCandidate _ _ _ resident@(Just _) _ = pure resident+confirmCandidate mutable x y Nothing candidate = do+  heldX <- readPointX mutable candidate+  heldY <- readPointY mutable candidate+  pure (if heldX == x && heldY == y then Just candidate else Nothing)+{-# INLINE confirmCandidate #-}++-- | Read one stored coordinate without building a t'Point'. Coordinates are+-- the authoritative state owned by 'mdPointX'/'mdPointY'; the t'Point'+-- constructor is the cold accessor's packaging, and the construction kernel+-- reads these arenas directly so a specialized sweep never boxes one.+readPointX :: MutableDcel s vertex directed undirected face -> Int -> ST s Double+readPointX MutableDcel{mdPointX} index = readPaged mdPointX index+{-# INLINE readPointX #-}++readPointY :: MutableDcel s vertex directed undirected face -> Int -> ST s Double+readPointY MutableDcel{mdPointY} index = readPaged mdPointY index+{-# INLINE readPointY #-}++writePoint :: MutableDcel s vertex directed undirected face -> Int -> Point -> ST s ()+writePoint MutableDcel{mdPointX, mdPointY} index rawPoint =+  case canonicalPoint rawPoint of+    Point x y -> do+      writePaged mdPointX index x+      writePaged mdPointY index y+{-# INLINE writePoint #-}++vertexDataAt :: MutableDcel s vertex directed undirected face -> Int -> ST s vertex+vertexDataAt MutableDcel{mdVertexData} = readBoxedPaged mdVertexData+{-# INLINE vertexDataAt #-}++writeVertexData :: MutableDcel s vertex directed undirected face -> Int -> vertex -> ST s ()+writeVertexData MutableDcel{mdVertexData} = writeBoxedPaged mdVertexData+{-# INLINE writeVertexData #-}++-- | Whether no element payload plane can be holding anything. Constant for the+-- transaction: see 'mdPayloadsPristine'. A rewrite site that performs several+-- resets together tests this once rather than paying the test inside each.+payloadsPristine :: MutableDcel s vertex directed undirected face -> Bool+payloadsPristine = mdPayloadsPristine+{-# INLINE payloadsPristine #-}++-- | Return one undirected edge and both its half-edges to the element+-- defaults. A payload labels the element occupying a slot, and an element is+-- its geometry: a rewrite that gives a slot new endpoints has put a different+-- edge there, and the label the old one carried does not describe it. Leaving+-- it would also make the payload plane depend on the flip order that reached+-- the normal form, while the topology does not.+--+-- The constraint flag is deliberately not reset with it. A flag states that a+-- segment of the input is present, and a segment that gets split is still+-- present as its two halves; a payload states what an element is.+resetEdgeData :: MutableDcel s vertex directed undirected face -> Int -> ST s ()+resetEdgeData MutableDcel{mdDirectedData, mdUndirectedData, mdPayloadsPristine, mdElementDefaults} pair =+  unless mdPayloadsPristine $ do+    resetBoxedRange mdDirectedData (defaultDirectedEdgeData mdElementDefaults) (2 * pair) 2+    resetBoxedRange mdUndirectedData (defaultUndirectedEdgeData mdElementDefaults) pair 1+{-# INLINE resetEdgeData #-}++-- | Return one face to the element default. See 'resetEdgeData'.+resetFaceData :: MutableDcel s vertex directed undirected face -> Int -> ST s ()+resetFaceData MutableDcel{mdFaceData, mdPayloadsPristine, mdElementDefaults} face =+  unless mdPayloadsPristine (resetBoxedRange mdFaceData (defaultFaceData mdElementDefaults) face 1)+{-# INLINE resetFaceData #-}++edgeOriginPoint :: MutableDcel s vertex directed undirected face -> Int -> ST s (Point)+edgeOriginPoint mutable edge = readOrigin mutable edge >>= pointAt mutable+{-# INLINE edgeOriginPoint #-}++appendVertex+  :: MutableDcel s vertex directed undirected face+  -> Point+  -> vertex+  -> ST s Int+appendVertex mutable rawPoint vertexData =+  case canonicalPoint rawPoint of+    Point x y -> appendVertexCoordinates mutable x y vertexData+{-# INLINE appendVertex #-}++-- | Append a vertex whose coordinates are already canonical, by components.+-- This is the one owner of the append record; 'appendVertex' is its+-- t'Point'-carrying form for callers holding a point. Raw capacity means the+-- appender initializes every field of the record it exposes.+appendVertexCoordinates+  :: MutableDcel s vertex directed undirected face+  -> Double+  -> Double+  -> vertex+  -> ST s Int+appendVertexCoordinates mutable@MutableDcel{mdPointCount, mdPointX, mdPointY, mdPointIndex, mdNewConnected, mdRecycledNew} x y vertexData = do+  vertex <- readSTRef mdPointCount+  writePaged mdPointX vertex x+  writePaged mdPointY vertex y+  writeVertexData mutable vertex vertexData+  writeVertexOut mutable vertex (-1)+  if vertex >= mdInitialPointCount mutable+    then writePaged mdNewConnected (vertex - mdInitialPointCount mutable) 0+    else modifySTRef' mdRecycledNew (IntSet.insert vertex)+  modifySTRef'+    mdPointIndex+    (\pointIndexState ->+       case pointIndexState of+         ActivePersistentPointIndex pointIndex ->+           ActivePersistentPointIndex (insertPointIndex x y vertex pointIndex)+         -- The batch table is only lawful over the removal subprogram that+         -- opened it. An insertion before that scope is closed invalidates the+         -- derived cache rather than pretending an unregistered handle exists.+         ActiveBatchPointIndex _ -> MissingPointIndex+         -- Transported lazily: the field holds a pure update thunk, so a batch+         -- that never asks an identity question pays one allocation per append,+         -- while a persistent chain that asks every publication forces a+         -- depth-one thunk instead of rebuilding the index over the whole mesh.+         DormantPointIndex pointIndex ->+           DormantPointIndex (insertPointIndex x y vertex pointIndex)+         MissingPointIndex -> MissingPointIndex+    )+  writeSTRef mdPointCount (vertex + 1)+  pure vertex++-- | Check the point arena before a local rewrite materializes vertices. The+-- caller performs this before the first write, so refusal needs no rollback.+ensurePointCapacity+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> ST s (Either BuildError ())+ensurePointCapacity MutableDcel{mdPointCount, mdPointCapacity} additional+  | additional < 0 = pure (Left (CapacityExceeded additional))+  | otherwise = do+      current <- readSTRef mdPointCount+      let !required = current + additional+      pure $+        if required > mdPointCapacity+          then Left (CapacityExceeded required)+          else Right ()+{-# INLINE ensurePointCapacity #-}++markConnected :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+markConnected mutable@MutableDcel{mdInitialPointCount, mdNewConnected, mdRecycledNew, mdConnectedCount} vertex outgoing = do+  if vertex >= mdInitialPointCount+    then do+      let !newVertex = vertex - mdInitialPointCount+      connected <- readPaged mdNewConnected newVertex+      unless (connected /= 0) $ do+        writePaged mdNewConnected newVertex 1+        modifySTRef' mdConnectedCount (+ 1)+    else do+      recycled <- readSTRef mdRecycledNew+      when (IntSet.member vertex recycled) $ do+        writeSTRef mdRecycledNew (IntSet.delete vertex recycled)+        modifySTRef' mdConnectedCount (+ 1)+  writeVertexOut mutable vertex outgoing+{-# INLINE markConnected #-}++isConnected :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool+isConnected MutableDcel{mdInitialPointCount, mdNewConnected, mdRecycledNew} vertex+  | vertex < mdInitialPointCount = IntSet.notMember vertex <$> readSTRef mdRecycledNew+  | otherwise = (/= 0) <$> readPaged mdNewConnected (vertex - mdInitialPointCount)+{-# INLINE isConnected #-}++addEdge :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s (Int, Int)+addEdge mutable from to = do+  base <- addEdgeBlock mutable 1+  writeOrigin mutable base from+  writeOrigin mutable (base + 1) to+  pure (base, base + 1)+{-# INLINE addEdge #-}++-- Each appended pair owns the initialization of its exposed topology and+-- constraint records; reserved capacity remains untouched.+addEdgeBlock :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+addEdgeBlock mutable@MutableDcel{mdHalfCount, mdConstraint} pairs = do+  base <- readSTRef mdHalfCount+  let !required = base + 2 * pairs+      !firstUndirected = base `quot` 2+      !lastUndirected = firstUndirected + pairs - 1+  forM_ [4 * base .. 4 * required - 1] $ \slot ->+    writePaged (mdHalfTopology mutable) slot noIndex+  forM_ [firstUndirected .. lastUndirected] $ \edge -> writePaged mdConstraint edge 0+  writeSTRef mdHalfCount required+  pure base+{-# INLINE addEdgeBlock #-}++addFace :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+addFace mutable anchor = do+  base <- addFaceBlock mutable 1+  writeFaceEdge mutable base anchor+  pure base+{-# INLINE addFace #-}++addFaceBlock :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+addFaceBlock mutable@MutableDcel{mdFaceCount} count = do+  base <- readSTRef mdFaceCount+  let !required = base + count+  mapM_ (\face -> writeFaceEdge mutable face (-1)) [base .. required - 1]+  writeSTRef mdFaceCount required+  pure base+{-# INLINE addFaceBlock #-}++-- | Check the local allocation section before any topology rewrite begins.+-- A refusal leaves every mutable plane untouched, so the enclosing transaction+-- can abandon publication without rollback machinery.+ensureCellCapacity+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> Int+  -> ST s (Either BuildError ())+ensureCellCapacity MutableDcel{mdHalfCount, mdHalfCapacity, mdFaceCount, mdFaceCapacity} additionalPairs additionalFaces+  | additionalPairs < 0 = pure (Left (HalfEdgeCapacityExceeded additionalPairs mdHalfCapacity))+  | additionalFaces < 0 = pure (Left (FaceCapacityExceeded additionalFaces mdFaceCapacity))+  | otherwise = do+      currentHalfEdges <- readSTRef mdHalfCount+      currentFaces <- readSTRef mdFaceCount+      let !requiredHalfEdges = currentHalfEdges + 2 * additionalPairs+          !requiredFaces = currentFaces + additionalFaces+      if requiredHalfEdges > mdHalfCapacity+        then pure (Left (HalfEdgeCapacityExceeded requiredHalfEdges mdHalfCapacity))+        else+          if requiredFaces > mdFaceCapacity+            then pure (Left (FaceCapacityExceeded requiredFaces mdFaceCapacity))+            else pure (Right ())+{-# INLINE ensureCellCapacity #-}++truncatePoints :: MutableDcel s vertex directed undirected face -> Int -> ST s ()+truncatePoints MutableDcel{mdPointCount, mdConnectedCount} count = do+  writeSTRef mdPointCount count+  connected <- readSTRef mdConnectedCount+  when (connected > count) (writeSTRef mdConnectedCount count)++truncateDirectedEdges :: MutableDcel s vertex directed undirected face -> Int -> ST s ()+truncateDirectedEdges MutableDcel{mdHalfCount} = writeSTRef mdHalfCount++truncateFaces :: MutableDcel s vertex directed undirected face -> Int -> ST s ()+truncateFaces MutableDcel{mdFaceCount, mdLastFace} count = do+  writeSTRef mdFaceCount count+  lastFace <- readSTRef mdLastFace+  when (lastFace >= count) (writeSTRef mdLastFace (if count > 1 then 1 else 0))++-- | Remove one undirected edge by moving the last pair into its slot. Only the+-- two neighboring links, one vertex representative, and one face+-- representative per moved half-edge can reference the old handles.+--+-- The slot the tail vacates is returned to the defaults here rather than when+-- the allocator hands it back out. That keeps one invariant — every slot at or+-- above the live count holds the fill — which the thaw establishes, this+-- preserves, and 'addEdgeBlock' may therefore assume without testing anything.+-- The cost lands on removal, which is where the element was retired, instead of+-- on every allocation a pure insertion makes.+swapRemoveUndirectedEdge :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError ())+swapRemoveUndirectedEdge mutable@MutableDcel{mdConstraint, mdConstraintCount, mdConstraintEdges} pair = do+  halfEdges <- directedEdgeCount mutable+  let !pairs = halfEdges `quot` 2+      !lastPair = pairs - 1+  if pair < 0 || pair > lastPair+    then+      pure+        ( Left+            ( RemovalEdgeOutOfRange+                (UndirectedEdgeId (fromIntegral pair))+                pairs+            )+        )+    else do+      swapRemoveUndirectedEdgeInRange lastPair+      pure (Right ())+ where+  swapRemoveUndirectedEdgeInRange lastPair = do+    removedFlag <- readPaged mdConstraint pair+    lastFlag <- readPaged mdConstraint lastPair+    when (removedFlag /= 0) (modifySTRef' mdConstraintCount (subtract 1))+    when (pair /= lastPair) $ do+      let !oldBase = 2 * lastPair+          !newBase = 2 * pair+          remap !handle+            | handle == oldBase = newBase+            | handle == oldBase + 1 = newBase + 1+            | otherwise = handle+      -- Both records are taken before either is republished: the pair's two+      -- half-edges can name each other, so a read after the first write would+      -- see the new handle where the old one belongs.+      !forwardOrigin <- readOrigin mutable oldBase+      !forwardNext <- remap <$> readNext mutable oldBase+      !forwardPrevious <- remap <$> readPrevious mutable oldBase+      !forwardFace <- readFace mutable oldBase+      !backwardOrigin <- readOrigin mutable (oldBase + 1)+      !backwardNext <- remap <$> readNext mutable (oldBase + 1)+      !backwardPrevious <- remap <$> readPrevious mutable (oldBase + 1)+      !backwardFace <- readFace mutable (oldBase + 1)+      writePaged mdConstraint pair lastFlag+      unless (mdPayloadsPristine mutable) $ do+        readBoxedPaged (mdUndirectedData mutable) lastPair >>= writeBoxedPaged (mdUndirectedData mutable) pair+        readBoxedPaged (mdDirectedData mutable) oldBase >>= writeBoxedPaged (mdDirectedData mutable) newBase+        readBoxedPaged (mdDirectedData mutable) (oldBase + 1) >>= writeBoxedPaged (mdDirectedData mutable) (newBase + 1)+      writeOrigin mutable newBase forwardOrigin+      writeNext mutable newBase forwardNext+      writePrevious mutable newBase forwardPrevious+      writeFace mutable newBase forwardFace+      writeOrigin mutable (newBase + 1) backwardOrigin+      writeNext mutable (newBase + 1) backwardNext+      writePrevious mutable (newBase + 1) backwardPrevious+      writeFace mutable (newBase + 1) backwardFace+      writeNext mutable forwardPrevious newBase+      writePrevious mutable forwardNext newBase+      writeVertexOut mutable forwardOrigin newBase+      writeFaceEdge mutable forwardFace newBase+      writeNext mutable backwardPrevious (newBase + 1)+      writePrevious mutable backwardNext (newBase + 1)+      writeVertexOut mutable backwardOrigin (newBase + 1)+      writeFaceEdge mutable backwardFace (newBase + 1)+    modifySTRef'+      mdConstraintEdges+      (\edges ->+         let withoutRetired = IntSet.delete pair (IntSet.delete lastPair edges)+          in if pair /= lastPair && lastFlag /= 0+               then IntSet.insert pair withoutRetired+               else withoutRetired+      )+    resetEdgeData mutable lastPair+    truncateDirectedEdges mutable (2 * lastPair)++swapRemoveFace :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError ())+swapRemoveFace mutable face = do+  faces <- faceCount mutable+  let !lastFace = faces - 1+  if face <= 0 || face > lastFace+    then+      pure+        ( Left+            (RemovalFaceOutOfRange (FaceId (fromIntegral face)) faces)+        )+    else do+      relocated <-+        if face == lastFace+          then pure (Right ())+          else relocateLastFace lastFace+      case relocated of+        Left obstruction -> pure (Left obstruction)+        Right () -> do+          resetFaceData mutable lastFace+          truncateFaces mutable lastFace+          pure (Right ())+ where+  relocateLastFace lastFace = do+    start <- readFaceEdge mutable lastFace+    writeFaceEdge mutable face start+    -- Swap-compaction moves the last face's index, not the face. When the+    -- locator's cached start is that face, following it here is the difference+    -- between a batch of removals resuming where the previous one settled and+    -- 'truncateFaces' finding the cached index out of range and resetting it to+    -- the first inner face. The cache is a start, never an answer.+    cachedFace <- readSTRef (mdLastFace mutable)+    when (cachedFace == lastFace) (writeSTRef (mdLastFace mutable) face)+    unless (mdPayloadsPristine mutable) $+      readBoxedPaged (mdFaceData mutable) lastFace >>= writeBoxedPaged (mdFaceData mutable) face+    halfEdges <- directedEdgeCount mutable+    let go !remaining !current !seen+          | remaining <= 0 =+              pure+                ( Left+                    ( RemovalFaceCycleDidNotTerminate+                        (FaceId (fromIntegral lastFace))+                        (DirectedEdgeId (fromIntegral current))+                        (halfEdges + 1)+                    )+                )+          | seen && current == start = pure (Right ())+          | otherwise = do+              writeFace mutable current face+              nextEdge <- readNext mutable current+              go (remaining - 1) nextEdge True+    go (halfEdges + 1) start False++-- | Retire a vertex by moving the arena's last into its slot. The relocation is+-- reported as the slot together with the position now standing in it: the two+-- are one fact, and a caller told only the slot has to consult the mesh to+-- learn what landed there.+swapRemoveVertex :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point)))+swapRemoveVertex mutable@MutableDcel{mdConnectedCount, mdPointIndex, mdRecycledNew, mdNewConnected} vertex = do+  vertices <- pointCount mutable+  let !lastVertex = vertices - 1+  if vertex < 0 || vertex > lastVertex+    then+      pure+        ( Left+            (RemovalVertexOutOfRange (VertexId (fromIntegral vertex)) vertices)+        )+    else swapRemoveVertexInRange lastVertex+ where+  swapRemoveVertexInRange lastVertex = do+    removedPoint <- pointAt mutable vertex+    removedPayload <- vertexDataAt mutable vertex+    movedOutcome <-+      if vertex == lastVertex+        then pure (Right Nothing)+        else moveTailVertex lastVertex+    case movedOutcome of+      Left obstruction -> pure (Left obstruction)+      Right moved -> do+        indexState <- readSTRef mdPointIndex+        updatedIndexState <-+          updatePointIndexAfterSwap mutable indexState removedPoint vertex lastVertex moved+        writeSTRef mdPointIndex updatedIndexState+        -- The connectivity companions must agree with the aggregate assertion two+        -- lines down: after a swap removal every surviving vertex is connected. The+        -- retired slot's entry and the relocated occupant's old entry are both+        -- stale, and a relocated occupant landing in the appended region must read+        -- connected through the offset store, not through its predecessor's bit.+        modifySTRef' mdRecycledNew (IntSet.delete vertex . IntSet.delete lastVertex)+        case moved of+          Just _+            | vertex >= mdInitialPointCount mutable ->+                writePaged mdNewConnected (vertex - mdInitialPointCount mutable) 1+          _ -> pure ()+        truncatePoints mutable lastVertex+        writeSTRef mdConnectedCount lastVertex+        pure (Right (removedPoint, removedPayload, moved))++  moveTailVertex lastVertex = do+    movedPoint <- pointAt mutable lastVertex+    movedPayload <- vertexDataAt mutable lastVertex+    movedOut <- readVertexOut mutable lastVertex+    writePoint mutable vertex movedPoint+    writeVertexData mutable vertex movedPayload+    writeVertexOut mutable vertex movedOut+    relocated <-+      if movedOut < 0+        then pure (Right ())+        else relocateOutgoingCycle lastVertex movedOut+    pure (Just (vertex, movedPoint) <$ relocated)++  relocateOutgoingCycle lastVertex movedOut = do+    halfEdges <- directedEdgeCount mutable+    let go !remaining !current !seen+          | remaining <= 0 =+              pure+                ( Left+                    ( RemovalOutgoingCycleDidNotTerminate+                        (VertexId (fromIntegral lastVertex))+                        (DirectedEdgeId (fromIntegral current))+                        (halfEdges + 1)+                    )+                )+          | seen && current == movedOut = pure (Right ())+          | otherwise = do+              writeOrigin mutable current vertex+              previousEdge <- readPrevious mutable current+              go (remaining - 1) (previousEdge `xor` 1) True+    go (halfEdges + 1) movedOut False++-- | Transport the identity view across one vertex swap. Persistent sections+-- retain their existing pure update law. A batch table mutates in place, then+-- deliberately falls back to @MissingPointIndex@ if either local proof cannot+-- be completed; geometry remains authoritative and subsequent operations walk+-- rather than observe a stale cache.+updatePointIndexAfterSwap+  :: MutableDcel s vertex directed undirected face+  -> MutablePointIndexState s+  -> Point+  -> Int+  -> Int+  -> Maybe (Int, Point)+  -> ST s (MutablePointIndexState s)+updatePointIndexAfterSwap mutable indexState removedPoint vertex lastVertex moved =+  case indexState of+    DormantPointIndex pointIndex ->+      pure (DormantPointIndex (updatePersistentPointIndex pointIndex))+    ActivePersistentPointIndex pointIndex ->+      pure (ActivePersistentPointIndex (updatePersistentPointIndex pointIndex))+    ActiveBatchPointIndex table ->+      transportBatchPointIndex table+    MissingPointIndex -> pure MissingPointIndex+ where+  updatePersistentPointIndex pointIndex =+    case removedPoint of+      Point removedX removedY ->+        let withoutRemoved = removePointIndex removedX removedY vertex pointIndex+         in case moved of+              Nothing -> withoutRemoved+              Just (_, Point movedX movedY) ->+                relocatePointIndex movedX movedY lastVertex vertex withoutRemoved++  transportBatchPointIndex table =+    case removedPoint of+      Point removedX removedY -> do+        removed <-+          removeMutablePoint+            table+            (readPointX mutable)+            (readPointY mutable)+            removedX+            removedY+            vertex+        case (removed, moved) of+          (MutablePointIndexUpdated, Nothing) ->+            pure (ActiveBatchPointIndex table)+          (MutablePointIndexUpdated, Just (_, Point movedX movedY)) -> do+            relocated <- relocateMutablePoint table movedX movedY lastVertex vertex+            pure $+              case relocated of+                MutablePointIndexUpdated -> ActiveBatchPointIndex table+                MutablePointIndexInvalidated -> MissingPointIndex+          (MutablePointIndexInvalidated, _) -> pure MissingPointIndex++  -- 'swapRemoveVertex' calls us before truncation. The tail's coordinate cells+  -- still carry the moved point, so backward-shift repair can derive every+  -- occupant home from the same canonical storage that the table indexes.+linkEdges :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+linkEdges mutable left right = do+  writeNext mutable left right+  writePrevious mutable right left+{-# INLINE linkEdges #-}++setCycle3 :: MutableDcel s vertex directed undirected face -> Int -> Int -> Int -> Int -> ST s ()+setCycle3 mutable face e0 e1 e2 = do+  writeNext mutable e0 e1+  writeNext mutable e1 e2+  writeNext mutable e2 e0+  writePrevious mutable e0 e2+  writePrevious mutable e1 e0+  writePrevious mutable e2 e1+  writeFace mutable e0 face+  writeFace mutable e1 face+  writeFace mutable e2 face+  writeFaceEdge mutable face e0+{-# INLINE setCycle3 #-}++faceEdges :: MutableDcel s vertex directed undirected face -> Int -> ST s (Int, Int, Int)+faceEdges mutable face = do+  e0 <- readFaceEdge mutable face+  e1 <- readNext mutable e0+  e2 <- readNext mutable e1+  pure (e0, e1, e2)+{-# INLINE faceEdges #-}++readOrigin :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+readOrigin MutableDcel{mdHalfTopology} index = fromIntegral <$> readPaged mdHalfTopology (4 * index)+readNext :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+readNext MutableDcel{mdHalfTopology} index = fromIntegral <$> readPaged mdHalfTopology (4 * index + 1)+readPrevious :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+readPrevious MutableDcel{mdHalfTopology} index = fromIntegral <$> readPaged mdHalfTopology (4 * index + 2)+readFace :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+readFace MutableDcel{mdHalfTopology} index = fromIntegral <$> readPaged mdHalfTopology (4 * index + 3)+{-# INLINE readOrigin #-}+{-# INLINE readNext #-}+{-# INLINE readPrevious #-}+{-# INLINE readFace #-}++writeOrigin :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+writeOrigin MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index) (packIndex value)+writeNext :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+writeNext MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index + 1) (packIndex value)+writePrevious :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+writePrevious MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index + 2) (packIndex value)+writeFace :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+writeFace MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index + 3) (packIndex value)+{-# INLINE writeOrigin #-}+{-# INLINE writeNext #-}+{-# INLINE writePrevious #-}+{-# INLINE writeFace #-}++readVertexOut :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+readVertexOut MutableDcel{mdVertexOut} index = do+  value <- readPaged mdVertexOut index+  pure (if value == noIndex then -1 else fromIntegral value)+{-# INLINE readVertexOut #-}++writeVertexOut :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+writeVertexOut MutableDcel{mdVertexOut} index value =+  writePaged mdVertexOut index (if value < 0 then noIndex else packIndex value)+{-# INLINE writeVertexOut #-}++readFaceEdge :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+readFaceEdge MutableDcel{mdFaceEdge} index = do+  value <- readPaged mdFaceEdge index+  pure (if value == noIndex then -1 else fromIntegral value)+{-# INLINE readFaceEdge #-}++writeFaceEdge :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+writeFaceEdge MutableDcel{mdFaceEdge} index value =+  writePaged mdFaceEdge index (if value < 0 then noIndex else packIndex value)+{-# INLINE writeFaceEdge #-}++readConstraint :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool+readConstraint MutableDcel{mdConstraint} directed = (/= 0) <$> readPaged mdConstraint (directed `quot` 2)+{-# INLINE readConstraint #-}++setConstraint :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool+setConstraint MutableDcel{mdConstraint, mdConstraintCount, mdConstraintEdges} directed = do+  let !index = directed `quot` 2+  current <- readPaged mdConstraint index+  if current /= 0+    then pure False+    else do+      writePaged mdConstraint index 1+      modifySTRef' mdConstraintCount (+ 1)+      modifySTRef' mdConstraintEdges (IntSet.insert index)+      pure True+{-# INLINE setConstraint #-}++clearConstraint :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool+clearConstraint MutableDcel{mdConstraint, mdConstraintCount, mdConstraintEdges} directed = do+  let !index = directed `quot` 2+  current <- readPaged mdConstraint index+  if current == 0+    then pure False+    else do+      writePaged mdConstraint index 0+      modifySTRef' mdConstraintCount (subtract 1)+      modifySTRef' mdConstraintEdges (IntSet.delete index)+      pure True+{-# INLINE clearConstraint #-}
+ src-dcel/Moonlight/Triangulation/Internal/OperationState.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | The state one operation owns while it works: the legalization arena, the+-- shared scratch arena, and the instrumentation cells. None of it is+-- topology, so none of it lives on @MutableDcel@ — a transaction allocates+-- this record when it thaws, hands it down to the operations it runs, and+-- reads the counters back once when it freezes. The hot loops thread their+-- stack top, maximum depth and flip count as strict loop variables and charge+-- these cells once per drain; cold events (one per insertion, one per walk+-- probe) charge them where they happen.+module Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , newOperationState+  , legalizationArena+  , storeLegalizationArena+  , writeScratch+  , readScratch+  , addCounter+  , setCounter+  , maxCounter+  , readCounter+  , freezeBuildStats+  ) where++import Control.Monad (when)+import Control.Monad.ST (ST)+import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32, Word64)+import Moonlight.Triangulation.Internal.Growable+  ( GrowableWord32+  , newGrowableWord32+  , readGrowable+  , writeGrowable+  )+import Moonlight.Triangulation.Internal.PackedIndex (packIndex)+import Moonlight.Triangulation.Internal.Types (BuildStats (..))++-- | Instrumentation cells. The first twenty constructors are exactly the+-- t'BuildStats' fields, in t'BuildStats' order; anything after+-- 'CounterRefinementQueuePops' is a diagnostic with no t'BuildStats' field and+-- is read only by instrumented entries, so 'freezeBuildStats' enumerates the+-- leading block and never sees the rest.+data Counter+  = CounterInputPoints+  | CounterUniquePoints+  | CounterExistingPoints+  | CounterDuplicatePoints+  | CounterSpatialSeedPoints+  | CounterFaceSplits+  | CounterInteriorEdgeSplits+  | CounterBoundaryEdgeSplits+  | CounterHullInsertions+  | CounterLineSplits+  | CounterLineExtensions+  | CounterLineToAreaTransitions+  | CounterEdgeFlips+  | CounterLocationWalkSteps+  | CounterLocationFallbacks+  | CounterLocationMaxWalk+  | CounterLegalizationMaxStack+  | CounterSteinerPoints+  | CounterRefinementFaceChecks+  | CounterRefinementQueuePops+  | CounterSweepFastPoints+  | CounterSweepSkippedPoints+  | CounterDiagLegalizationCandidates+  | CounterDiagHullBucketProbeSteps+  | CounterDiagHullKeyRebuilds+  | CounterCount+  deriving stock (Eq, Ord, Enum, Bounded, Show)++-- | One operation's working state. Scratch is fixed and raw: writes always+-- precede reads within an epoch. The legalization vector is held behind one+-- reference solely so an adversarial generic drain can grow it without+-- reintroducing mesh-global work state. A drain reads that reference once,+-- carries the vector and all stack metrics strictly, and stores it once when+-- finished; there is no per-candidate reference traffic.+data OperationState s = OperationState+  { osLegalizationArena :: !(STRef s (MUV.MVector s Word32))+  , osScratchArena :: !(GrowableWord32 s)+  , osCounters :: !(MUV.MVector s Word64)+  }++-- | Allocate transaction-sized working state. The legalization reservation is a+-- starting size, not a semantic limit: a generic flip pops one candidate and may+-- push four, no linear worst-case depth follows from the input size, and+-- overflow grows the operation-owned vector by doubling. So the reservation is+-- capped. A transaction-sized one charges every singleton verb a fresh block+-- group whose tail no drain reaches, and the doublings that reach a real peak+-- copy less in total than reserving that tail costs.+--+-- Scratch retains four disjoint half-edge sections as its semantic limit: the+-- removal kernel locally glues border, retired-edge, retired-face, and new-fan+-- sections there. Its physical storage still grows only with the star or strip+-- actually observed. Reserving the full mesh bound made every singleton+-- persistent edit allocate an arena whose untouched tail was orders of+-- magnitude larger than the edit.+newOperationState :: Int -> ST s (OperationState s)+newOperationState halfEdgeCapacity = do+  initialArena <- MUV.new (min (2 * halfEdgeCapacity + 64) initialLegalizationReservation)+  arena <- newSTRef initialArena+  scratch <- newGrowableWord32 (min 64 (halfEdgeCapacity + 8))+  counters <- MUV.replicate (fromEnum CounterCount) 0+  pure+    OperationState+      { osLegalizationArena = arena+      , osScratchArena = scratch+      , osCounters = counters+      }++-- | Ordinary cavities are tiny; exceptional stars and recovered strips grow+-- geometrically behind the sealed arena rather than taxing every singleton+-- edit for a pathological frontier it never visits.+initialLegalizationReservation :: Int+initialLegalizationReservation = 64++legalizationArena :: OperationState s -> ST s (MUV.MVector s Word32)+legalizationArena = readSTRef . osLegalizationArena+{-# INLINE legalizationArena #-}++storeLegalizationArena :: OperationState s -> MUV.MVector s Word32 -> ST s ()+storeLegalizationArena = writeSTRef . osLegalizationArena+{-# INLINE storeLegalizationArena #-}++-- | Write a scratch cell. Collection walks carry their topology-derived+-- termination budgets; the growable arena is physical storage, not a second+-- semantic bound capable of disagreeing with those typed obstructions.+writeScratch :: OperationState s -> Int -> Int -> ST s ()+writeScratch OperationState{osScratchArena} index value =+  writeGrowable osScratchArena index (packIndex value)+{-# INLINE writeScratch #-}++readScratch :: OperationState s -> Int -> ST s Int+readScratch OperationState{osScratchArena} index = fromIntegral <$> readGrowable osScratchArena index+{-# INLINE readScratch #-}++addCounter :: OperationState s -> Counter -> Int -> ST s ()+addCounter OperationState{osCounters} counter amount = do+  let !index = fromEnum counter+  current <- MUV.unsafeRead osCounters index+  MUV.unsafeWrite osCounters index (current + fromIntegral amount)+{-# INLINE addCounter #-}++setCounter :: OperationState s -> Counter -> Int -> ST s ()+setCounter OperationState{osCounters} counter value =+  MUV.unsafeWrite osCounters (fromEnum counter) (fromIntegral value)+{-# INLINE setCounter #-}++maxCounter :: OperationState s -> Counter -> Int -> ST s ()+maxCounter OperationState{osCounters} counter value = do+  let !index = fromEnum counter+  current <- MUV.unsafeRead osCounters index+  when (fromIntegral value > current) (MUV.unsafeWrite osCounters index (fromIntegral value))+{-# INLINE maxCounter #-}++readCounter :: OperationState s -> Counter -> ST s Int+readCounter OperationState{osCounters} counter =+  fromIntegral <$> MUV.unsafeRead osCounters (fromEnum counter)+{-# INLINE readCounter #-}++-- | Materialize the public statistics once, at freeze time, from the cells the+-- operation's subsystems charged while it ran. Diagnostic cells past+-- 'CounterRefinementQueuePops' have no t'BuildStats' field and are not read+-- here.+freezeBuildStats :: OperationState s -> ST s BuildStats+freezeBuildStats operation =+  BuildStats+    <$> readCounter operation CounterInputPoints+    <*> readCounter operation CounterUniquePoints+    <*> readCounter operation CounterExistingPoints+    <*> readCounter operation CounterDuplicatePoints+    <*> readCounter operation CounterSpatialSeedPoints+    <*> readCounter operation CounterFaceSplits+    <*> readCounter operation CounterInteriorEdgeSplits+    <*> readCounter operation CounterBoundaryEdgeSplits+    <*> readCounter operation CounterHullInsertions+    <*> readCounter operation CounterLineSplits+    <*> readCounter operation CounterLineExtensions+    <*> readCounter operation CounterLineToAreaTransitions+    <*> readCounter operation CounterEdgeFlips+    <*> readCounter operation CounterLocationWalkSteps+    <*> readCounter operation CounterLocationFallbacks+    <*> readCounter operation CounterLocationMaxWalk+    <*> readCounter operation CounterLegalizationMaxStack+    <*> readCounter operation CounterSteinerPoints+    <*> readCounter operation CounterRefinementFaceChecks+    <*> readCounter operation CounterRefinementQueuePops+    <*> readCounter operation CounterSweepFastPoints+    <*> readCounter operation CounterSweepSkippedPoints+{-# INLINE freezeBuildStats #-}
+ src-dcel/Moonlight/Triangulation/Internal/PointIndex.hs view
@@ -0,0 +1,351 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | The one derived identity index from canonical position hashes to the+-- vertices holding them. Geometry remains solely in the coordinate arenas:+-- both forms store handles only, and every hit is confirmed against those+-- authoritative coordinates. The persistent form follows a published mesh;+-- the open-addressed form is the denser ingress representation used while a+-- bulk load is still claiming its vertices.+module Moonlight.Triangulation.Internal.PointIndex+  ( PointIndex+  , emptyPointIndex+  , buildPointIndex+  , pointIndexCandidates+  , lookupPointIndex+  , insertPointIndex+  , removePointIndex+  , relocatePointIndex+  , MutablePointIndex+  , MutablePointIndexUpdate (..)+  , newMutablePointIndex+  , seedMutablePointIndex+  , lookupMutablePoint+  , removeMutablePoint+  , relocateMutablePoint+  , resolveMutablePoint+  ) where++import Control.DeepSeq (NFData (..))+import Control.Monad.ST (ST)+import Data.Bits (shiftR, xor, (.&.))+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32, Word64)+import GHC.Float (castDoubleToWord64)+import Moonlight.Triangulation.Internal.Types (BuildError (PointIndexCapacityExhausted), Point (..))+import Moonlight.Triangulation.Internal.Paged+  ( Paged+  , pagedUnsafeIndex+  , toVector+  )+import Moonlight.Triangulation.Scalar (canonicalScalarZero)+import qualified Data.Vector.Unboxed as U++-- | Hash buckets containing only vertex handles. Callers confirm candidates+-- against the authoritative coordinate planes.+newtype PointIndex = PointIndex (IntMap.IntMap [Int])+  deriving stock (Eq, Show)++-- A point index is a memoized derived view. Forcing a triangulation forces the+-- geometry and topology that determine it, not a cache no read has demanded.+-- This is the same semantic boundary as omitting the cache from serialization.+instance NFData PointIndex where+  rnf _ = ()++emptyPointIndex :: PointIndex+emptyPointIndex = PointIndex IntMap.empty++-- | Derive an index from the authoritative structure-of-arrays geometry.+buildPointIndex :: Paged Double -> Paged Double -> PointIndex+buildPointIndex pointXs pointYs =+  U.ifoldl'+    (\index vertex x ->+       insertPointIndex x (pagedUnsafeIndex pointYs vertex) vertex index+    )+    emptyPointIndex+    (toVector pointXs)++-- | Candidate vertices sharing a position hash. Exact coordinate comparison+-- belongs to the caller that owns the coordinate reader.+pointIndexCandidates :: Double -> Double -> PointIndex -> [Int]+pointIndexCandidates x y (PointIndex buckets) =+  IntMap.findWithDefault [] (pointHash x y) buckets+{-# INLINE pointIndexCandidates #-}++-- | Resolve one exact position against the authoritative coordinate planes.+-- Hashes reject; coordinates prove. Keeping this here makes the persistent+-- removal and constraint schedules consume the same identity law as a mutable+-- session instead of paying a topological point-location walk for a key lookup.+lookupPointIndex+  :: Paged Double+  -> Paged Double+  -> PointIndex+  -> Point+  -> Maybe Int+lookupPointIndex pointXs pointYs pointIndex (Point x y) =+  foldr confirm Nothing (pointIndexCandidates x y pointIndex)+ where+  confirm candidate resolved+    | pagedUnsafeIndex pointXs candidate == x+        && pagedUnsafeIndex pointYs candidate == y = Just candidate+    | otherwise = resolved++insertPointIndex :: Double -> Double -> Int -> PointIndex -> PointIndex+insertPointIndex x y vertex (PointIndex buckets) =+  PointIndex (IntMap.insertWith (++) (pointHash x y) [vertex] buckets)+{-# INLINE insertPointIndex #-}++-- | Forget one proved handle without touching geometry. Empty collision+-- buckets disappear, so the index remains a derived finite view rather than a+-- history of retired sites.+removePointIndex :: Double -> Double -> Int -> PointIndex -> PointIndex+removePointIndex x y vertex (PointIndex buckets) =+  PointIndex (IntMap.update retainOthers (pointHash x y) buckets)+ where+  retainOthers candidates = case candidates of+    [candidate]+      | candidate == vertex -> Nothing+    _ ->+      case removeCandidate candidates of+        [] -> Nothing+        remaining -> Just remaining++  removeCandidate [] = []+  removeCandidate (candidate : remaining)+    | candidate == vertex = remaining+    | otherwise = candidate : removeCandidate remaining+{-# INLINE removePointIndex #-}++-- | Transport the tail vertex into the slot vacated by swap compaction.+-- Coordinate storage remains authoritative; this updates handles only.+relocatePointIndex+  :: Double+  -> Double+  -> Int+  -> Int+  -> PointIndex+  -> PointIndex+relocatePointIndex x y previousVertex currentVertex (PointIndex buckets) =+  PointIndex+    (IntMap.alter (Just . relocateCandidate . maybe [] id) (pointHash x y) buckets)+ where+  relocateCandidate [] = [currentVertex]+  relocateCandidate (candidate : remaining)+    | candidate == previousVertex = currentVertex : remaining+    | otherwise = candidate : relocateCandidate remaining+{-# INLINE relocatePointIndex #-}++-- The arena already holds every key, so a slot is the vertex that owns the+-- position and nothing else. Every lookup rechecks coordinates; a failed local+-- transport invalidates the table rather than letting it outlive that proof.+data MutablePointIndex s = MutablePointIndex+  { tableSlots :: !(MUV.MVector s Word32)+  , tableMask :: {-# UNPACK #-} !Int+  }++-- | A local cache transport either preserves the proof that every slot agrees+-- with the coordinate arenas, or explicitly gives that proof up. Callers must+-- fall back to the lazy immutable derivation after 'MutablePointIndexInvalidated';+-- they never publish a table whose handle correspondence was not established.+data MutablePointIndexUpdate+  = MutablePointIndexUpdated+  | MutablePointIndexInvalidated++vacant :: Word32+vacant = maxBound++-- | Size a table for a stated number of distinct positions.+newMutablePointIndex :: Int -> ST s (MutablePointIndex s)+newMutablePointIndex expected = do+  tableSlots <- MUV.replicate capacity vacant+  pure MutablePointIndex{tableSlots, tableMask = capacity - 1}+ where+  -- Two slots per key, rounded up to a power of two: linear probing stays in a+  -- short run and the mask stands in for a division.+  !capacity = grow 16+  !wanted = 2 * max 1 expected+  grow !size+    | size >= wanted = size+    | otherwise = grow (size * 2)++-- | Seed the open-addressed section from authoritative coordinates. This is+-- the shared ingress/batch operation: no point payload or parallel identity+-- store crosses the boundary.+seedMutablePointIndex+  :: MutablePointIndex s+  -> Int+  -> (Int -> ST s Double)+  -> (Int -> ST s Double)+  -> ST s (Either BuildError ())+seedMutablePointIndex table count readX readY = seed 0+ where+  seed !vertex+    | vertex >= count = pure (Right ())+    | otherwise = do+        x <- readX vertex+        y <- readY vertex+        claimed <- resolveMutablePoint table readX readY x y vertex+        case claimed of+          Left failure -> pure (Left failure)+          Right _ -> seed (vertex + 1)++-- | Look up a canonical position in the mutable section. A vacant slot proves+-- absence; all occupied candidates are confirmed against coordinate authority.+lookupMutablePoint+  :: MutablePointIndex s+  -> (Int -> ST s Double)+  -> (Int -> ST s Double)+  -> Double+  -> Double+  -> ST s (Maybe Int)+lookupMutablePoint MutablePointIndex{tableSlots, tableMask} readX readY x y =+  probe (fromIntegral (mixCoordinates x y) .&. tableMask) (tableMask + 1)+ where+  probe !slot !budget+    | budget <= 0 = pure Nothing+    | otherwise = do+        occupant <- MUV.unsafeRead tableSlots slot+        if occupant == vacant+          then pure Nothing+          else do+            heldX <- readX (fromIntegral occupant)+            heldY <- readY (fromIntegral occupant)+            if heldX == x && heldY == y+              then pure (Just (fromIntegral occupant))+              else probe ((slot + 1) .&. tableMask) (budget - 1)+{-# INLINE lookupMutablePoint #-}++-- | Forget a retired handle and repair its linear-probe cluster by backward+-- shifting only entries whose home run crosses the resulting hole. The reader+-- is needed for the surviving entries' homes; the retiring entry itself is+-- identified by handle because swap compaction may already have overwritten+-- its coordinate slot. An exhausted or absent proof invalidates the derived+-- cache instead of manufacturing a lookup result.+removeMutablePoint+  :: MutablePointIndex s+  -> (Int -> ST s Double)+  -> (Int -> ST s Double)+  -> Double+  -> Double+  -> Int+  -> ST s MutablePointIndexUpdate+removeMutablePoint MutablePointIndex{tableSlots, tableMask} readX readY x y retiredVertex =+  findRetired (fromIntegral (mixCoordinates x y) .&. tableMask) (tableMask + 1)+ where+  findRetired !slot !budget+    | budget <= 0 = pure MutablePointIndexInvalidated+    | otherwise = do+        occupant <- MUV.unsafeRead tableSlots slot+        if occupant == vacant+          then pure MutablePointIndexInvalidated+          else+            if fromIntegral occupant == retiredVertex+              then do+                MUV.unsafeWrite tableSlots slot vacant+                closeProbeHole slot ((slot + 1) .&. tableMask) (budget - 1)+              else findRetired ((slot + 1) .&. tableMask) (budget - 1)++  closeProbeHole !hole !slot !budget+    | budget <= 0 =+        MutablePointIndexInvalidated <$ MUV.unsafeWrite tableSlots hole vacant+    | otherwise = do+        occupant <- MUV.unsafeRead tableSlots slot+        if occupant == vacant+          then MutablePointIndexUpdated <$ MUV.unsafeWrite tableSlots hole vacant+          else do+            heldX <- readX (fromIntegral occupant)+            heldY <- readY (fromIntegral occupant)+            let !home = fromIntegral (mixCoordinates heldX heldY) .&. tableMask+                !distanceToHole = (hole - home) .&. tableMask+                !distanceToSlot = (slot - home) .&. tableMask+            if distanceToHole < distanceToSlot+              then do+                MUV.unsafeWrite tableSlots hole occupant+                closeProbeHole slot ((slot + 1) .&. tableMask) (budget - 1)+              else closeProbeHole hole ((slot + 1) .&. tableMask) (budget - 1)+{-# INLINE removeMutablePoint #-}++-- | Rename the tail handle after DCEL swap compaction. Failure remains a+-- typed cache obstruction, so its caller drops the table and later identity+-- questions descend from geometry rather than trusting an unproved cache.+relocateMutablePoint+  :: MutablePointIndex s+  -> Double+  -> Double+  -> Int+  -> Int+  -> ST s MutablePointIndexUpdate+relocateMutablePoint MutablePointIndex{tableSlots, tableMask} x y previousVertex currentVertex =+  findPrevious (fromIntegral (mixCoordinates x y) .&. tableMask) (tableMask + 1)+ where+  findPrevious !slot !budget+    | budget <= 0 = pure MutablePointIndexInvalidated+    | otherwise = do+        occupant <- MUV.unsafeRead tableSlots slot+        if occupant == vacant+          then pure MutablePointIndexInvalidated+          else+            if fromIntegral occupant == previousVertex+              then+                MutablePointIndexUpdated+                  <$ MUV.unsafeWrite tableSlots slot (fromIntegral currentVertex)+              else findPrevious ((slot + 1) .&. tableMask) (budget - 1)+{-# INLINE relocateMutablePoint #-}++-- | Answer the vertex already holding a canonical position, or claim the+-- position for @candidate@ and answer 'Nothing'. The position travels as raw+-- coordinates — the v'Point' constructor is the cold boundary's packaging and+-- has no business on the ingress path. The caller supplies the arena's+-- coordinate reader, so a claim is only sound if @candidate@ is the very next+-- vertex the arena will append.+resolveMutablePoint+  :: MutablePointIndex s+  -> (Int -> ST s Double)+  -> (Int -> ST s Double)+  -> Double+  -> Double+  -> Int+  -> ST s (Either BuildError (Maybe Int))+resolveMutablePoint MutablePointIndex{tableSlots, tableMask} readX readY x y candidate =+  probe (fromIntegral (mixCoordinates x y) .&. tableMask) (tableMask + 1)+ where+  probe !slot !budget+    | budget <= 0 = pure (Left (PointIndexCapacityExhausted (MUV.length tableSlots)))+    | otherwise = do+        occupant <- MUV.unsafeRead tableSlots slot+        if occupant == vacant+          then Right Nothing <$ MUV.unsafeWrite tableSlots slot (fromIntegral candidate)+          else do+            heldX <- readX (fromIntegral occupant)+            heldY <- readY (fromIntegral occupant)+            if heldX == x && heldY == y+              then pure (Right (Just (fromIntegral occupant)))+              else probe ((slot + 1) .&. tableMask) (budget - 1)++-- Inlined rather than merely specialized: the coordinate reader arrives as an+-- argument, so until the probe loop lands at its call site every collision pays+-- an unknown call and a boxed pair for a read the caller could have made+-- directly.+{-# INLINE resolveMutablePoint #-}++mixCoordinates :: Double -> Double -> Word64+mixCoordinates x y =+  mix+    ( castDoubleToWord64 (canonicalScalarZero x)+        `xor` mix (castDoubleToWord64 (canonicalScalarZero y))+    )+{-# INLINE mixCoordinates #-}++mix :: Word64 -> Word64+mix raw =+  let !z0 = raw + 0x9e3779b97f4a7c15+      !z1 = (z0 `xor` (z0 `shiftR` 30)) * 0xbf58476d1ce4e5b9+      !z2 = (z1 `xor` (z1 `shiftR` 27)) * 0x94d049bb133111eb+   in z2 `xor` (z2 `shiftR` 31)+{-# INLINE mix #-}++pointHash :: Double -> Double -> Int+pointHash x y = fromIntegral (mixCoordinates x y)+{-# INLINE pointHash #-}
+ src-dcel/Moonlight/Triangulation/Internal/Probe.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}++-- | Compile-time instrumentation switch. The bulk board is the measuring+-- instrument, so per-candidate probe counters must not exist on its path at+-- all: gating behind a flag the compiler can eliminate is the only honest way+-- to have both one sweep implementation and an undistorted measurement. The+-- flag is a type, not a value: at 'ProbeOff the counter type is @()@, so no+-- arithmetic on it can survive in the worker — erasure is a property of the+-- kind, not of the optimizer's mood. The instrumented entry instantiates the+-- same code at 'ProbeOn and pays the cold counter writes itself.+module Moonlight.Triangulation.Internal.Probe+  ( Probe (..)+  , ProbeCounter+  , KnownProbe (..)+  ) where++import Control.Monad.ST (ST)+import Data.Kind (Type)+import Moonlight.Triangulation.Internal.OperationState+  ( Counter+  , OperationState+  , addCounter+  )++-- | The instrumentation switch, promoted to a kind by @DataKinds@.+data Probe = ProbeOff | ProbeOn++-- | The counter a probe site threads. At 'ProbeOff there is nothing to+-- thread; at 'ProbeOn it is a strict @Int@.+type family ProbeCounter (probe :: Probe) = (counter :: Type) | counter -> probe where+  ProbeCounter 'ProbeOff = ()+  ProbeCounter 'ProbeOn = Int++class KnownProbe probe where+  probeZero :: ProbeCounter probe+  probeBump :: ProbeCounter probe -> ProbeCounter probe+  -- | Charge one finished counter to the operation's diagnostic cell. At+  -- 'ProbeOff this is @pure ()@ and disappears with the dictionary; at+  -- 'ProbeOn it is one cold vector write per drain or probe site, on the+  -- instrumented entry that asked for it.+  probeCharge :: OperationState s -> Counter -> ProbeCounter probe -> ST s ()++instance KnownProbe 'ProbeOff where+  probeZero = ()+  probeBump = id+  probeCharge _ _ _ = pure ()+  {-# INLINE probeZero #-}+  {-# INLINE probeBump #-}+  {-# INLINE probeCharge #-}++instance KnownProbe 'ProbeOn where+  probeZero = 0+  probeBump counter = counter + 1+  probeCharge operation counter value = addCounter operation counter value+  {-# INLINE probeZero #-}+  {-# INLINE probeBump #-}+  {-# INLINE probeCharge #-}
+ src-dcel/Moonlight/Triangulation/Internal/Representation.hs view
@@ -0,0 +1,371 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}++-- | The stored representation: the structure-of-arrays mesh, the payload+-- traversals that reach its four free parameters, and the records that carry a+-- built mesh beside its telemetry.+module Moonlight.Triangulation.Internal.Representation+  ( Triangulation (..)+  , promoteConstrained+  , PayloadTraversal+  , vertexPayloads+  , directedPayloads+  , undirectedPayloads+  , facePayloads+  , mapVertices+  , mapDirectedEdges+  , mapUndirectedEdges+  , mapFaces+  , DelaunayTriangulation+  , ConstrainedDelaunayTriangulation+  , BuildResult (..)+  , InsertionResult (..)+  , RefinementReceipt (..)+  , RefinementDomainResult (..)+  , RefinementResult (..)+  ) where++import Control.DeepSeq (NFData)+import qualified Data.IntSet as IntSet+import Data.Primitive.PrimArray (PrimArray)+import Data.Traversable (foldMapDefault)+import qualified Data.Vector as V+import Data.Word (Word8, Word32)+import Moonlight.Triangulation.Handles.HandleDefs (FaceId, UndirectedEdgeId, VertexId)+import Moonlight.Triangulation.Internal.BoxedPaged (BoxedPaged, boxedFromVector, boxedToVector)+import Moonlight.Triangulation.Internal.Paged (Paged)+import Moonlight.Triangulation.Internal.PointIndex (PointIndex)+import Moonlight.Triangulation.Internal.Types+  ( BuildStats+  , ConstraintMode (..)+  , ElementDefaults (..)+  , InsertionDisposition+  )+import GHC.Generics (Generic)++-- | Immutable finite DCEL. The coordinate pages own the geometry; vertex+-- payloads are free annotations carried alongside it.+-- 'Moonlight.Triangulation.Internal.Types.HasPosition' is how a point is read+-- out of a payload at the moment of+-- ingestion and is not consulted again, so a payload whose instance later+-- disagrees with where its vertex sits is not a corrupt triangulation — it is a+-- payload nobody asks about position. Half-edge topology is one interleaved+-- arena: edge @e@ owns slots @4e..4e+3@ holding origin, next, previous and+-- face, so a twin pair is one contiguous eight-word record.+-- Directed edges are adjacent twin pairs, so reversal is an XOR with one.+-- Face zero is the unique outer face. Constraint flags are stored once per+-- undirected edge and are zero for ordinary Delaunay triangulations.+-- All four payload components are therefore representational: coercing a+-- newtype through any of them is a coercion, not a rebuild.+type role Triangulation nominal representational representational representational representational++data Triangulation (mode :: ConstraintMode) vertex directed undirected face = Triangulation+  { triPointX :: !(Paged Double)+  , triPointY :: !(Paged Double)+  , -- | Derived position-hash buckets containing vertex handles only. This is+    -- deliberately lazy: geometry is authoritative, so a workload that never+    -- asks an identity question owes no cache construction.+    triPointIndex :: PointIndex+  , triVertexOut :: !(Paged Word32)+  , triVertexData :: !(BoxedPaged vertex)+  , triHalfTopology :: !(Paged Word32)+  , triDirectedData :: !(BoxedPaged directed)+  , triUndirectedData :: !(BoxedPaged undirected)+  , triFaceEdge :: !(Paged Word32)+  , triFaceData :: !(BoxedPaged face)+  , triConstraint :: !(Paged Word8)+  , triConstraintCount :: {-# UNPACK #-} !Int+  , -- | Derived exact membership for the sparse constrained edge section.+    -- The flag plane remains authoritative and serializable; this index is+    -- transported with edge rewrites so constraint-only queries need not scan+    -- every ordinary Delaunay edge.+    triConstraintEdges :: !IntSet.IntSet+  , triElementDefaults :: !(ElementDefaults directed undirected face)+  }+  deriving stock (Show, Generic)+  deriving anyclass (NFData)++-- The point index is a derived cache and therefore not an observable part of+-- the mesh value. Structural equality compares every semantic plane and+-- default while deliberately refusing to construct or compare that cache.+instance+  ( Eq vertex+  , Eq directed+  , Eq undirected+  , Eq face+  ) => Eq (Triangulation mode vertex directed undirected face) where+  left == right =+    triPointX left == triPointX right+      && triPointY left == triPointY right+      && triVertexOut left == triVertexOut right+      && triVertexData left == triVertexData right+      && triHalfTopology left == triHalfTopology right+      && triDirectedData left == triDirectedData right+      && triUndirectedData left == triUndirectedData right+      && triFaceEdge left == triFaceEdge right+      && triFaceData left == triFaceData right+      && triConstraint left == triConstraint right+      && triConstraintCount left == triConstraintCount right+      && triElementDefaults left == triElementDefaults right++promoteConstrained+  :: Triangulation 'Unconstrained vertex directed undirected face+  -> Triangulation 'Constrained vertex directed undirected face+promoteConstrained Triangulation{+  triPointX, triPointY, triPointIndex, triVertexOut, triVertexData, triHalfTopology,+  triDirectedData, triUndirectedData, triFaceEdge, triFaceData,+  triConstraint, triConstraintCount, triConstraintEdges, triElementDefaults+  } =+  Triangulation{+    triPointX, triPointY, triPointIndex, triVertexOut, triVertexData, triHalfTopology,+    triDirectedData, triUndirectedData, triFaceEdge, triFaceData,+    triConstraint, triConstraintCount, triConstraintEdges, triElementDefaults+    }++-- | A traversal of every occurrence of one payload parameter, in the van+-- Laarhoven encoding: an effectful visit that may change the payload's type.+-- The 'Applicative' belongs to the caller, so one traversal per parameter+-- serves relabeling, collection and genuinely effectful annotation alike+-- instead of a separate function for each.+type PayloadTraversal source target payload payload' =+  forall f. Applicative f => (payload -> f payload') -> source -> f target++-- | Every stored vertex payload, in vertex order.+--+-- The vertex store carries no fill — a vertex's payload arrives with the+-- vertex, and no slot is read before it is written — so the visits are exactly+-- the stored payloads and nothing besides.+vertexPayloads+  :: PayloadTraversal+      (Triangulation mode vertex directed undirected face)+      (Triangulation mode vertex' directed undirected face)+      vertex+      vertex'+vertexPayloads visit triangulation =+  (\payloads -> triangulation{triVertexData = boxedFromVector Nothing payloads})+    <$> traverse visit (boxedToVector (triVertexData triangulation))++-- | Every stored directed-edge payload, then the default a later directed edge+-- will inherit.+--+-- The default is visited because it is a payload the structure carries, and it+-- is visited /once/: its single image is written both to t'ElementDefaults' and+-- to the store's fill, which every slot of an unmaterialized page reports.+-- Visiting the two positions separately would let an effect with more than one+-- answer hand them different values, and a triangulation whose future elements+-- disagree with its present ones is not a triangulation anyone asked for.+directedPayloads+  :: PayloadTraversal+      (Triangulation mode vertex directed undirected face)+      (Triangulation mode vertex directed' undirected face)+      directed+      directed'+directedPayloads visit triangulation =+  (\payloads fallback ->+     triangulation+       { triDirectedData = boxedFromVector (Just fallback) payloads+       , triElementDefaults = defaults{defaultDirectedEdgeData = fallback}+       })+    <$> traverse visit (boxedToVector (triDirectedData triangulation))+    <*> visit (defaultDirectedEdgeData defaults)+ where+  defaults = triElementDefaults triangulation++-- | Every stored undirected-edge payload, then the default a later undirected+-- edge will inherit.+undirectedPayloads+  :: PayloadTraversal+      (Triangulation mode vertex directed undirected face)+      (Triangulation mode vertex directed undirected' face)+      undirected+      undirected'+undirectedPayloads visit triangulation =+  (\payloads fallback ->+     triangulation+       { triUndirectedData = boxedFromVector (Just fallback) payloads+       , triElementDefaults = defaults{defaultUndirectedEdgeData = fallback}+       })+    <$> traverse visit (boxedToVector (triUndirectedData triangulation))+    <*> visit (defaultUndirectedEdgeData defaults)+ where+  defaults = triElementDefaults triangulation++-- | Every stored face payload, then the default a later face will inherit.+facePayloads+  :: PayloadTraversal+      (Triangulation mode vertex directed undirected face)+      (Triangulation mode vertex directed undirected face')+      face+      face'+facePayloads visit triangulation =+  (\payloads fallback ->+     triangulation+       { triFaceData = boxedFromVector (Just fallback) payloads+       , triElementDefaults = defaults{defaultFaceData = fallback}+       })+    <$> traverse visit (boxedToVector (triFaceData triangulation))+    <*> visit (defaultFaceData defaults)+ where+  defaults = triElementDefaults triangulation++-- | Ranges over the face payload, which is the last parameter and so the only+-- one a class of this kind can reach. The other three payloads have exactly+-- the same structure under 'vertexPayloads', 'directedPayloads' and+-- 'undirectedPayloads'; they are simply not spellable as instances here.+--+-- 'mapFaces' rather than the traversal, because it leaves an unmaterialized+-- page unmaterialized. The two agree on everything a 'BoxedPaged' lets anyone+-- observe, which is what the coherence law asks and all it asks.+instance Functor (Triangulation mode vertex directed undirected) where+  fmap = mapFaces+  {-# INLINE fmap #-}++-- | Folds the stored face payloads and then the default, so 'length' is one+-- greater than the number of stored faces. A fold that skipped the default+-- would report a triangulation as holding a value it does hold.+instance Foldable (Triangulation mode vertex directed undirected) where+  foldMap = foldMapDefault+  {-# INLINE foldMap #-}++instance Traversable (Triangulation mode vertex directed undirected) where+  traverse = facePayloads+  {-# INLINE traverse #-}++-- | An element payload map carries the element defaults with it. A new+-- insertion hands its new elements the default, so a map that reindexed the+-- stored payloads and left the default behind would produce a triangulation+-- whose future elements disagree with its present ones. The type system very+-- nearly forces this on its own — the image type is inhabited here only+-- through the mapping function — but only a test can insist the argument is+-- the /default/ rather than some other payload of the right type.+mapDirectedEdges+  :: (directed -> directed')+  -> Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex directed' undirected face+mapDirectedEdges f triangulation =+  triangulation+    { triDirectedData = fmap f (triDirectedData triangulation)+    , triElementDefaults = defaults{defaultDirectedEdgeData = f (defaultDirectedEdgeData defaults)}+    }+ where+  defaults = triElementDefaults triangulation++mapUndirectedEdges+  :: (undirected -> undirected')+  -> Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex directed undirected' face+mapUndirectedEdges f triangulation =+  triangulation+    { triUndirectedData = fmap f (triUndirectedData triangulation)+    , triElementDefaults = defaults{defaultUndirectedEdgeData = f (defaultUndirectedEdgeData defaults)}+    }+ where+  defaults = triElementDefaults triangulation++mapFaces+  :: (face -> face')+  -> Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex directed undirected face'+mapFaces f triangulation =+  triangulation+    { triFaceData = fmap f (triFaceData triangulation)+    , triElementDefaults = defaults{defaultFaceData = f (defaultFaceData defaults)}+    }+ where+  defaults = triElementDefaults triangulation++-- | The vertex component is free, like the other three. Geometry owns the+-- points, so a payload map cannot move one — the image type need not even have+-- a position to speak of. There is no vertex default to carry: vertices arrive+-- with their payloads.+mapVertices+  :: (vertex -> vertex')+  -> Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex' directed undirected face+mapVertices f triangulation =+  triangulation{triVertexData = fmap f (triVertexData triangulation)}++-- | Geometry-only unconstrained Delaunay triangulation.+type DelaunayTriangulation vertex = Triangulation 'Unconstrained vertex () () ()++-- | Geometry-only constrained Delaunay triangulation.+type ConstrainedDelaunayTriangulation vertex = Triangulation 'Constrained vertex () () ()++-- | A constructed triangulation and the canonical handle chosen for each input.+--+-- The result is a value, not a history: derived 'Eq'/'Show' would observe+-- 'buildStats' through a facade that hides it, so neither instance exists.+data BuildResult mode vertex directed undirected face = BuildResult+  { -- | The immutable constructed mesh.+    buildTriangulation :: !(Triangulation mode vertex directed undirected face)+  , -- | Canonical vertex handle for each input position, including duplicates.+    buildInputVertices :: !(PrimArray Word32)+  , buildStats :: !BuildStats+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++data InsertionResult mode vertex directed undirected face = InsertionResult+  { insertionTriangulation :: !(Triangulation mode vertex directed undirected face)+  , insertionVertex :: !VertexId+  , insertionDisposition :: !InsertionDisposition+  , insertionStats :: !BuildStats+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++deriving stock instance+  (Eq vertex, Eq directed, Eq undirected, Eq face)+  => Eq (InsertionResult mode vertex directed undirected face)+deriving stock instance+  (Show vertex, Show directed, Show undirected, Show face)+  => Show (InsertionResult mode vertex directed undirected face)++-- | Exact support touched by one refinement publication. Checked local+-- refinement uses this as the positive receipt accompanying its typed+-- obstruction surface; unrestricted refinement deliberately avoids the+-- additional support scan.+data RefinementReceipt = RefinementReceipt+  { refinementVisitedJoinFaces :: !(V.Vector FaceId)+  , refinementVisitedProtectedFaces :: !(V.Vector FaceId)+  , refinementCreatedFaces :: !(V.Vector FaceId)+  , refinementTouchedEdges :: !(V.Vector UndirectedEdgeId)+  , refinementRemovedEdges :: !(V.Vector UndirectedEdgeId)+  , refinementInterfaceBoundaryReads :: {-# UNPACK #-} !Int+  , refinementAttemptedBoundaryCrossings :: {-# UNPACK #-} !Int+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | A locally refined section paired with the proof of what the checked+-- interpreter observed and rewrote. Ordinary refinement does not pay to+-- construct this proof.+data RefinementDomainResult mode vertex directed undirected face = RefinementDomainResult+  { refinementDomainResult :: !(RefinementResult mode vertex directed undirected face)+  , refinementDomainReceipt :: !RefinementReceipt+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++-- | Refined mesh together with the budget, exclusion, and support outcome.+data RefinementResult mode vertex directed undirected face = RefinementResult+  { -- | The immutable mesh after all admitted refinement steps.+    refinedTriangulation :: !(Triangulation mode vertex directed undirected face)+  , refinementStats :: !BuildStats+  , refinementAddedVertices :: {-# UNPACK #-} !Int+  -- | Whether the quality worklist drained. 'False' means the vertex budget+  -- stopped the run with work outstanding. A drained worklist can still leave+  -- faces the quality bounds condemn but no admissible Steiner point can fix;+  -- auditing the result is the caller's to ask for, not a cost every run pays.+  , refinementComplete :: !Bool+  , -- | Faces deliberately excluded by barrier-depth policy.+    refinementExcludedFaces :: !(V.Vector FaceId)+  }+  deriving stock (Generic)+  deriving anyclass (NFData)
+ src-dcel/Moonlight/Triangulation/Internal/Types.hs view
@@ -0,0 +1,401 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | The vocabulary: the types the surface names, none of which mentions the+-- stored representation.+module Moonlight.Triangulation.Internal.Types+  ( Point (..)+  , SiteRelation (..)+  , QueryPoint (..)+  , PointValidationError (..)+  , HasPosition (..)+  , ElementDefaults (..)+  , unitElementDefaults+  , ConstraintMode (..)+  , KnownConstraintMode (..)+  , InsertionDisposition (..)+  , BuildStats (..)+  , emptyBuildStats+  , CoordinateError (..)+  , NonFiniteValue (..)+  , classifyNonFinite+  , BuildError (..)+  , Location (..)+  , LocationHint (..)+  , LocationStats (..)+  , emptyLocationStats+  , NearestStats (..)+  , RefinementParameters (..)+  , defaultRefinementParameters+  , InvariantViolation (..)+  ) where++import Control.DeepSeq (NFData)+import Moonlight.Triangulation.Handles.HandleDefs+  ( DirectedEdgeId+  , FaceId+  , UndirectedEdgeId+  , VertexId+  )+import Data.Word (Word8)+import Foreign.Ptr (castPtr)+import Foreign.Storable (Storable (..), peekElemOff, pokeElemOff)+import GHC.Generics (Generic)+import Moonlight.Triangulation.Internal.BoxedPaged (BoxedStorageError)++-- | Type-level witness for whether constraint flags may be present.+data ConstraintMode = Unconstrained | Constrained+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++class KnownConstraintMode (mode :: ConstraintMode) where+  constraintModeValue :: proxy mode -> ConstraintMode++instance KnownConstraintMode 'Unconstrained where+  constraintModeValue _ = Unconstrained++instance KnownConstraintMode 'Constrained where+  constraintModeValue _ = Constrained++-- | Cartesian binary64 point.+data Point = Point+  { pointX :: !Double+  , pointY :: !Double+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Exact geometric relation between two finite coordinate supports. The+-- overlap count is strictly positive in 'PartialOverlap'; equality, subset and+-- disjointness have already been excluded before that constructor is chosen.+data SiteRelation+  = -- | Both supports contain exactly the same coordinates.+    EqualSites+  | -- | Every left coordinate occurs on the right, which has at least one more.+    LeftProperSubset+  | -- | Every right coordinate occurs on the left, which has at least one more.+    RightProperSubset+  | -- | The supports share no coordinate.+    DisjointSites+  | -- | Neither support contains the other; the field is the positive number+    -- of coordinates they share.+    PartialOverlap {-# UNPACK #-} !Int+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | A coordinate pair admitted to the exact-predicate domain and normalized+-- at its construction boundary. Query algorithms consume this phase rather+-- than each inventing a fallback for invalid floating-point input.+newtype QueryPoint = QueryPoint+  { -- | The admitted, canonically normalized point.+    queryPointValue :: Point+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Coordinate axis and reason that kept a point outside the query domain.+data PointValidationError+  = InvalidPointX !CoordinateError+  | InvalidPointY !CoordinateError+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++instance Storable (Point) where+  sizeOf _ = 2 * sizeOf (0 :: Double)+  alignment _ = alignment (0 :: Double)+  peek pointer = do+    x <- peekElemOff (castPtr pointer) 0+    y <- peekElemOff (castPtr pointer) 1+    pure (Point x y)+  poke pointer (Point x y) = do+    pokeElemOff (castPtr pointer) 0 x+    pokeElemOff (castPtr pointer) 1 y++-- | Extract a vertex's position once, at the construction boundary.+class HasPosition vertex where+  position :: vertex -> Point++instance HasPosition (Point) where+  position = id++-- | Payloads inherited by topology elements created after initial loading.+data ElementDefaults directed undirected face = ElementDefaults+  { defaultDirectedEdgeData :: !directed+  , defaultUndirectedEdgeData :: !undirected+  , defaultFaceData :: !face+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Payload defaults for geometry-only triangulations.+unitElementDefaults :: ElementDefaults () () ()+unitElementDefaults = ElementDefaults () () ()++data BuildStats = BuildStats+  { statInputPoints :: {-# UNPACK #-} !Int+  , statUniquePoints :: {-# UNPACK #-} !Int+  , statExistingPoints :: {-# UNPACK #-} !Int+  , statDuplicatePoints :: {-# UNPACK #-} !Int+  , statSpatialSeedPoints :: {-# UNPACK #-} !Int+  , statFaceSplits :: {-# UNPACK #-} !Int+  , statInteriorEdgeSplits :: {-# UNPACK #-} !Int+  , statBoundaryEdgeSplits :: {-# UNPACK #-} !Int+  , statHullInsertions :: {-# UNPACK #-} !Int+  , statLineSplits :: {-# UNPACK #-} !Int+  , statLineExtensions :: {-# UNPACK #-} !Int+  , statLineToAreaTransitions :: {-# UNPACK #-} !Int+  , statEdgeFlips :: {-# UNPACK #-} !Int+  , statLocationWalkSteps :: {-# UNPACK #-} !Int+  , statLocationFallbacks :: {-# UNPACK #-} !Int+  , statLocationMaxWalk :: {-# UNPACK #-} !Int+  , statLegalizationMaxStack :: {-# UNPACK #-} !Int+  , statSteinerPoints :: {-# UNPACK #-} !Int+  , statRefinementFaceChecks :: {-# UNPACK #-} !Int+  , statRefinementQueuePops :: {-# UNPACK #-} !Int+  , statSweepFastPoints :: {-# UNPACK #-} !Int+  , statSweepSkippedPoints :: {-# UNPACK #-} !Int+  }+  deriving stock (Eq, Show, Read, Generic)+  deriving anyclass (NFData)++emptyBuildStats :: BuildStats+emptyBuildStats =+  BuildStats+    { statInputPoints = 0+    , statUniquePoints = 0+    , statExistingPoints = 0+    , statDuplicatePoints = 0+    , statSpatialSeedPoints = 0+    , statFaceSplits = 0+    , statInteriorEdgeSplits = 0+    , statBoundaryEdgeSplits = 0+    , statHullInsertions = 0+    , statLineSplits = 0+    , statLineExtensions = 0+    , statLineToAreaTransitions = 0+    , statEdgeFlips = 0+    , statLocationWalkSteps = 0+    , statLocationFallbacks = 0+    , statLocationMaxWalk = 0+    , statLegalizationMaxStack = 0+    , statSteinerPoints = 0+    , statRefinementFaceChecks = 0+    , statRefinementQueuePops = 0+    , statSweepFastPoints = 0+    , statSweepSkippedPoints = 0+    }++data InsertionDisposition = Inserted | AlreadyPresent+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Reason a floating-point coordinate cannot enter the exact-predicate domain.+data CoordinateError+  = CoordinateNaN+  | CoordinateInfinite+  | CoordinateTooSmall+  | CoordinateTooLarge+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Classification retained when a numeric parameter is not finite.+data NonFiniteValue+  = ValueNaN+  | ValuePositiveInfinity+  | ValueNegativeInfinity+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++classifyNonFinite :: Double -> Maybe NonFiniteValue+classifyNonFinite value+  | isNaN value = Just ValueNaN+  | isInfinite value && value < 0 = Just ValueNegativeInfinity+  | isInfinite value = Just ValuePositiveInfinity+  | otherwise = Nothing++-- | Total construction and rewrite obstruction surface.+data BuildError+  = InvalidCoordinate !(Maybe Int) {-# UNPACK #-} !Double !CoordinateError+  | PointLocationFailed !(Point)+  | LocationWalkExhausted !(Point) {-# UNPACK #-} !Int+  | RefinementInputTopologyInvalid !InvariantViolation+  | FreshInsertionMatchedExistingVertex !VertexId !VertexId+  | DegenerateLineEndpointMissingOutgoing !VertexId+  | DegenerateLineEndpointTurnMissing {-# UNPACK #-} !Int+  | DegenerateLineConnectedVertexMissing {-# UNPACK #-} !Int+  | HullStartNotVisible !DirectedEdgeId+  | OuterRangeDidNotTerminate !DirectedEdgeId !DirectedEdgeId {-# UNPACK #-} !Int+  | OuterRangeContainsInnerEdge !DirectedEdgeId !FaceId+  | ConstrainedEdgeFlipRefused !UndirectedEdgeId+  | RemovalVertexOutOfRange !VertexId {-# UNPACK #-} !Int+  | RemovalEdgeOutOfRange !UndirectedEdgeId {-# UNPACK #-} !Int+  | RemovalFaceOutOfRange !FaceId {-# UNPACK #-} !Int+  | RemovalFaceCycleDidNotTerminate+      !FaceId+      !DirectedEdgeId+      {-# UNPACK #-} !Int+  | RemovalEmptyTriangulation !VertexId+  | RemovalTwoPointDegreeMismatch !VertexId {-# UNPACK #-} !Int+  | RemovalCollinearDegreeMismatch !VertexId {-# UNPACK #-} !Int+  | RemovalBorderTooShort {-# UNPACK #-} !Int+  | RemovalBorderArityMismatch {-# UNPACK #-} !Int+  | RemovalOutgoingCycleDidNotTerminate+      !VertexId+      !DirectedEdgeId+      {-# UNPACK #-} !Int+  | CircleSweepHullEmpty+  | OuterCycleDidNotTerminate+      !DirectedEdgeId+      !DirectedEdgeId+      {-# UNPACK #-} !Int+  | HierarchyLevelPopulationMismatch+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+  | HierarchyInsertionHandleMismatch !VertexId !VertexId+  | PointIndexCapacityExhausted {-# UNPACK #-} !Int+  | RefinementMinimumAngleNotFinite !NonFiniteValue+  | RefinementMinimumAngleOutOfRange {-# UNPACK #-} !Double+  | RefinementMinimumAngleDerivedRatioNotFinite !NonFiniteValue+  | RefinementMaximumAdditionalVerticesNegative {-# UNPACK #-} !Int+  | RefinementMinimumAreaNotFinite !NonFiniteValue+  | RefinementMinimumAreaNegative {-# UNPACK #-} !Double+  | RefinementMaximumAreaNotFinite !NonFiniteValue+  | RefinementMaximumAreaNotPositive {-# UNPACK #-} !Double+  | RefinementMaximumRadiusEdgeRatioNotFinite !NonFiniteValue+  | RefinementMaximumRadiusEdgeRatioNotPositive {-# UNPACK #-} !Double+  | RefinementMinimumAreaExceedsMaximum+      {-# UNPACK #-} !Double+      {-# UNPACK #-} !Double+  | RefinementSeedFaceNotActive !FaceId {-# UNPACK #-} !Int+  | RefinementDomainInterfaceEdgeNotActive !UndirectedEdgeId {-# UNPACK #-} !Int+  | RefinementDomainInterfaceMissing !UndirectedEdgeId+  | RefinementDomainInterfaceExtraneous !UndirectedEdgeId+  | RefinementDomainTopologyChanged+  | RefinementDomainRequiresConvexHullPreservation+  | RefinementDomainRequiresConstraintPreservation+  | RefinementDomainForbidsOuterFaceExclusion+  | RefinementDomainWouldCrossInterface !UndirectedEdgeId !FaceId+  | RefinementDomainWouldRewriteProtectedFace !FaceId+  | RefinementDomainProtectedFaceChanged !FaceId+  | CapacityExceeded {-# UNPACK #-} !Int+  | HalfEdgeCapacityExceeded {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | FaceCapacityExceeded {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | PayloadStorageFailure !BoxedStorageError+  | CoordinatePayloadCountMismatch+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++data Location+  = EmptyTriangulation+  | OnVertex !VertexId+  | OnEdge !DirectedEdgeId+  | InFace !FaceId+  | OutsideConvexHull !(Maybe DirectedEdgeId)+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Optional starting cell for point-location descent.+data LocationHint+  = VertexHint !VertexId+  | FaceHint !FaceId+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data LocationStats = LocationStats+  { locationWalkSteps :: {-# UNPACK #-} !Int+  , locationUsedFallback :: !Bool+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++emptyLocationStats :: LocationStats+emptyLocationStats = LocationStats 0 False++-- | Work performed by a nearest-neighbor query.+data NearestStats = NearestStats+  { nearestWalkSteps :: {-# UNPACK #-} !Int+  , nearestDistanceTests :: {-# UNPACK #-} !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Independent quality bounds and a finite Steiner-vertex budget.+data RefinementParameters = RefinementParameters+  { refineMaxAdditionalVertices :: !(Maybe Int)+  , refineMinArea :: !(Maybe Double)+  , refineMaxArea :: !(Maybe Double)+  , refineMaxRadiusEdgeRatio :: !(Maybe Double)+  , refinePreserveConvexHull :: !Bool+  , refineKeepConstraintEdges :: !Bool+  , refineExcludeOuterFaces :: !Bool+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Conservative refinement defaults with no explicit area bounds.+defaultRefinementParameters :: RefinementParameters+defaultRefinementParameters =+  RefinementParameters+    { refineMaxAdditionalVertices = Nothing+    , refineMinArea = Nothing+    , refineMaxArea = Nothing+    , refineMaxRadiusEdgeRatio = Just 1+    , refinePreserveConvexHull = True+    , refineKeepConstraintEdges = False+    , refineExcludeOuterFaces = False+    }++-- | A concrete witness that an immutable DCEL law does not hold.+data InvariantViolation+  = CoordinatePlaneLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | VertexOutgoingLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | VertexPayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | TopologyArenaLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | DirectedPayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | UndirectedPayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | DirectedEdgeCountOdd {-# UNPACK #-} !Int+  | ConstraintLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | NonCanonicalConstraintFlag !UndirectedEdgeId !Word8+  | CachedConstraintCountMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | CachedConstraintIndexMismatch+  | MissingOuterFace+  | FacePayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | EdgeOriginOutOfRange !DirectedEdgeId !VertexId {-# UNPACK #-} !Int+  | EdgeNextOutOfRange !DirectedEdgeId !DirectedEdgeId {-# UNPACK #-} !Int+  | EdgePreviousOutOfRange !DirectedEdgeId !DirectedEdgeId {-# UNPACK #-} !Int+  | EdgeFaceOutOfRange !DirectedEdgeId !FaceId {-# UNPACK #-} !Int+  | VertexOutgoingOutOfRange !VertexId !DirectedEdgeId {-# UNPACK #-} !Int+  | FaceAdjacentOutOfRange !FaceId !DirectedEdgeId {-# UNPACK #-} !Int+  | EdgeNextPreviousMismatch !DirectedEdgeId !DirectedEdgeId+  | EdgePreviousNextMismatch !DirectedEdgeId !DirectedEdgeId+  | EdgeDoubleReversalMismatch !DirectedEdgeId+  | EdgeSelfLinkedNext !DirectedEdgeId+  | EdgeSelfLinkedPrevious !DirectedEdgeId+  | InnerFaceNotTriangularAtEdge !DirectedEdgeId+  | FaceMissingAdjacentEdge !FaceId+  | FaceRepresentativeMismatch !FaceId !DirectedEdgeId !FaceId+  | InnerFaceVertexCardinalityMismatch !FaceId {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | ConnectedVertexMissingOutgoing !VertexId+  | VertexOutgoingOriginMismatch !VertexId !DirectedEdgeId !VertexId+  | CollinearEdgeCountMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | EulerCharacteristicMismatch {-# UNPACK #-} !Int+  | InnerFaceNotCounterClockwise !FaceId+  | LocallyIllegalDelaunayEdge !UndirectedEdgeId+  | DelaunayIncidentFaceNotTriangular !UndirectedEdgeId+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)
+ src-dcel/Moonlight/Triangulation/Interop.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE FlexibleInstances #-}++module Moonlight.Triangulation.Interop+  ( Coordinate2 (..)+  , mapCoordinate2+  ) where++import Data.Complex (Complex ((:+)))+import Moonlight.Triangulation.Types (Point (..))++-- | Minimal mint-like interchange class. It owns no geometry and introduces no+-- second point representation inside the triangulation; conversion happens only+-- at an ecosystem boundary.+class Coordinate2 value where+  toPoint :: value -> Point+  fromPoint :: Point -> value++instance Coordinate2 (Point) where+  toPoint = id+  fromPoint = id++instance Coordinate2 (Double, Double) where+  toPoint (x, y) = Point x y+  fromPoint (Point x y) = (x, y)++instance Coordinate2 (Complex Double) where+  toPoint (x :+ y) = Point x y+  fromPoint (Point x y) = x :+ y++mapCoordinate2+  :: (Coordinate2 input, Coordinate2 output)+  => (Point -> Point)+  -> input+  -> output+mapCoordinate2 transform = fromPoint . transform . toPoint
+ src-dcel/Moonlight/Triangulation/IntersectionIterator.hs view
@@ -0,0 +1,407 @@+{-# LANGUAGE BangPatterns #-}++module Moonlight.Triangulation.IntersectionIterator+  ( Intersection (..)+  , lineIntersections+  , lineIntersectionsBetweenVertices+  , foldCorridorBetweenPoints+  , foldCorridorBetweenVertices+  , conflictingEdges+  , segmentIntersectsNonCollinear+  ) where++import Data.List (sortBy)+import Data.Maybe (mapMaybe)+import Data.Ord (comparing)+import Data.Void (Void, absurd)+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (undirectedEdges, vertices)+import Moonlight.Triangulation.Math+import Moonlight.Triangulation.PointLocation+import Moonlight.Triangulation.Types++-- | One crossing: an edge cut, a vertex hit, or a collinear overlap.+data Intersection+  = EdgeIntersection !DirectedEdgeId+  | VertexIntersection !VertexId+  | EdgeOverlap !DirectedEdgeId+  deriving stock (Eq, Ord, Show)++-- | Every crossing between two points, ordered along the segment.+lineIntersections+  :: Triangulation mode vertex directed undirected face+  -> QueryPoint+  -> QueryPoint+  -> [Intersection]+lineIntersections triangulation queryFrom queryTo =+  let !from = queryPointValue queryFrom+      !to = queryPointValue queryTo+   in case firstIntersection triangulation queryFrom queryTo of+        Nothing -> []+        Just first -> walkIntersections triangulation from to first++-- | 'lineIntersections' between two existing vertices.+lineIntersectionsBetweenVertices :: Triangulation mode vertex directed undirected face -> VertexId -> VertexId -> [Intersection]+lineIntersectionsBetweenVertices triangulation fromVertex toVertex =+  let from = vertexPoint triangulation fromVertex+      to = vertexPoint triangulation toVertex+   in walkIntersections triangulation from to (VertexIntersection fromVertex)++-- | The directed edges a crossing list cuts.+conflictingEdges :: [Intersection] -> [DirectedEdgeId]+conflictingEdges = mapMaybe asConflict+ where+  asConflict (EdgeIntersection edge) = Just edge+  asConflict _ = Nothing++-- | Fold the corridor one crossing at a time, stopping the instant the step+-- function answers.+--+-- The list-producing walks cannot stop early: their step budget is only known+-- to have been respected once the walk ends, so the whole corridor is+-- materialized before the first event is visible. A caller whose answer is+-- settled by a prefix — anything asking whether some crossing exists — should+-- not pay for the suffix. 'Nothing' reports a walk that outran its budget and+-- is the caller's signal to fall back to the materialized walk, which+-- substitutes the exact scan.+foldCorridorBetweenVertices+  :: Triangulation mode vertex directed undirected face+  -> VertexId+  -> VertexId+  -> (state -> Intersection -> Either answer state)+  -> state+  -> Maybe (Either answer state)+foldCorridorBetweenVertices triangulation fromVertex toVertex =+  foldCorridor+    triangulation+    (vertexPoint triangulation fromVertex)+    (vertexPoint triangulation toVertex)+    (VertexIntersection fromVertex)++-- | As 'foldCorridorBetweenVertices', for a corridor given by its endpoints.+-- A segment that meets nothing at all folds to the initial state.+foldCorridorBetweenPoints+  :: Triangulation mode vertex directed undirected face+  -> QueryPoint+  -> QueryPoint+  -> (state -> Intersection -> Either answer state)+  -> state+  -> Maybe (Either answer state)+foldCorridorBetweenPoints triangulation queryFrom queryTo step state =+  case firstIntersection triangulation queryFrom queryTo of+    Nothing -> Just (Right state)+    Just first ->+      foldCorridor+        triangulation+        (queryPointValue queryFrom)+        (queryPointValue queryTo)+        first+        step+        state++foldCorridor+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> Point+  -> Intersection+  -> (state -> Intersection -> Either answer state)+  -> state+  -> Maybe (Either answer state)+foldCorridor triangulation from to first step =+  go (2 * numDirectedEdges triangulation + numVertices triangulation + 8) first+ where+  go !remaining !current !state+    | remaining <= 0 = Nothing+    | otherwise = case step state current of+        Left answer -> Just (Left answer)+        Right advanced ->+          case nextIntersection triangulation from to current of+            Nothing -> Just (Right advanced)+            Just following -> go (remaining - 1) following advanced+-- The early-answer 'Either' exists to let a caller stop at the first event it+-- cares about; it should not survive to runtime. Inlining the non-recursive+-- wrapper puts the worker at each call site with 'step' statically known, so+-- the constructor is matched where it is built — and at 'walkIntersections',+-- where the answer is 'Void', the left branch is erased outright.+{-# INLINE foldCorridor #-}++walkIntersections :: Triangulation mode vertex directed undirected face -> Point -> Point -> Intersection -> [Intersection]+walkIntersections triangulation from to first =+  case foldCorridor triangulation from to first collect [] of+    Nothing -> exactIntersectionScan triangulation from to+    Just (Left impossible) -> absurd impossible+    Just (Right events) -> reverse events+ where+  collect :: [Intersection] -> Intersection -> Either Void [Intersection]+  collect accumulated event = Right (event : accumulated)++nextIntersection :: Triangulation mode vertex directed undirected face -> Point -> Point -> Intersection -> Maybe Intersection+nextIntersection triangulation lineFrom lineTo current = case current of+  EdgeIntersection edge -> case traceDirectionOutOfEdge triangulation edge lineFrom lineTo of+    EdgeOutHull -> Nothing+    EdgeOutVertex vertex -> Just (VertexIntersection vertex)+    EdgeOutEdge nextEdge -> Just (EdgeIntersection nextEdge)+    EdgeOutNone -> Nothing+  VertexIntersection vertex+    | vertexPoint triangulation vertex == lineTo -> Nothing+    | otherwise -> case traceDirectionOutOfVertex triangulation vertex lineTo of+        VertexOutHull -> Nothing+        VertexOutOverlap edge -> Just (EdgeOverlap edge)+        VertexOutEdge edge ->+          let from = vertexPoint triangulation (origin triangulation edge)+              to = vertexPoint triangulation (destination triangulation edge)+           in if orient2d from to lineTo == LT then Nothing else Just (EdgeIntersection edge)+  EdgeOverlap edge+    | lineFrom == lineTo -> Nothing+    | onClosedSegment lineFrom lineTo (vertexPoint triangulation (destination triangulation edge)) ->+        Just (VertexIntersection (destination triangulation edge))+    | otherwise -> Nothing++firstIntersection :: Triangulation mode vertex directed undirected face -> QueryPoint -> QueryPoint -> Maybe Intersection+firstIntersection triangulation queryFrom queryTo =+  case locatePoint triangulation queryFrom of+    EmptyTriangulation -> singleVertexHit+    OnVertex vertex -> Just (VertexIntersection vertex)+    OnEdge edge -> Just (classifyStartingEdge edge)+    InFace face -> firstFromFace face+    OutsideConvexHull entry -> firstFromOutside entry+ where+  !lineFrom = queryPointValue queryFrom+  !lineTo = queryPointValue queryTo+  singleVertexHit = case vertices triangulation of+    [vertex]+      | onClosedSegment lineFrom lineTo (vertexPoint triangulation vertex) -> Just (VertexIntersection vertex)+    _ -> Nothing++  classifyStartingEdge edge =+    let a = vertexPoint triangulation (origin triangulation edge)+        b = vertexPoint triangulation (destination triangulation edge)+     in if orient2d lineFrom lineTo a == EQ && orient2d lineFrom lineTo b == EQ+          then EdgeOverlap (orientAlongLine edge)+          else EdgeIntersection (orientTowardTarget edge)++  firstFromFace face = firstEdgeFromRing (faceDirectedEdges triangulation face)++  firstEdgeFromRing [] = Nothing+  firstEdgeFromRing (edge : remaining) =+    let a = vertexPoint triangulation (origin triangulation edge)+        b = vertexPoint triangulation (destination triangulation edge)+     in if segmentIntersectsNonCollinear lineFrom lineTo a b+          then+            if orient2d lineFrom lineTo a == EQ+              then Just (VertexIntersection (origin triangulation edge))+              else+                if orient2d lineFrom lineTo b == EQ+                  then Just (VertexIntersection (destination triangulation edge))+                  else Just (EdgeIntersection (reverseEdge edge))+          else firstEdgeFromRing remaining++  -- Outside the region the segment's first contact with it lies on the ring+  -- the locator's edge sits on, so only that ring can carry the earliest+  -- event. A ring that outran its budget, an absent locator edge, and+  -- endpoints that leave the parameter comparison without a total order all+  -- keep the exact scan.+  firstFromOutside (Just edge)+    | finiteEndpoint lineFrom && finiteEndpoint lineTo =+        case ringEntryEvent triangulation lineFrom lineTo edge of+          Just entry -> eventValue <$> entry+          Nothing -> firstFromScan+  firstFromOutside _ = firstFromScan++  firstFromScan = case exactIntersectionScan triangulation lineFrom lineTo of+    event : _ -> Just event+    [] -> Nothing++  orientAlongLine edge =+    let a = vertexPoint triangulation (origin triangulation edge)+        b = vertexPoint triangulation (destination triangulation edge)+     in if projectionFactor lineFrom lineTo a <= projectionFactor lineFrom lineTo b then edge else reverseEdge edge++  orientTowardTarget edge =+    let a = vertexPoint triangulation (origin triangulation edge)+        b = vertexPoint triangulation (destination triangulation edge)+     in if orient2d a b lineTo == LT then reverseEdge edge else edge++data VertexOut+  = VertexOutHull+  | VertexOutOverlap !DirectedEdgeId+  | VertexOutEdge !DirectedEdgeId++data EdgeOut+  = EdgeOutHull+  | EdgeOutVertex !VertexId+  | EdgeOutEdge !DirectedEdgeId+  | EdgeOutNone++traceDirectionOutOfVertex :: Triangulation mode vertex directed undirected face -> VertexId -> Point -> VertexOut+traceDirectionOutOfVertex triangulation vertex target =+  case vertexOutEdge triangulation vertex of+    Nothing -> VertexOutHull+    Just start ->+      let !startSide = sideOf start+          !rotateCounterClockwise = startSide == GT+       in go rotateCounterClockwise (numDirectedEdges triangulation + 1) start startSide+ where+  go !rotateCounterClockwise !remaining !current !currentSide+    | remaining <= 0 = VertexOutHull+    | currentSide == EQ && projectionFactor currentPoint (edgeTarget current) target >= 0 =+        VertexOutOverlap current+    | otherwise =+        let following = if rotateCounterClockwise then counterClockwise triangulation current else clockwise triangulation current+            followingSide = sideOf following+         in if followingSide == EQ && projectionFactor currentPoint (edgeTarget following) target >= 0+              then VertexOutOverlap following+              else+                let faceBetween = if rotateCounterClockwise then incidentFace triangulation current else incidentFace triangulation following+                 in if faceBetween == outerFace+                      then VertexOutHull+                      else+                        if rotateCounterClockwise == (followingSide == LT)+                          then+                            let segment = if rotateCounterClockwise then next triangulation current else previous triangulation (reverseEdge current)+                             in VertexOutEdge (reverseEdge segment)+                          else go rotateCounterClockwise (remaining - 1) following followingSide++  currentPoint = vertexPoint triangulation vertex+  edgeTarget edge = vertexPoint triangulation (destination triangulation edge)+  sideOf edge = orient2d currentPoint (edgeTarget edge) target++traceDirectionOutOfEdge :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> Point -> Point -> EdgeOut+traceDirectionOutOfEdge triangulation edge lineFrom lineTo+  | incidentFace triangulation edge == outerFace = EdgeOutHull+  | otherwise =+      case (previousIntersects, nextIntersects) of+        (True, False) -> EdgeOutEdge (reverseEdge edgePrevious)+        (False, True) -> EdgeOutEdge (reverseEdge edgeNext)+        (True, True) -> EdgeOutVertex (origin triangulation edgePrevious)+        (False, False) -> EdgeOutNone+ where+  edgePrevious = previous triangulation edge+  edgeNext = next triangulation edge++  -- The face runs @edge@ A->B, @edgeNext@ B->C, @edgePrevious@ C->A, so the+  -- two candidates share C and each vertex's side of the line is read once+  -- rather than once per candidate. Whether the segment reaches a candidate is+  -- then asked only of one the line already separates, and a walk that entered+  -- across A->B leaves that true for exactly one of the two.+  pointA = vertexPoint triangulation (origin triangulation edge)+  pointB = vertexPoint triangulation (origin triangulation edgeNext)+  pointC = vertexPoint triangulation (origin triangulation edgePrevious)++  sideA = orient2d lineFrom lineTo pointA+  sideB = orient2d lineFrom lineTo pointB+  sideC = orient2d lineFrom lineTo pointC++  previousIntersects = sideC /= sideA && reaches pointC pointA+  nextIntersects = sideB /= sideC && reaches pointB pointC++  reaches from to = orient2d from to lineFrom /= orient2d from to lineTo++-- | Whether two segments properly cross; collinear touching does not.+segmentIntersectsNonCollinear :: Point -> Point -> Point -> Point -> Bool+segmentIntersectsNonCollinear p0 p1 q0 q1 =+  -- Equality admits an endpoint on the opposite segment; four equal sides+  -- reject the collinear case without recomputing either orientation pair.+  p0Side /= p1Side+    && q0Side /= q1Side+ where+  !p0Side = orient2d q0 q1 p0+  !p1Side = orient2d q0 q1 p1+  !q0Side = orient2d p0 p1 q0+  !q1Side = orient2d p0 p1 q1+{-# INLINE segmentIntersectsNonCollinear #-}++exactIntersectionScan :: Triangulation mode vertex directed undirected face -> Point -> Point -> [Intersection]+exactIntersectionScan triangulation lineFrom lineTo =+  map eventValue . sortBy compareEvent $ vertexEvents ++ edgeEvents+ where+  vertexEvents = mapMaybe (vertexEvent triangulation lineFrom lineTo) (vertices triangulation)+  edgeEvents = mapMaybe (edgeEvent triangulation lineFrom lineTo) (undirectedEdges triangulation)++data Event = Event+  { eventParameter :: !Double+  , eventPriority :: {-# UNPACK #-} !Int+  , eventValue :: !Intersection+  }++compareEvent :: Event -> Event -> Ordering+compareEvent = comparing (\event -> (eventParameter event, eventPriority event, eventValue event))++-- Ties in this order are the same 'Intersection', so a traversal that reaches+-- the minimum by a different route still reports the value the sorted scan's+-- head reports.+vertexEvent+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> Point+  -> VertexId+  -> Maybe (Event)+vertexEvent triangulation lineFrom lineTo vertex+  | onClosedSegment lineFrom lineTo point = Just (Event (projectionFactor lineFrom lineTo point) 0 (VertexIntersection vertex))+  | otherwise = Nothing+ where+  point = vertexPoint triangulation vertex++edgeEvent+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> Point+  -> UndirectedEdgeId+  -> Maybe (Event)+edgeEvent triangulation lineFrom lineTo edge+  | oa == EQ && ob == EQ =+      if low < high+        then Just (Event low 1 (EdgeOverlap (if projectedA <= projectedB then directed else reverseEdge directed)))+        else Nothing+  | segmentsIntersect lineFrom lineTo a b && oa /= EQ && ob /= EQ =+      Just (Event (segmentIntersectionParameter lineFrom lineTo a b) 2 (EdgeIntersection oriented))+  | otherwise = Nothing+ where+  directed = normalizedDirected edge+  a = vertexPoint triangulation (origin triangulation directed)+  b = vertexPoint triangulation (destination triangulation directed)+  oa = orient2d lineFrom lineTo a+  ob = orient2d lineFrom lineTo b+  projectedA = projectionFactor lineFrom lineTo a+  projectedB = projectionFactor lineFrom lineTo b+  low = max 0 (min projectedA projectedB)+  high = min 1 (max projectedA projectedB)+  oriented = if orient2d a b lineTo == LT then reverseEdge directed else directed++-- | The earliest event carried by the outer-face ring the given edge sits on,+-- walked from that edge. 'Nothing' reports a ring that outran its budget.+ringEntryEvent+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> Point+  -> DirectedEdgeId+  -> Maybe (Maybe (Event))+ringEntryEvent triangulation lineFrom lineTo entry =+  go (numDirectedEdges triangulation + 1) entry False Nothing+ where+  go !remaining !edge !departed !earliest+    | remaining <= 0 = Nothing+    | departed && edge == entry = Just earliest+    | otherwise =+        let !stepped =+              keepEarliest (edgeEvent triangulation lineFrom lineTo (asUndirected edge)) $+                keepEarliest (vertexEvent triangulation lineFrom lineTo (origin triangulation edge)) earliest+         in go (remaining - 1) (next triangulation edge) True stepped++keepEarliest :: Maybe (Event) -> Maybe (Event) -> Maybe (Event)+keepEarliest Nothing held = held+keepEarliest candidate Nothing = candidate+keepEarliest candidate@(Just proposed) held@(Just incumbent)+  | compareEvent proposed incumbent == LT = candidate+  | otherwise = held++finiteEndpoint :: Point -> Bool+finiteEndpoint point = isFinite (pointX point) && isFinite (pointY point)++segmentIntersectionParameter :: Point -> Point -> Point -> Point -> Double+segmentIntersectionParameter (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy)+  | denominator == 0 = 0+  | otherwise = ((cx - ax) * (dy - cy) - (cy - ay) * (dx - cx)) / denominator+ where+  denominator = (bx - ax) * (dy - cy) - (by - ay) * (dx - cx)
+ src-dcel/Moonlight/Triangulation/JoinSemilattice.hs view
@@ -0,0 +1,20 @@+-- | Payloads that can be glued coordinate-wise when triangulation site sets+-- overlap. The laws are the contract: implementations must be commutative,+-- associative, and idempotent.+module Moonlight.Triangulation.JoinSemilattice+  ( JoinSemilattice (..)+  ) where++-- | A join-semilattice carried by vertex annotations.+--+-- @+-- joinAnnotations left right == joinAnnotations right left+-- joinAnnotations (joinAnnotations a b) c == joinAnnotations a (joinAnnotations b c)+-- joinAnnotations value value == value+-- @+class Eq annotation => JoinSemilattice annotation where+  joinAnnotations :: annotation -> annotation -> annotation++instance JoinSemilattice () where+  joinAnnotations _ _ = ()+  {-# INLINE joinAnnotations #-}
+ src-dcel/Moonlight/Triangulation/Math.hs view
@@ -0,0 +1,439 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++module Moonlight.Triangulation.Math+  ( orient2d+  , sideQuery+  , inCircle+  , orientDetApprox+  , inCircleDetApprox+  , onClosedSegment+  , SegmentRelation (..)+  , allSegmentRelations+  , segmentRelation+  , segmentsProperlyCross+  , segmentsIntersect+  , squaredDistance+  , squaredDistanceWide+  , segmentDistanceSquared+  , segmentDistanceSquaredWide+  , distance+  , midpoint+  , centroid+  , triangleArea+  , triangleRadiusEdgeRatio+  , triangleRadiusEdgeRatioSquaredWithArea+  , circumcenter+  , barycentricCoordinates+  , inDiametralCircle+  , projectionFactor+  , canonicalPoint+  , canonicalCoordinate+  , validateCoordinate+  , mkQueryPoint+  , validatePoint+  , mitigateUnderflow+  , isFinite+  ) where++import Control.DeepSeq (NFData)+import GHC.Generics (Generic)+import Moonlight.Triangulation.Internal.Dyadic+  ( exactBarycentricDeterminants+  , exactDiametralDot+  , integerRatioToDouble+  )+import Moonlight.Triangulation.LineSideInfo (LineSideInfo, fromOrdering)+import Moonlight.Triangulation.Scalar+  ( canonicalScalarZero+  , inCircleCoordinates+  , maximumAllowedCoordinate+  , minimumAllowedCoordinate+  , orient2dCoordinates+  , scalarCcwErrorBound+  )+import Moonlight.Triangulation.Internal.Types+  ( BuildError (..)+  , CoordinateError (..)+  , Point (..)+  , PointValidationError (..)+  , QueryPoint (..)+  )++-- | The complete exact-predicate relation between two closed segments. There+-- is one vocabulary owner; traversal and constrained-union consumers derive+-- their booleans and obstruction policy from it rather than cloning slightly+-- different orientation formulae.+data SegmentRelation+  = SegmentsDisjoint+  | SegmentsDuplicate+  | SegmentsShareEndpoint+  | SegmentsProperlyCross+  | SegmentEndpointTouchesInterior+  | SegmentsCollinearlyOverlap+  deriving stock (Bounded, Enum, Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++allSegmentRelations :: [SegmentRelation]+allSegmentRelations = [minBound .. maxBound]++segmentRelation+  :: Point+  -> Point+  -> Point+  -> Point+  -> SegmentRelation+segmentRelation a b c d+  | sameUndirectedSegment = SegmentsDuplicate+  | sharesEndpoint = SegmentsShareEndpoint+  | opposite abC abD && opposite cdA cdB = SegmentsProperlyCross+  | abC == EQ && abD == EQ && cdA == EQ && cdB == EQ = collinearRelation+  | endpointTouches = SegmentEndpointTouchesInterior+  | otherwise = SegmentsDisjoint+ where+  !abC = orient2d a b c+  !abD = orient2d a b d+  !cdA = orient2d c d a+  !cdB = orient2d c d b+  sameUndirectedSegment = (a == c && b == d) || (a == d && b == c)+  sharesEndpoint = a == c || a == d || b == c || b == d+  endpointTouches =+    (abC == EQ && onClosedSegment a b c)+      || (abD == EQ && onClosedSegment a b d)+      || (cdA == EQ && onClosedSegment c d a)+      || (cdB == EQ && onClosedSegment c d b)+  collinearRelation =+    let !overlapLower = max (min a b) (min c d)+        !overlapUpper = min (max a b) (max c d)+     in case compare overlapLower overlapUpper of+          LT -> SegmentsCollinearlyOverlap+          EQ -> SegmentEndpointTouchesInterior+          GT -> SegmentsDisjoint+  opposite left right =+    (left == LT && right == GT) || (left == GT && right == LT)++segmentsIntersect+  :: Point+  -> Point+  -> Point+  -> Point+  -> Bool+segmentsIntersect a b c d = segmentRelation a b c d /= SegmentsDisjoint++-- | The proper-crossing section of 'segmentRelation'. Consumers which reject+-- only that constructor need not compute the collinear and endpoint-touch+-- distinctions required by the complete ADT after either side already proves+-- separation.+segmentsProperlyCross+  :: Point+  -> Point+  -> Point+  -> Point+  -> Bool+segmentsProperlyCross a b c d =+  opposite (orient2d a b c) (orient2d a b d)+    && opposite (orient2d c d a) (orient2d c d b)+ where+  opposite LT GT = True+  opposite GT LT = True+  opposite _ _ = False++validateCoordinate :: Double -> Maybe CoordinateError+validateCoordinate value+  | isNaN value = Just CoordinateNaN+  | isInfinite value = Just CoordinateInfinite+  | value /= 0 && abs value < minimumAllowedCoordinate = Just CoordinateTooSmall+  | abs value > maximumAllowedCoordinate = Just CoordinateTooLarge+  | otherwise = Nothing++-- | Admit and normalize a finite point for read-only geometric queries.+mkQueryPoint :: Point -> Either PointValidationError (QueryPoint)+mkQueryPoint point@(Point x y) = do+  maybe (Right ()) (Left . InvalidPointX) (validateCoordinate x)+  maybe (Right ()) (Left . InvalidPointY) (validateCoordinate y)+  Right (QueryPoint (canonicalPoint point))++validatePoint :: Maybe Int -> Point -> Either BuildError (QueryPoint)+validatePoint slot point@(Point x y) =+  case mkQueryPoint point of+    Left (InvalidPointX reason) -> Left (InvalidCoordinate slot x reason)+    Left (InvalidPointY reason) -> Left (InvalidCoordinate slot y reason)+    Right queryPoint -> Right queryPoint++-- | Round coordinates below the robust-predicate input floor toward zero.+-- The operation never changes a coordinate already accepted by+-- 'validateCoordinate'.+mitigateUnderflow :: Point -> Point+mitigateUnderflow (Point x y) = Point (mitigate x) (mitigate y)+ where+  mitigate :: Double -> Double+  mitigate value+    | value /= 0 && abs value < minimumAllowedCoordinate = 0+    | otherwise = value++canonicalPoint :: Point -> Point+canonicalPoint (Point x y) = Point (canonicalCoordinate x) (canonicalCoordinate y)+{-# INLINE canonicalPoint #-}++-- | Round a signed zero to the canonical zero. The law that makes two points+-- at the same position compare equal lives here; @canonicalPoint@ is its+-- component-wise form and coordinate-carrying callers use it directly so no+-- t'Point' is built only to be taken apart again.+canonicalCoordinate :: Double -> Double+canonicalCoordinate = canonicalScalarZero+{-# INLINE canonicalCoordinate #-}++-- base's 'isNaN' and 'isInfinite' are FFI calls in this GHC (static+-- ccall to isDoubleNaN/isDoubleInfinite), and a circumcentre pays four of+-- them per call. @value - value == 0@ is the same predicate in pure Double+-- arithmetic: finite values subtract to zero, while NaN and the infinities+-- subtract to NaN, which never compares equal.+isFinite :: Double -> Bool+isFinite value = value - value == 0+{-# INLINE isFinite #-}++orientDetApprox :: Point -> Point -> Point -> Double+orientDetApprox (Point ax ay) (Point bx by) (Point cx cy) =+  (ax - cx) * (by - cy) - (ay - cy) * (bx - cx)+{-# INLINE orientDetApprox #-}++orient2d :: Point -> Point -> Point -> Ordering+orient2d (Point ax ay) (Point bx by) (Point cx cy) =+  orient2dCoordinates ax ay bx by cx cy+{-# INLINE orient2d #-}++sideQuery :: Point -> Point -> Point -> LineSideInfo+sideQuery a b point = fromOrdering (orient2d a b point)+{-# INLINE sideQuery #-}++inCircleDetApprox+  :: Point -> Point -> Point -> Point -> Double+inCircleDetApprox+  (Point ax ay)+  (Point bx by)+  (Point cx cy)+  (Point dx dy) =+    alift * bcdet + blift * cadet + clift * abdet+ where+  !adx = ax - dx+  !ady = ay - dy+  !bdx = bx - dx+  !bdy = by - dy+  !cdx = cx - dx+  !cdy = cy - dy+  !abdet = adx * bdy - bdx * ady+  !bcdet = bdx * cdy - cdx * bdy+  !cadet = cdx * ady - adx * cdy+  !alift = adx * adx + ady * ady+  !blift = bdx * bdx + bdy * bdy+  !clift = cdx * cdx + cdy * cdy+{-# INLINE inCircleDetApprox #-}++-- | Ordering of the oriented incircle determinant. For a counter-clockwise+-- triangle, 'GT' means the fourth point lies strictly inside its circumcircle.+inCircle+  :: Point -> Point -> Point -> Point -> Ordering+inCircle+  (Point ax ay)+  (Point bx by)+  (Point cx cy)+  (Point dx dy) =+    inCircleCoordinates ax ay bx by cx cy dx dy+{-# INLINE inCircle #-}++onClosedSegment :: Point -> Point -> Point -> Bool+onClosedSegment a@(Point ax ay) b@(Point bx by) query@(Point qx qy) =+  orient2d a b query == EQ+    && qx >= min ax bx+    && qx <= max ax bx+    && qy >= min ay by+    && qy <= max ay by+{-# INLINE onClosedSegment #-}++squaredDistance :: Point -> Point -> Double+squaredDistance (Point ax ay) (Point bx by) =+  let !dx = ax - bx+      !dy = ay - by+   in dx * dx + dy * dy+{-# INLINE squaredDistance #-}++-- | Squared Euclidean distance in the mesh's Binary64 coordinate domain.+squaredDistanceWide :: Point -> Point -> Double+squaredDistanceWide = squaredDistance+{-# INLINE squaredDistanceWide #-}++segmentDistanceSquared+  :: Point -> Point -> Point -> Double+segmentDistanceSquared from@(Point ax ay) to@(Point bx by) point@(Point px py)+  | lengthSquared == 0 = squaredDistance from point+  | factor <= 0 = squaredDistance from point+  | factor >= 1 = squaredDistance to point+  | otherwise = squaredDistance point (Point (ax + factor * dx) (ay + factor * dy))+ where+  !dx = bx - ax+  !dy = by - ay+  !lengthSquared = dx * dx + dy * dy+  !factor = ((px - ax) * dx + (py - ay) * dy) / lengthSquared+{-# INLINE segmentDistanceSquared #-}++-- | Comparison form retained beside 'segmentDistanceSquared' for callers that+-- state metric intent explicitly.+segmentDistanceSquaredWide+  :: Point -> Point -> Point -> Double+segmentDistanceSquaredWide = segmentDistanceSquared+{-# INLINE segmentDistanceSquaredWide #-}++distance :: Point -> Point -> Double+distance left right = sqrt (squaredDistance left right)+{-# INLINE distance #-}++midpoint :: Point -> Point -> Point+midpoint (Point ax ay) (Point bx by) = Point (0.5 * ax + 0.5 * bx) (0.5 * ay + 0.5 * by)+{-# INLINE midpoint #-}++centroid :: Point -> Point -> Point -> Point+centroid (Point ax ay) (Point bx by) (Point cx cy) =+  Point (ax + (bx - ax) / 3 + (cx - ax) / 3) (ay + (by - ay) / 3 + (cy - ay) / 3)+{-# INLINE centroid #-}++triangleArea :: Point -> Point -> Point -> Double+triangleArea a b c = 0.5 * abs (orientDetApprox a b c)+{-# INLINE triangleArea #-}++triangleRadiusEdgeRatio+  :: Point -> Point -> Point -> Maybe Double+triangleRadiusEdgeRatio p0 p1 p2+  | area <= 0 || shortest <= 0 = Nothing+  | not (isFinite ratio) = Nothing+  | otherwise = Just ratio+ where+  !area = triangleArea p0 p1 p2+  !side01 = distance p0 p1+  !side12 = distance p1 p2+  !side20 = distance p2 p0+  !shortest = min side01 (min side12 side20)+  !otherProduct+    | side01 <= side12 && side01 <= side20 = side12 * side20+    | side12 <= side20 = side20 * side01+    | otherwise = side01 * side12+  !ratio = otherProduct / (4 * area)++-- | The square of 'triangleRadiusEdgeRatio', for a triangle whose area the+-- caller already has.+--+-- The ratio is only ever compared against a bound, and both sides are+-- non-negative, so the comparison can be made between squares. That is the+-- whole reason to have this: it settles the same question without the three+-- square roots the lengths would need, on the path taken by every face+-- refinement considers.+--+-- The area is a parameter and a degenerate triangle answers with an infinity+-- rather than an absence, because the caller on that path has already computed+-- the area to ask the area question and does nothing with the absence but+-- compare an infinity in its place.+triangleRadiusEdgeRatioSquaredWithArea+  :: Double -> Point -> Point -> Point -> Double+triangleRadiusEdgeRatioSquaredWithArea area p0 p1 p2+  | area <= 0 || shortest <= 0 = 1 / 0+  | not (isFinite ratio) = 1 / 0+  | otherwise = ratio+ where+  !side01 = squaredDistance p0 p1+  !side12 = squaredDistance p1 p2+  !side20 = squaredDistance p2 p0+  !shortest = min side01 (min side12 side20)+  !otherProduct+    | side01 <= side12 && side01 <= side20 = side12 * side20+    | side12 <= side20 = side20 * side01+    | otherwise = side01 * side12+  !ratio = otherProduct / (16 * area * area)++-- The scale the determinants are divided by cancels out of the quotient+-- exactly, so the computation works on the unscaled differences and divides+-- once per coordinate. Scaling would only matter against overflow, and the+-- validated coordinate domain (|x| <= 3.3e60) keeps every intermediate below+-- 1e183, five orders below the Double ceiling; the four divisions it cost+-- are the circumcentre's hot-path price. Identical points answer through the+-- denominator, which is exactly zero exactly when they are collinear.+circumcenter+  :: Point -> Point -> Point -> Maybe (Point)+circumcenter (Point ax ay) (Point bx by) (Point cx cy)+  | denominator == 0 = Nothing+  | not (isFinite resultX && isFinite resultY) = Nothing+  | otherwise = Just (canonicalPoint (Point resultX resultY))+ where+  !bax = bx - ax+  !bay = by - ay+  !cax = cx - ax+  !cay = cy - ay+  !bLength = bax * bax + bay * bay+  !cLength = cax * cax + cay * cay+  !denominator = 2 * (bax * cay - bay * cax)+  !offsetX = (cay * bLength - bay * cLength) / denominator+  !offsetY = (bax * cLength - cax * bLength) / denominator+  !resultX = ax + offsetX+  !resultY = ay + offsetY++barycentricCoordinates+  :: Point -> Point -> Point -> Point+  -> Maybe (Double, Double, Double)+barycentricCoordinates a@(Point ax ay) b@(Point bx by) c@(Point cx cy) query@(Point qx qy)+  | all reliable [denominatorInfo, weightAInfo, weightBInfo, weightCInfo] =+      if denominator == 0+        then Nothing+        else Just (weightA / denominator, weightB / denominator, weightC / denominator)+  | exactDenominator == 0 = Nothing+  | otherwise =+      Just+        ( integerRatioToDouble exactWeightA exactDenominator+        , integerRatioToDouble exactWeightB exactDenominator+        , integerRatioToDouble exactWeightC exactDenominator+        )+ where+  !denominatorInfo@(denominator, _) = determinantInfo a b c+  !weightAInfo@(weightA, _) = determinantInfo query b c+  !weightBInfo@(weightB, _) = determinantInfo a query c+  !weightCInfo@(weightC, _) = determinantInfo a b query+  (!exactDenominator, !exactWeightA, !exactWeightB, !exactWeightC) =+    exactBarycentricDeterminants ax ay bx by cx cy qx qy++  reliable (determinant, determinantSum) =+    isFinite determinant && abs determinant > scalarCcwErrorBound * determinantSum++  determinantInfo :: Point -> Point -> Point -> (Double, Double)+  determinantInfo (Point px py) (Point rx ry) (Point sx sy) =+    let !left = (px - sx) * (ry - sy)+        !right = (py - sy) * (rx - sx)+     in (left - right, abs left + abs right)++-- | Whether a point lies in the closed diametral disk of a segment, decided by+-- the sign of @(a-p)·(b-p)@.+--+-- The approximation is two coordinate differences and one product per term+-- combined additively, which is the arithmetic shape 'orient2d' is analysed+-- under: the forward error of @fl(fl(a⊖b) ⊗ fl(c⊖d))@ combined by one rounded+-- addition does not depend on the sign of that combination. The orientation+-- coefficient therefore transfers unchanged, and the exact dot product remains+-- the oracle for the uncertain band.+inDiametralCircle :: Point -> Point -> Point -> Bool+inDiametralCircle (Point ax ay) (Point bx by) (Point px py)+  | isFinite dot && abs dot > scalarCcwErrorBound * dotSum = dot < 0+  | otherwise = exactDiametralDot ax ay bx by px py <= 0+ where+  !left = (ax - px) * (bx - px)+  !right = (ay - py) * (by - py)+  !dot = left + right+  !dotSum = abs left + abs right+{-# INLINE inDiametralCircle #-}++projectionFactor :: Point -> Point -> Point -> Double+projectionFactor (Point ax ay) (Point bx by) (Point qx qy)+  | lengthSquared == 0 = 0+  | otherwise = ((qx - ax) * dx + (qy - ay) * dy) / lengthSquared+ where+  !dx = bx - ax+  !dy = by - ay+  !lengthSquared = dx * dx + dy * dy+{-# INLINE projectionFactor #-}
+ src-dcel/Moonlight/Triangulation/Payload.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE RankNTypes #-}++-- | The payload parameters' functorial and traversable structure: relabeling a+-- payload touches no geometry, so every law here holds for the reason that a+-- triangulation's points and its annotations are separate things.+module Moonlight.Triangulation.Payload+  ( PayloadTraversal+  , vertexPayloads+  , directedPayloads+  , undirectedPayloads+  , facePayloads+  , mapVertices+  , mapDirectedEdges+  , mapUndirectedEdges+  , mapFaces+  , overPayloads+  , foldPayloads+  , payloadList+  ) where++import Data.Functor.Const (Const (..))+import Data.Functor.Identity (Identity (..))+import Data.Monoid (Endo (..))+import Moonlight.Triangulation.Internal.Representation+  ( PayloadTraversal+  , directedPayloads+  , facePayloads+  , mapDirectedEdges+  , mapFaces+  , mapUndirectedEdges+  , mapVertices+  , undirectedPayloads+  , vertexPayloads+  )++-- | Relabel every payload a traversal reaches.+--+-- The 'mapVertices' family is this at each parameter and cheaper: a pure map+-- leaves an unmaterialized page unmaterialized, where a traversal must visit+-- every slot the page would have reported and so materializes it. Reach for+-- this one when the traversal is chosen at runtime, and for the named map when+-- the parameter is known where you stand.+overPayloads+  :: PayloadTraversal source target payload payload'+  -> (payload -> payload')+  -> source+  -> target+overPayloads traversal relabel = runIdentity . traversal (Identity . relabel)+{-# INLINE overPayloads #-}++-- | Summarize every payload a traversal reaches.+foldPayloads+  :: Monoid summary+  => PayloadTraversal source source payload payload+  -> (payload -> summary)+  -> source+  -> summary+foldPayloads traversal measure = getConst . traversal (Const . measure)+{-# INLINE foldPayloads #-}++-- | Every payload a traversal reaches, in visit order. Accumulated through+-- t'Endo' so the list is built by a right fold rather than by repeated append.+payloadList :: PayloadTraversal source source payload payload -> source -> [payload]+payloadList traversal source = appEndo (foldPayloads traversal (Endo . (:)) source) []+{-# INLINE payloadList #-}
+ src-dcel/Moonlight/Triangulation/PointLocation.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE BangPatterns #-}++-- | Walk location over the finite mesh; the hinted form takes a starting point+-- and reports the steps it spent.+module Moonlight.Triangulation.PointLocation+  ( locatePoint+  , locatePointWithHint+  ) where++import Data.List (find)+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Handles.Iterators.FixedIterators+import Moonlight.Triangulation.Internal.FaceProbe+import Moonlight.Triangulation.Math+import Moonlight.Triangulation.Types++locatePoint :: Triangulation mode vertex directed undirected face -> QueryPoint -> Location+locatePoint triangulation query = fst (locatePointWithHint triangulation Nothing query)++locatePointWithHint :: Triangulation mode vertex directed undirected face -> Maybe LocationHint -> QueryPoint -> (Location, LocationStats)+locatePointWithHint triangulation hint queryPoint+  | numVertices triangulation == 0 = (EmptyTriangulation, emptyLocationStats)+  | numInnerFaces triangulation == 0 = (locateDegenerate triangulation query, emptyLocationStats)+  | otherwise = walk budget 0 startFace+ where+  !query = queryPointValue queryPoint+  !budget = max 8 (numFaces triangulation + numUndirectedEdges triangulation + 4)+  !startFace = chooseStart triangulation hint++  walk !remaining !steps !face+    | remaining <= 0 = scanAll steps+    | face == outerFace =+        (outsideLocation triangulation query, LocationStats steps False)+    | otherwise =+        case probeFace triangulation face query of+          FaceHit location -> (location, LocationStats (steps + 1) False)+          FaceCross edge ->+            let adjacent = incidentFace triangulation edge+             in if adjacent == outerFace+                  then (OutsideConvexHull (Just edge), LocationStats (steps + 1) False)+                  else walk (remaining - 1) (steps + 1) adjacent+          FaceMiss -> scanAll (steps + 1)++  scanAll !steps =+    case findHit (innerFaces triangulation) of+      Just location -> (location, LocationStats steps True)+      Nothing -> (outsideLocation triangulation query, LocationStats steps True)++  findHit [] = Nothing+  findHit (face : remaining) =+    case probeFace triangulation face query of+      FaceHit location -> Just location+      _ -> findHit remaining++data FaceProbe = FaceHit !Location | FaceCross !DirectedEdgeId | FaceMiss++probeFace :: Triangulation mode vertex directed undirected face -> FaceId -> Point -> FaceProbe+probeFace triangulation face query =+  case innerFaceDirectedEdges triangulation face of+    Nothing -> FaceMiss+    Just (e0, e1, e2) -> classify [e0, e1, e2] Nothing+ where+  classify [] Nothing = FaceHit (InFace face)+  classify [] (Just edge) = FaceCross edge+  classify (edge : remaining) crossing =+    let fromVertex = origin triangulation edge+        toVertex = destination triangulation edge+        from = vertexPoint triangulation fromVertex+        to = vertexPoint triangulation toVertex+     in case probeBoundary reverseEdge query edge fromVertex from toVertex to of+          BoundaryClear -> classify remaining crossing+          BoundaryOnVertex vertex -> FaceHit (OnVertex vertex)+          BoundaryOnEdge boundary -> FaceHit (OnEdge boundary)+          BoundaryCrossing boundary -> classify remaining (Just boundary)++locateDegenerate :: Triangulation mode vertex directed undirected face -> Point -> Location+locateDegenerate triangulation query =+  case find ((== query) . vertexPoint triangulation) (vertices triangulation) of+    Just vertex -> OnVertex vertex+    Nothing ->+      case find contains (undirectedEdges triangulation) of+        Just edge -> OnEdge (normalizedDirected edge)+        Nothing ->+          case undirectedEdges triangulation of+            [] -> OutsideConvexHull Nothing+            edge : _ ->+              let forward = normalizedDirected edge+                  from = vertexPoint triangulation (origin triangulation forward)+                  to = vertexPoint triangulation (destination triangulation forward)+                  directed = case orient2d from to query of+                    GT -> forward+                    LT -> reverseEdge forward+                    EQ -> forward+               in OutsideConvexHull (Just directed)+ where+  contains edge =+    let forward = normalizedDirected edge+     in onClosedSegment+          (vertexPoint triangulation (origin triangulation forward))+          (vertexPoint triangulation (destination triangulation forward))+          query++outsideLocation :: Triangulation mode vertex directed undirected face -> Point -> Location+outsideLocation triangulation query =+  OutsideConvexHull (find visible (faceDirectedEdges triangulation outerFace))+ where+  visible edge =+    orient2d+      (vertexPoint triangulation (origin triangulation edge))+      (vertexPoint triangulation (destination triangulation edge))+      query+      /= LT++chooseStart :: Triangulation mode vertex directed undirected face -> Maybe LocationHint -> FaceId+chooseStart triangulation hint =+  case hint of+    Just (FaceHint face@(FaceId index))+      | index > 0 && fromIntegral index < numFaces triangulation -> face+    Just (VertexHint vertex@(VertexId index))+      | toInteger index < toInteger (numVertices triangulation) ->+          case [face | edge <- vertexOutgoingEdges triangulation vertex, let face = incidentFace triangulation edge, face /= outerFace] of+            face : _ -> face+            [] -> FaceId 1+      | otherwise -> FaceId 1+    _ -> FaceId 1+
+ src-dcel/Moonlight/Triangulation/Types.hs view
@@ -0,0 +1,40 @@+-- | The package vocabulary: sites and validated queries, the mode-indexed+-- triangulation, what construction returns, and the closed failure types.+module Moonlight.Triangulation.Types+  ( Point (..)+  , SiteRelation (..)+  , QueryPoint+  , queryPointValue+  , PointValidationError (..)+  , HasPosition (..)+  , ElementDefaults (..)+  , unitElementDefaults+  , ConstraintMode (..)+  , KnownConstraintMode (..)+  , Triangulation+  , DelaunayTriangulation+  , ConstrainedDelaunayTriangulation+  , BuildResult (..)+  , InsertionDisposition (..)+  , InsertionResult (..)+  , BuildStats (..)+  , emptyBuildStats+  , CoordinateError (..)+  , NonFiniteValue (..)+  , classifyNonFinite+  , BuildError (..)+  , Location (..)+  , LocationHint (..)+  , LocationStats (..)+  , emptyLocationStats+  , NearestStats (..)+  , RefinementParameters (..)+  , defaultRefinementParameters+  , RefinementReceipt (..)+  , RefinementDomainResult (..)+  , RefinementResult (..)+  , InvariantViolation (..)+  ) where++import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types
+ src-dcel/Moonlight/Triangulation/Validation.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE BangPatterns #-}++-- | Discharge: the invariants the constructors guarantee, checkable on a value+-- built by any route.+module Moonlight.Triangulation.Validation+  ( validateTopology+  , validateDelaunay+  , validateTriangulation+  , triangulationIsValid+  , faceArea+  , faceMinimumAngleDegrees+  ) where++import Data.List (nub)+import qualified Data.IntSet as IntSet+import Moonlight.Triangulation.Internal.BoxedPaged (boxedPagedLength)+import Moonlight.Triangulation.Internal.Paged (pagedFoldl', pagedLength, pagedUnsafeIndex)+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (allFaces, directedEdges, undirectedEdges, vertices)+import Moonlight.Triangulation.Internal.PackedIndex (noIndex)+import Moonlight.Triangulation.Math+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types++-- | Every structural invariant violated, not the first.+validateTopology :: Triangulation mode vertex directed undirected face -> [InvariantViolation]+validateTopology triangulation =+  structuralViolations ++ orientationViolations+ where+  verticesCount = numVertices triangulation+  halfCount = numDirectedEdges triangulation+  edgeCount = numUndirectedEdges triangulation+  facesCount = numFaces triangulation++  -- Geometry descends only after the finite DCEL has glued structurally.+  -- Reading triangle coordinates through malformed links would turn a typed+  -- validation failure into an indexing crash.+  structuralViolations =+    cardinalityViolations+      ++ rangeViolations+      ++ edgeViolations+      ++ faceViolations+      ++ vertexViolations+      ++ eulerViolations++  orientationViolations+    | not (null structuralViolations) = []+    | otherwise =+        [ InnerFaceNotCounterClockwise face+        | face <- allFaces triangulation+        , face /= outerFace+        , Just (first, second, third) <- [innerFaceVertices triangulation face]+        , orient2d+            (vertexPoint triangulation first)+            (vertexPoint triangulation second)+            (vertexPoint triangulation third)+            /= GT+        ]++  cardinalityViolations =+    [ CoordinatePlaneLengthMismatch pointXCount pointYCount+    | pointXCount /= pointYCount+    ]+      ++ [VertexOutgoingLengthMismatch vertexOutCount verticesCount | vertexOutCount /= verticesCount]+      ++ [VertexPayloadLengthMismatch vertexPayloadCount verticesCount | vertexPayloadCount /= verticesCount]+      ++ [TopologyArenaLengthMismatch topologyLength (4 * halfCount) | not halfArraysEqual]+      ++ [DirectedPayloadLengthMismatch directedPayloadCount halfCount | directedPayloadCount /= halfCount]+      ++ [UndirectedPayloadLengthMismatch undirectedPayloadCount edgeCount | undirectedPayloadCount /= edgeCount]+      ++ [DirectedEdgeCountOdd halfCount | odd halfCount]+      ++ [ConstraintLengthMismatch constraintLength edgeCount | constraintLength /= edgeCount]+      ++ [ NonCanonicalConstraintFlag (UndirectedEdgeId (fromIntegral index)) flag+         | index <- [0 .. pagedLength (triConstraint triangulation) - 1]+         , let flag = pagedUnsafeIndex (triConstraint triangulation) index+         , flag /= 0 && flag /= 1+         ]+      ++ [CachedConstraintCountMismatch (triConstraintCount triangulation) actualConstraintCount | triConstraintCount triangulation /= actualConstraintCount]+      ++ [CachedConstraintIndexMismatch | triConstraintEdges triangulation /= indexedConstraintEdges]+      ++ [MissingOuterFace | facesCount == 0]+      ++ [FacePayloadLengthMismatch facePayloadCount facesCount | facePayloadCount /= facesCount]++  pointXCount = pagedLength (triPointX triangulation)+  pointYCount = pagedLength (triPointY triangulation)+  vertexOutCount = pagedLength (triVertexOut triangulation)+  vertexPayloadCount = boxedPagedLength (triVertexData triangulation)+  topologyLength = pagedLength (triHalfTopology triangulation)+  directedPayloadCount = boxedPagedLength (triDirectedData triangulation)+  undirectedPayloadCount = boxedPagedLength (triUndirectedData triangulation)+  constraintLength = pagedLength (triConstraint triangulation)+  facePayloadCount = boxedPagedLength (triFaceData triangulation)+  actualConstraintCount = pagedFoldl' (\count flag -> if flag == 1 then count + 1 else count) 0 (triConstraint triangulation)+  halfArraysEqual = topologyLength == 4 * halfCount++  indexedConstraintEdges =+    IntSet.fromAscList+      [ index+      | index <- [0 .. edgeCount - 1]+      , pagedUnsafeIndex (triConstraint triangulation) index == 1+      ]++  rangeViolations =+    [ EdgeOriginOutOfRange (DirectedEdgeId (fromIntegral index)) (VertexId value) verticesCount+    | index <- [0 .. halfCount - 1]+    , let value = pagedUnsafeIndex (triHalfTopology triangulation) (4 * index)+    , fromIntegral value >= verticesCount+    ]+      ++ [ EdgeNextOutOfRange (DirectedEdgeId (fromIntegral index)) (DirectedEdgeId value) halfCount+         | index <- [0 .. halfCount - 1]+         , let value = pagedUnsafeIndex (triHalfTopology triangulation) (4 * index + 1)+         , fromIntegral value >= halfCount+         ]+      ++ [ EdgePreviousOutOfRange (DirectedEdgeId (fromIntegral index)) (DirectedEdgeId value) halfCount+         | index <- [0 .. halfCount - 1]+         , let value = pagedUnsafeIndex (triHalfTopology triangulation) (4 * index + 2)+         , fromIntegral value >= halfCount+         ]+      ++ [ EdgeFaceOutOfRange (DirectedEdgeId (fromIntegral index)) (FaceId value) facesCount+         | index <- [0 .. halfCount - 1]+         , let value = pagedUnsafeIndex (triHalfTopology triangulation) (4 * index + 3)+         , fromIntegral value >= facesCount+         ]+      ++ [ VertexOutgoingOutOfRange (VertexId (fromIntegral index)) (DirectedEdgeId value) halfCount+         | index <- [0 .. pagedLength (triVertexOut triangulation) - 1]+         , let value = pagedUnsafeIndex (triVertexOut triangulation) index+         , value /= noIndex+         , fromIntegral value >= halfCount+         ]+      ++ [ FaceAdjacentOutOfRange (FaceId (fromIntegral index)) (DirectedEdgeId value) halfCount+         | index <- [0 .. facesCount - 1]+         , let value = pagedUnsafeIndex (triFaceEdge triangulation) index+         , value /= noIndex+         , fromIntegral value >= halfCount+         ]++  edgeViolations+    | not halfArraysEqual || odd halfCount = []+    | otherwise = concatMap validateEdge (directedEdges triangulation)++  validateEdge edge@(DirectedEdgeId raw) =+    let index = fromIntegral raw+        nextEdge = next triangulation edge+        previousEdge = previous triangulation edge+        twinEdge = reverseEdge edge+        local =+          [ EdgeNextPreviousMismatch edge nextEdge+          | validEdge nextEdge && previous triangulation nextEdge /= edge+          ]+            ++ [ EdgePreviousNextMismatch edge previousEdge+               | validEdge previousEdge && next triangulation previousEdge /= edge+               ]+            ++ [EdgeDoubleReversalMismatch edge | reverseEdge twinEdge /= edge]+            ++ [EdgeSelfLinkedNext edge | nextEdge == edge && halfCount > 2]+            ++ [EdgeSelfLinkedPrevious edge | previousEdge == edge && halfCount > 2]+        innerCycle =+          if incidentFace triangulation edge /= outerFace && validEdge nextEdge && validEdge previousEdge+            then+              [ InnerFaceNotTriangularAtEdge edge+              | next triangulation (next triangulation nextEdge) /= edge+              ]+            else []+     in if index < halfCount then local ++ innerCycle else []++  validEdge (DirectedEdgeId value) = fromIntegral value < halfCount++  faceViolations = concatMap validateFace (allFaces triangulation)+  validateFace face@(FaceId _) =+    case adjacentEdge triangulation face of+      Nothing+        | face == outerFace && halfCount == 0 -> []+        | otherwise -> [FaceMissingAdjacentEdge face]+      Just edge ->+        [ FaceRepresentativeMismatch face edge representedFace+        | let representedFace = incidentFace triangulation edge+        , representedFace /= face+        ]+          ++ [ InnerFaceVertexCardinalityMismatch face (length faceVertexIds) (length (nub faceVertexIds))+             | face /= outerFace+             , let faceVertexIds = faceVertices triangulation face+             , length faceVertexIds /= 3 || length (nub faceVertexIds) /= 3+             ]++  vertexViolations = concatMap validateVertex (vertices triangulation)+  validateVertex vertex = case vertexOutEdge triangulation vertex of+    Nothing+      | verticesCount <= 1 -> []+      | otherwise -> [ConnectedVertexMissingOutgoing vertex]+    Just edge ->+      [ VertexOutgoingOriginMismatch vertex edge actualOrigin+      | let actualOrigin = origin triangulation edge+      , actualOrigin /= vertex+      ]+++  eulerViolations+    | not (null cardinalityViolations) || verticesCount < 2 = []+    | numInnerFaces triangulation == 0 =+        [ CollinearEdgeCountMismatch (verticesCount - 1) edgeCount+        | edgeCount /= verticesCount - 1+        ]+    | otherwise =+        [ EulerCharacteristicMismatch eulerCharacteristic+        | eulerCharacteristic /= 2+        ]+   where+    eulerCharacteristic = verticesCount - edgeCount + facesCount++-- | Every edge whose circumcircle is not empty.+validateDelaunay :: Triangulation mode vertex directed undirected face -> [InvariantViolation]+validateDelaunay triangulation = concatMap validateEdge (undirectedEdges triangulation)+ where+  validateEdge edge+    | isConstraintEdge triangulation edge = []+    | isBoundaryEdge triangulation edge = []+    | otherwise =+        let directed = normalizedDirected edge+            twin = reverseEdge directed+         in case (innerFaceDirectedEdges triangulation (incidentFace triangulation directed), innerFaceDirectedEdges triangulation (incidentFace triangulation twin)) of+              (Just _, Just _) ->+                let a = vertexPoint triangulation (origin triangulation directed)+                    b = vertexPoint triangulation (destination triangulation directed)+                    c = vertexPoint triangulation (origin triangulation (previous triangulation directed))+                    d = vertexPoint triangulation (origin triangulation (previous triangulation twin))+                    convex = orient2d c d b == GT && orient2d d c a == GT+                    circle = inCircle a b c d+                    illegal = convex && (circle == GT || (circle == EQ && orderedPair c d < orderedPair a b))+                 in [LocallyIllegalDelaunayEdge edge | illegal]+              _ -> [DelaunayIncidentFaceNotTriangular edge]++-- | Topology first; the Delaunay property only if the topology holds.+validateTriangulation+  :: Triangulation mode vertex directed undirected face+  -> [InvariantViolation]+validateTriangulation triangulation =+  let topology = validateTopology triangulation+   in if null topology+        then validateDelaunay triangulation+        else topology++-- | Whether 'validateTriangulation' is empty.+triangulationIsValid+  :: Triangulation mode vertex directed undirected face+  -> Bool+triangulationIsValid = null . validateTriangulation++-- | Signed area, or 'Nothing' where the face is not a triangle.+faceArea :: Triangulation mode vertex directed undirected face -> FaceId -> Maybe Double+faceArea triangulation face = do+  (v0, v1, v2) <- innerFaceVertices triangulation face+  pure (triangleArea (vertexPoint triangulation v0) (vertexPoint triangulation v1) (vertexPoint triangulation v2))++-- | Smallest interior angle, in degrees.+faceMinimumAngleDegrees :: Triangulation mode vertex directed undirected face -> FaceId -> Maybe Double+faceMinimumAngleDegrees triangulation face = do+  (v0, v1, v2) <- innerFaceVertices triangulation face+  let p0 = vertexPoint triangulation v0+      p1 = vertexPoint triangulation v1+      p2 = vertexPoint triangulation v2+      a = sqrt (squaredDistance p1 p2)+      b = sqrt (squaredDistance p2 p0)+      c = sqrt (squaredDistance p0 p1)+  if min a (min b c) <= 0+    then Nothing+    else Just (minimum [angle b c a, angle c a b, angle a b c])+ where+  angle left right opposite = acos (clamp ((left * left + right * right - opposite * opposite) / (2 * left * right))) * 180 / pi+  clamp = max (-1) . min 1++orderedPair :: Ord a => a -> a -> (a, a)+orderedPair a b = if a <= b then (a, b) else (b, a)
+ src-dual/Moonlight/Triangulation/HintGenerator.hs view
@@ -0,0 +1,482 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}++module Moonlight.Triangulation.HintGenerator+  ( LastUsedHint+  , emptyLastUsedHint+  , lastUsedHint+  , rememberVertex+  , HierarchyHint+  , defaultHierarchyBranchFactor+  , buildHierarchyHint+  , hierarchyHint+  , hierarchyBranchFactor+  , hierarchyBaseCount+  , hierarchyLevelCount+  , hierarchyVertexCount+  , updateHierarchyAfterInsertion+  , updateHierarchyAfterRemoval+  , rebuildHierarchyHint+  , removeManyWithHierarchy+  ) where++import qualified Data.Vector as V+import Control.DeepSeq (NFData)+import Data.List (sort)+import Data.Word (Word32)+import Moonlight.Triangulation.BulkLoad (delaunay, insert)+import Moonlight.Triangulation.Dcel (numUndirectedEdges, numVertices, undirectedEndpoints, vertexPoint)+import Moonlight.Triangulation.Handles.HandleDefs (UndirectedEdgeId (..), VertexId (..))+import Moonlight.Triangulation.Interpolation (nearestNeighbor)+import Moonlight.Triangulation.Math (canonicalPoint, validatePoint)+import Moonlight.Triangulation.Removal (RemovalOutcome, removalTriangulation, removeVertex)+import Moonlight.Triangulation.Session (removeManyAtNear, withSession)+import Moonlight.Triangulation.Types+import GHC.Generics (Generic)++newtype LastUsedHint = LastUsedHint (Maybe VertexId)+  deriving stock (Show)+  deriving newtype (Eq, Ord)++emptyLastUsedHint :: LastUsedHint+emptyLastUsedHint = LastUsedHint Nothing++lastUsedHint :: LastUsedHint -> Maybe LocationHint+lastUsedHint (LastUsedHint vertex) = VertexHint <$> vertex++rememberVertex :: VertexId -> LastUsedHint -> LastUsedHint+rememberVertex vertex _ = LastUsedHint (Just vertex)++-- | A Delaunay hierarchy for logarithmic expected random point location.+-- The first vector element is the finest sparse level; the final element is+-- the coarsest. The base triangulation is not duplicated.+--+-- The levels are nested by a single arithmetic law rather than by a stored+-- correspondence. Level @i@ holds every @branch^(i+1)@-th base vertex in base+-- order, so a level-local handle @j@ names handle @j * branch@ one level finer+-- — and at level 0 the finer level is the base mesh itself, under the very+-- same multiplication. Descent therefore never rediscovers a handle it has+-- already computed, and no level carries an index vector.+--+-- 'hierarchyBaseCount' is the base cardinality the levels were sampled from.+-- It is the hierarchy's claim about which triangulation it answers for, and+-- every maintenance entry is stated against it: a base whose cardinality is not+-- the one recorded here plus the movement the operation performs is not the+-- base this hierarchy describes, and is rebuilt for rather than patched.+data HierarchyHint = HierarchyHint+  { hierarchyBranchFactor :: {-# UNPACK #-} !Int+  , hierarchyBaseCount :: {-# UNPACK #-} !Int+  , hierarchyLevels :: !(V.Vector (Triangulation 'Unconstrained (Point) () () ()))+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++instance Show (HierarchyHint) where+  showsPrec precedence hierarchy =+    showParen (precedence > 10) $+      showString "HierarchyHint "+        . shows (hierarchyBranchFactor hierarchy)+        . showString " "+        . shows (hierarchyBaseCount hierarchy)+        . showString " "+        . shows (hierarchyLevelCount hierarchy)+        . showString " "+        . shows (hierarchyVertexCount hierarchy)++instance Eq (HierarchyHint) where+  left == right =+    hierarchyBranchFactor left == hierarchyBranchFactor right+      && hierarchyBaseCount left == hierarchyBaseCount right+      && hierarchyLevelCount left == hierarchyLevelCount right+      && V.and (V.zipWith sameSparseMesh (hierarchyLevels left) (hierarchyLevels right))++-- Two sparse levels are the same hint when they carry the same points and the+-- same undirected edges. Half-edge index labelling records the order+-- construction happened to visit, so a level rebuilt from scratch and a level+-- extended in place are structurally equal while their arrays are not.+sameSparseMesh+  :: Triangulation 'Unconstrained (Point) () () ()+  -> Triangulation 'Unconstrained (Point) () () ()+  -> Bool+sameSparseMesh left right =+  numVertices left == numVertices right+    && numUndirectedEdges left == numUndirectedEdges right+    && meshPoints left == meshPoints right+    && meshEdges left == meshEdges right+ where+  meshPoints+    :: Triangulation mode vertex directed undirected face+    -> [Point]+  meshPoints triangulation =+    sort [vertexPoint triangulation (VertexId (fromIntegral index)) | index <- [0 .. numVertices triangulation - 1]]++  meshEdges+    :: Triangulation mode vertex directed undirected face+    -> [(Point, Point)]+  meshEdges triangulation =+    sort+      [ if from <= to then (from, to) else (to, from)+      | index <- [0 .. numUndirectedEdges triangulation - 1]+      , let (fromVertex, toVertex) = undirectedEndpoints triangulation (UndirectedEdgeId (fromIntegral index))+            from = vertexPoint triangulation fromVertex+            to = vertexPoint triangulation toVertex+      ]++defaultHierarchyBranchFactor :: Int+defaultHierarchyBranchFactor = 16++hierarchyLevelCount :: HierarchyHint -> Int+hierarchyLevelCount = V.length . hierarchyLevels++hierarchyVertexCount :: HierarchyHint -> Int+hierarchyVertexCount =+  V.foldl' (\total level -> total + numVertices level) 0 . hierarchyLevels++-- | Build nested sparse Delaunay levels. A branch factor of 16 mirrors Spade's+-- default and gives O(log n) expected descent on uniformly distributed input.+--+-- Each level is bulk loaded from the sampled points in base order. Base+-- vertices carry pairwise distinct positions, so the load deduplicates nothing+-- and assigns local handle @j@ to sample @j@ — which is what makes the nesting+-- law on 'hierarchyLevels' an identity rather than a lookup.+buildHierarchyHint+  :: Int+  -> Triangulation mode vertex directed undirected face+  -> Either BuildError (HierarchyHint)+buildHierarchyHint requestedBranch triangulation =+  HierarchyHint branch count <$> V.mapM buildLevel levelDivisors+ where+  !branch = max 2 requestedBranch+  !count = numVertices triangulation+  levelDivisors =+    V.unfoldr+      (\candidate ->+         case candidate of+           Nothing -> Nothing+           Just divisor ->+             let !population = samplePopulation count divisor+                 next =+                   if population <= 1+                     then Nothing+                     else Just (safeMultiply divisor branch)+              in Just (divisor, next)+      )+      (if count <= 0 then Nothing else Just branch)++  buildLevel divisor =+    buildTriangulation+      <$> delaunay+        unitElementDefaults+        ( V.generate+            (samplePopulation count divisor)+            (\index ->+               vertexPoint+                 triangulation+                 (VertexId (fromIntegral (index * divisor)))+            )+        )++-- | Descend from the coarsest sparse triangulation. The handle a level returns+-- is carried to the next finer level by one multiplication, and the same+-- multiplication at level 0 names the base vertex. Nothing is relocated: the+-- coarse answer is not searched for again, it is computed.+hierarchyHint :: HierarchyHint -> QueryPoint -> Maybe LocationHint+hierarchyHint HierarchyHint{hierarchyBranchFactor, hierarchyLevels} query =+  VertexHint <$> descend (V.length hierarchyLevels - 1) Nothing+ where+  !branch = fromIntegral hierarchyBranchFactor :: Word32++  descend !levelIndex !coarse+    | levelIndex < 0 = Nothing+    | otherwise =+        case nearestNeighbor (hierarchyLevels V.! levelIndex) coarse query of+          Nothing -> Nothing+          Just (VertexId local, _) ->+            let !finer = VertexId (local * branch)+             in if levelIndex == 0 then Just finer else descend (levelIndex - 1) (Just finer)+++-- | Update the nested hierarchy from an insertion's own report: the point the+-- insertion was asked for, the handle it answered, and whether it created a+-- site. Only the levels selected by the branch divisibility rule are changed.+-- Unaffected levels are structurally shared.+--+-- No triangulation is named. The hierarchy walks its own levels and nothing+-- else, so a base was only ever a lookup table for three facts — its+-- cardinality, the stored position of the new vertex, and the position of+-- vertex zero — and every one of them is in the report or already in the+-- levels, because level-local handle zero is base handle zero at every level.+-- A caller maintaining the hierarchy across a run of insertions therefore+-- never has to publish a mesh to be allowed to speak to it, which is the whole+-- cost of the arrangement this replaces: one full arena copy per step, paid+-- only to name the thing that was just edited.+--+-- An insertion that found its point already present created no site, and a+-- hierarchy valid for a triangulation is valid for that same triangulation, so+-- the answer is the argument, unexamined.+updateHierarchyAfterInsertion+  :: HierarchyHint+  -> Point+  -> VertexId+  -> InsertionDisposition+  -> Either BuildError (HierarchyHint)+updateHierarchyAfterInsertion hierarchy requested vertex disposition =+  case disposition of+    AlreadyPresent -> Right hierarchy+    Inserted+      | vertexIndex vertex /= baseIndex ->+          Left+            ( HierarchyInsertionHandleMismatch+                (VertexId (fromIntegral baseIndex))+                vertex+            )+      | otherwise -> do+          updated <- updateLevels branch (V.toList (hierarchyLevels hierarchy))+          topped <- ensureSingletonTop updated+          pure+            hierarchy+              { hierarchyBaseCount = baseIndex + 1+              , hierarchyLevels = V.fromList topped+              }+ where+  !branch = hierarchyBranchFactor hierarchy+  !baseIndex = hierarchyBaseCount hierarchy+  -- A level holds what the mesh stores, not what the caller wrote: storage+  -- rounds a signed zero, and a level built from the unrounded point would+  -- settle a distance tie against a different handle.+  !point = canonicalPoint requested++  -- An update is the only operation that can break the nesting law, so the law+  -- is stated here as an equation rather than trusted: a level admitted to the+  -- new base vertex must already hold exactly @baseIndex / divisor@ samples,+  -- and must receive the vertex at its end.+  updateLevels !_ [] = Right []+  updateLevels !divisor levels@(level : rest)+    | baseIndex `rem` divisor /= 0 = Right levels+    | safeMultiply (numVertices level) divisor /= baseIndex =+        Left+          ( HierarchyLevelPopulationMismatch+              divisor+              (numVertices level)+              baseIndex+          )+    | otherwise = do+        inserted <- insert level point+        if vertexIndex (insertionVertex inserted) /= numVertices level+          then+            Left+              ( HierarchyInsertionHandleMismatch+                  (VertexId (fromIntegral (numVertices level)))+                  (insertionVertex inserted)+              )+          else (insertionTriangulation inserted :) <$> updateLevels (safeMultiply divisor branch) rest++  -- With no levels at all the base was empty, so the vertex just appended is+  -- vertex zero. Otherwise vertex zero is the finest level's local vertex+  -- zero, under the same law that makes the descent a multiplication.+  ensureSingletonTop [] = pure <$> singletonLevel point+  ensureSingletonTop levels@(finest : _) =+    case reverse levels of+      top : _+        | numVertices top <= 1 -> Right levels+        | otherwise ->+            (\first -> levels ++ [first])+              <$> singletonLevel (vertexPoint finest (VertexId 0))+      [] -> Right levels++-- | Repair the nested hierarchy from a removal's swap report — the slot+-- compaction freed and the position of the vertex it moved into that slot, or+-- 'Nothing' when the removal took the last vertex and compaction moved+-- nothing — rather than rebuilding because removal renumbers.+--+-- No triangulation is named, for the reason 'updateHierarchyAfterInsertion'+-- gives: the only base position this repair cannot find in its own levels is+-- the relocated vertex's, and that is what the report carries.+--+-- Swap compaction moves exactly one vertex — the former last one, into the slot+-- the removed vertex vacated — so a level's sample sequence changes in at most+-- one place, and which place is decided by the two divisibilities the level's+-- divisor gives the freed slot and the vacated last index:+--+-- * neither is sampled: the level, and every coarser level above it, is+--   untouched, because a divisor that divides neither index is divided by no+--   multiple of itself either;+-- * the vacated index is sampled and the freed slot is not: the level loses its+--   last sample and nothing else;+-- * both are sampled: the level loses its last sample and that sample's point+--   lands in the freed slot's local position — which is the level's own swap+--   removal, mirroring the base's;+-- * the freed slot is sampled and the vacated index is not: the level keeps its+--   population and substitutes the relocated position at an interior local+--   slot. No removal expresses a substitution, so that level is rebuilt — from+--   its own points and the reported one, never from a mesh.+--+-- The last case is the only one that pays a build, and it is the rarest: it+-- needs the freed slot to be sampled and the vacated index not to be.+updateHierarchyAfterRemoval+  :: HierarchyHint+  -> Maybe (VertexId, Point)+  -> Either BuildError (HierarchyHint)+updateHierarchyAfterRemoval hierarchy swap+  | baseCount <= 0 = Left (RemovalEmptyTriangulation (maybe (VertexId 0) fst swap))+  | otherwise = do+      repaired <- repairLevels branch (V.toList (hierarchyLevels hierarchy))+      pure+        hierarchy+          { hierarchyBaseCount = surviving+          , hierarchyLevels = V.fromList (levelsThroughSingleton repaired)+          }+ where+  !branch = hierarchyBranchFactor hierarchy+  !baseCount = hierarchyBaseCount hierarchy+  !surviving = baseCount - 1+  -- The freed slot is the removed vertex's own index, and it is where the+  -- former last vertex now stands. A removal that took the last vertex frees+  -- no slot and reports none, and its removed index is that last index.+  !freedSlot = maybe surviving (vertexIndex . fst) swap+  !vacatedIndex = surviving++  -- The nesting law is stated here as an equation for the same reason the+  -- insertion path states it: a repair is the other operation that can break+  -- it. A level the removal reaches must hold exactly the samples the+  -- pre-removal base owed it.+  repairLevels !_ [] = Right []+  repairLevels !divisor levels@(level : rest)+    | not freedSampled && not vacatedSampled = Right levels+    | numVertices level /= population =+        Left+          ( HierarchyLevelPopulationMismatch+              divisor+              (numVertices level)+              baseCount+          )+    | otherwise =+        case swap of+          -- The two divisibilities differ only when the two indices do, so a+          -- level reaching the substitution has a relocation to substitute:+          -- the guard cannot hold while compaction moved nothing.+          Just (_, relocated)+            | freedSampled && not vacatedSampled -> do+                substituted <- substituteSample level (freedSlot `quot` divisor) relocated+                (substituted :) <$> repairLevels (safeMultiply divisor branch) rest+          _ -> do+            shrunk <- removeVertex level (VertexId (fromIntegral localSample))+            (removalTriangulation shrunk :) <$> repairLevels (safeMultiply divisor branch) rest+   where+    !freedSampled = freedSlot `rem` divisor == 0+    !vacatedSampled = vacatedIndex `rem` divisor == 0+    !population = samplePopulation baseCount divisor+    !localSample+      | freedSampled = freedSlot `quot` divisor+      | otherwise = population - 1++  -- A build stops at the first level holding one sample, and removal only+  -- shrinks populations, so the shape a rebuild would answer with is this list+  -- cut after its first singleton.+  levelsThroughSingleton+    :: [Triangulation mode vertex directed undirected face]+    -> [Triangulation mode vertex directed undirected face]+  levelsThroughSingleton [] = []+  levelsThroughSingleton (level : rest)+    | numVertices level <= 0 = []+    | numVertices level <= 1 = [level]+    | otherwise = level : levelsThroughSingleton rest++-- | The coarsest level a growing hierarchy needs: one sample, the base's+-- vertex zero.+singletonLevel+  :: Point+  -> Either BuildError (Triangulation 'Unconstrained (Point) () () ())+singletonLevel origin =+  buildTriangulation <$> delaunay unitElementDefaults (V.singleton origin)++-- | The level a substitution asks for: the same samples in the same local+-- order, one slot carrying the relocated position instead of the one that+-- left. Stated over the level's own points, so no mesh is consulted.+substituteSample+  :: Triangulation 'Unconstrained (Point) () () ()+  -> Int+  -> Point+  -> Either BuildError (Triangulation 'Unconstrained (Point) () () ())+substituteSample level localSlot relocated =+  buildTriangulation+    <$> delaunay+      unitElementDefaults+      ( V.generate+          (numVertices level)+          (\index ->+            if index == localSlot+              then relocated+              else vertexPoint level (VertexId (fromIntegral index))+          )+      )++-- | Rebuild a hierarchy after an operation that may renumber vertices, such as+-- removal. The branch factor remains canonical.+rebuildHierarchyHint+  :: HierarchyHint+  -> Triangulation mode vertex directed undirected face+  -> Either BuildError (HierarchyHint)+rebuildHierarchyHint hierarchy = buildHierarchyHint (hierarchyBranchFactor hierarchy)++-- | Remove many points, each locate starting from the hierarchy's nearest+-- sample instead of the mesh boundary. One session publishes once; the+-- hierarchy is rebuilt against the surviving mesh and returned alongside it.+removeManyWithHierarchy+  :: HierarchyHint+  -> Triangulation mode vertex directed undirected face+  -> V.Vector (Point)+  -> Either+      BuildError+      ( V.Vector (Maybe (RemovalOutcome vertex))+      , Triangulation mode vertex directed undirected face+      , HierarchyHint+      )+removeManyWithHierarchy hierarchy triangulation points = do+  queryPoints <- traverse (validatePoint Nothing) points+  let guesses = fmap hierarchyGuess queryPoints+  (outcomes, surviving, _) <-+    withSession triangulation 0 (removeManyAtNear guesses points)+  repaired <- rebuildHierarchyHint hierarchy surviving+  pure (outcomes, surviving, repaired)+ where+  hierarchyGuess queryPoint =+    case hierarchyHint hierarchy queryPoint of+      Just (VertexHint vertex) -> Just vertex+      _ -> Nothing++safeMultiply :: Int -> Int -> Int+safeMultiply left right+  | left > maxBound `quot` right = maxBound+  | otherwise = left * right++-- | How many samples a divisor takes from a base of this size. Sampling takes+-- index zero and every @divisor@-th index after it; the direct+-- vector generator above states the same ceiling without constructing an+-- intermediate handle list.+samplePopulation :: Int -> Int -> Int+samplePopulation count divisor+  | count <= 0 = 0+  | otherwise = 1 + (count - 1) `quot` divisor++vertexIndex :: VertexId -> Int+vertexIndex (VertexId value) = fromIntegral value++-- The hierarchy is consulted once per query from another package, so its+-- polymorphic entries expose their unfoldings for the same reason the search+-- itself does.+--+-- The two level constructors are listed for a second reason, and the list is+-- not complete without them: they are overloaded and the entries call them, so+-- an entry specialised in the consumer that reaches an unspecialised+-- constructor threads the dictionary right back into the build it was+-- specialised to avoid. Only a stable unfolding is a specialisation candidate+-- across a package boundary; the optimised one GHC publishes on its own is not.+-- These two were 'where' bindings before they were named, and a 'where' binding+-- is specialised with the function that encloses it — so naming them is what+-- put the dictionary in, and this is what takes it back out.
+ src-dual/Moonlight/Triangulation/Internal/InterpolationWorkspace.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}++module Moonlight.Triangulation.Internal.InterpolationWorkspace+  ( NaturalNeighborWorkspace (..)+  , newNaturalNeighborWorkspace+  , nextFaceGeneration+  , nextOriginGeneration+  , workspaceBytes+  ) where++import Control.Monad.Primitive (PrimMonad, PrimState)+import Control.Monad.ST (ST)+import Data.Primitive.MutVar+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32)+import Moonlight.Triangulation.Dcel (numDirectedEdges, numFaces, numVertices)+import Moonlight.Triangulation.Internal.Representation (Triangulation)+import Moonlight.Triangulation.Internal.Types (ConstraintMode)+import Moonlight.Triangulation.Scalar (scalarByteSize)++-- | Reusable scratch space for Sibson interpolation. It borrows no mutable+-- topology: the immutable triangulation is the sole owner, while these arrays+-- are query-local marks, queues and numeric work buffers.+data NaturalNeighborWorkspace state (mode :: ConstraintMode) vertex directed undirected face = NaturalNeighborWorkspace+  { nnTriangulation :: !(Triangulation mode vertex directed undirected face)+  , nnFaceMarks :: !(MUV.MVector state Word32)+  , nnFaceSeenMarks :: !(MUV.MVector state Word32)+    -- The circumcentre plane is stamped by the same generation as the two mark+    -- planes above, and that is what makes it sound: a generation is minted+    -- once per Sibson query, and the circumcentre a face contributes is a+    -- function of the face and the query point together. Holding the plane to+    -- exactly one generation's lifetime holds the query point fixed for as long+    -- as an entry can be read.+  , nnCircumcenterMarks :: !(MUV.MVector state Word32)+  , nnFaceGeneration :: !(MutVar state Word32)+  , nnCircumcenterX :: !(MUV.MVector state Double)+  , nnCircumcenterY :: !(MUV.MVector state Double)+  , nnFaceQueue :: !(MUV.MVector state Word32)+  , nnCavityFaces :: !(MUV.MVector state Word32)+  , nnBoundaryEdges :: !(MUV.MVector state Word32)+  , nnOrderedEdges :: !(MUV.MVector state Word32)+  , nnOriginMarks :: !(MUV.MVector state Word32)+  , nnOriginGeneration :: !(MutVar state Word32)+  , nnOriginEdge :: !(MUV.MVector state Word32)+  , nnInsertionX :: !(MUV.MVector state Double)+  , nnInsertionY :: !(MUV.MVector state Double)+  , nnWeightVertex :: !(MUV.MVector state Word32)+  , nnWeightValue :: !(MUV.MVector state Double)+  }++newNaturalNeighborWorkspace+  :: PrimMonad m+  => Triangulation mode vertex directed undirected face+  -> m (NaturalNeighborWorkspace (PrimState m) mode vertex directed undirected face)+newNaturalNeighborWorkspace triangulation = do+  let !faceCapacity = max 1 (numFaces triangulation)+      !edgeCapacity = max 1 (numDirectedEdges triangulation)+      !vertexCapacity = max 1 (numVertices triangulation)+  faceMarks <- MUV.replicate faceCapacity 0+  faceSeenMarks <- MUV.replicate faceCapacity 0+  circumcenterMarks <- MUV.replicate faceCapacity 0+  faceGeneration <- newMutVar 0+  circumcenterX <- MUV.new faceCapacity+  circumcenterY <- MUV.new faceCapacity+  faceQueue <- MUV.new faceCapacity+  cavityFaces <- MUV.new faceCapacity+  boundaryEdges <- MUV.new edgeCapacity+  orderedEdges <- MUV.new edgeCapacity+  originMarks <- MUV.replicate vertexCapacity 0+  originGeneration <- newMutVar 0+  originEdge <- MUV.new vertexCapacity+  insertionX <- MUV.new edgeCapacity+  insertionY <- MUV.new edgeCapacity+  weightVertex <- MUV.new edgeCapacity+  weightValue <- MUV.new edgeCapacity+  pure NaturalNeighborWorkspace+    { nnTriangulation = triangulation+    , nnFaceMarks = faceMarks+    , nnFaceSeenMarks = faceSeenMarks+    , nnCircumcenterMarks = circumcenterMarks+    , nnFaceGeneration = faceGeneration+    , nnCircumcenterX = circumcenterX+    , nnCircumcenterY = circumcenterY+    , nnFaceQueue = faceQueue+    , nnCavityFaces = cavityFaces+    , nnBoundaryEdges = boundaryEdges+    , nnOrderedEdges = orderedEdges+    , nnOriginMarks = originMarks+    , nnOriginGeneration = originGeneration+    , nnOriginEdge = originEdge+    , nnInsertionX = insertionX+    , nnInsertionY = insertionY+    , nnWeightVertex = weightVertex+    , nnWeightValue = weightValue+    }++nextFaceGeneration :: NaturalNeighborWorkspace s mode vertex directed undirected face -> ST s Word32+nextFaceGeneration workspace = do+  current <- readMutVar (nnFaceGeneration workspace)+  let !next = current + 1+  if next == 0+    then do+      MUV.set (nnFaceMarks workspace) 0+      MUV.set (nnFaceSeenMarks workspace) 0+      MUV.set (nnCircumcenterMarks workspace) 0+      writeMutVar (nnFaceGeneration workspace) 1+      pure 1+    else writeMutVar (nnFaceGeneration workspace) next >> pure next++nextOriginGeneration :: NaturalNeighborWorkspace s mode vertex directed undirected face -> ST s Word32+nextOriginGeneration workspace = nextGeneration (nnOriginMarks workspace) (nnOriginGeneration workspace)++nextGeneration :: MUV.MVector s Word32 -> MutVar s Word32 -> ST s Word32+nextGeneration marks reference = do+  current <- readMutVar reference+  let !next = current + 1+  if next == 0+    then do+      MUV.set marks 0+      writeMutVar reference 1+      pure 1+    else writeMutVar reference next >> pure next++workspaceBytes+  :: NaturalNeighborWorkspace state mode vertex directed undirected face+  -> Integer+workspaceBytes workspace =+  4 * toInteger wordSlots+    + toInteger scalarByteSize * toInteger scalarSlots+ where+  wordSlots =+    MUV.length (nnFaceMarks workspace)+      + MUV.length (nnFaceSeenMarks workspace)+      + MUV.length (nnCircumcenterMarks workspace)+      + MUV.length (nnFaceQueue workspace)+      + MUV.length (nnCavityFaces workspace)+      + MUV.length (nnBoundaryEdges workspace)+      + MUV.length (nnOrderedEdges workspace)+      + MUV.length (nnOriginMarks workspace)+      + MUV.length (nnOriginEdge workspace)+      + MUV.length (nnWeightVertex workspace)+  scalarSlots =+    MUV.length (nnCircumcenterX workspace)+      + MUV.length (nnCircumcenterY workspace)+      + MUV.length (nnInsertionX workspace)+      + MUV.length (nnInsertionY workspace)+      + MUV.length (nnWeightValue workspace)
+ src-dual/Moonlight/Triangulation/Interpolation.hs view
@@ -0,0 +1,889 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- | Nearest, barycentric, and natural-neighbor interpolation over one+-- authoritative triangulation.+module Moonlight.Triangulation.Interpolation+  ( BarycentricWeights (..)+  , InterpolationStats (..)+  , NaturalNeighborResult (..)+  , NaturalNeighborWorkspace+  , newNaturalNeighborWorkspace+  , workspaceBytes+  , nearestNeighbor+  , barycentricWeights+  , naturalNeighborWeights+  , foldNaturalNeighborWeights+  , interpolateNearest+  , interpolateBarycentric+  , interpolateNaturalNeighbor+  , estimateGradient+  , estimateGradients+  , interpolateNaturalNeighborGradient+  ) where++import Control.DeepSeq (NFData)+import Control.Monad.ST (ST)+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32)+import Moonlight.Triangulation.Dcel+  ( destination+  , counterClockwise+  , foldVertexOutgoingEdges'+  , incidentFace+  , innerFaceDirectedEdges+  , innerFaceVertices+  , isBoundaryEdge+  , next+  , numConstraints+  , numDirectedEdges+  , numVertices+  , origin+  , outerFace+  , vertexOutEdge+  , vertexPoint+  )+import Moonlight.Triangulation.Handles.HandleDefs+  ( DirectedEdgeId (..)+  , asUndirected+  , FaceId (..)+  , VertexId (..)+  , reverseEdge+  )+import Moonlight.Triangulation.Internal.InterpolationWorkspace+import Moonlight.Triangulation.Math+  ( barycentricCoordinates+  , circumcenter+  , inCircle+  , isFinite+  , projectionFactor+  , squaredDistanceWide+  )+import Moonlight.Triangulation.PointLocation (locatePointWithHint)+import Moonlight.Triangulation.Scalar (scalarEpsilon)+import Moonlight.Triangulation.Types+  ( Location (..)+  , LocationHint+  , LocationStats+  , NearestStats (..)+  , Point (..)+  , QueryPoint+  , queryPointValue+  , Triangulation+  )+import GHC.Generics (Generic)++-- | Barycentric weights use the mesh's binary64 coordinate domain.+data BarycentricWeights+  = NoWeights+  | OneWeight !VertexId+  | TwoWeights !VertexId !Double !VertexId !Double+  | ThreeWeights !VertexId !Double !VertexId !Double !VertexId !Double+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++data InterpolationStats = InterpolationStats+  { interpolationCavityFaces :: {-# UNPACK #-} !Int+  , interpolationNaturalNeighbors :: {-# UNPACK #-} !Int+  , interpolationFaceTests :: {-# UNPACK #-} !Int+    -- | 'True' exactly when the Sibson pipeline declined and the returned+    -- weights are the barycentric coordinates of the located face instead.+    -- A silent degradation from Sibson to barycentric is a defect that hides;+    -- this bit is the announcement.+  , interpolationUsedFallback :: !Bool+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data NaturalNeighborResult = NaturalNeighborResult+  { naturalNeighborValues :: !(V.Vector (VertexId, Double))+  , naturalNeighborLocationStats :: !LocationStats+  , naturalNeighborStats :: !InterpolationStats+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Nearest vertex and query work, using an optional admitted vertex as the+-- descent seed. Empty triangulations have no nearest vertex.+nearestNeighbor+  :: Triangulation mode vertex directed undirected face+  -> Maybe VertexId+  -> QueryPoint+  -> Maybe (VertexId, NearestStats)+nearestNeighbor triangulation hint queryPoint+  | numVertices triangulation == 0 = Nothing+  | numConstraints triangulation == 0 = Just (descend start startDistance 0 0)+  | otherwise = Just (walk start startDistance 0 0)+ where+  !query = queryPointValue queryPoint+  !start = validateHint hint+  !startDistance = squaredDistanceWide query (vertexPoint triangulation start)+  !bound = numDirectedEdges triangulation + numVertices triangulation + 1++  validateHint (Just vertex@(VertexId index))+    | fromIntegral index < numVertices triangulation = vertex+  validateHint _ = VertexId 0++  -- A vertex's Voronoi cell is the intersection of the half-planes its+  -- Delaunay neighbours induce, so a query outside that cell violates one of+  -- them and some neighbour is strictly closer. Descending on the /first/+  -- strict improvement therefore lands on the same vertex as descending on the+  -- best one, having tested about half of the star on average instead of all+  -- of it. The argument needs the Delaunay property, so a constrained+  -- triangulation keeps the exhaustive scan below.+  descend !current !currentDistance !steps !tests+    | steps >= bound = (current, NearestStats steps tests)+    | otherwise =+        case vertexOutEdge triangulation current of+          Nothing -> (current, NearestStats steps tests)+          Just ring -> revolve current currentDistance steps ring ring Nothing tests++  -- Equal-distance neighbours are not an improvement, so they cannot end the+  -- revolution early; the lowest such handle is carried to the end and taken+  -- only if nothing strictly closer appeared. That is the same deterministic+  -- tie the exhaustive scan settles on.+  revolve !current !currentDistance !steps !edge !ring !tie !tests+    | candidateDistance < currentDistance =+        descend candidate candidateDistance (steps + 1) nextTests+    | nextEdge == ring =+        case nextTie of+          Just settled -> descend settled currentDistance (steps + 1) nextTests+          Nothing -> (current, NearestStats steps nextTests)+    | otherwise = revolve current currentDistance steps nextEdge ring nextTie nextTests+   where+    !candidate = destination triangulation edge+    !candidateDistance = squaredDistanceWide query (vertexPoint triangulation candidate)+    !nextTests = tests + 1+    !nextEdge = counterClockwise triangulation edge+    !nextTie+      | candidateDistance == currentDistance && candidate < current =+          case tie of+            Just held | held <= candidate -> tie+            _ -> Just candidate+      | otherwise = tie++  walk !current !currentDistance !steps !tests+    | steps >= bound = (current, NearestStats steps tests)+    | otherwise =+        let (!candidate, !candidateDistance, !newTests) =+              foldVertexOutgoingEdges'+                triangulation+                current+                inspect+                (current, currentDistance, tests)+         in if candidate == current+              then (current, NearestStats steps newTests)+              else walk candidate candidateDistance (steps + 1) newTests++  inspect (!best, !bestDistance, !tests) edge =+    let !candidate = destination triangulation edge+        !candidateDistance = squaredDistanceWide query (vertexPoint triangulation candidate)+        !isBetter =+          candidateDistance < bestDistance+            || (candidateDistance == bestDistance && candidate < best)+     in if isBetter+          then (candidate, candidateDistance, tests + 1)+          else (best, bestDistance, tests + 1)++barycentricWeights+  :: Triangulation mode vertex directed undirected face+  -> Maybe LocationHint+  -> QueryPoint+  -> (BarycentricWeights, LocationStats)+barycentricWeights triangulation hint queryPoint =+  let !query = queryPointValue queryPoint+      (!location, !stats) = locatePointWithHint triangulation hint queryPoint+   in (weightsFor query location, stats)+ where+  weightsFor _ (OnVertex vertex) = OneWeight vertex+  weightsFor query (OnEdge edge) =+    let !from = origin triangulation edge+        !to = destination triangulation edge+        !factor = clamp 0 1 (projectionFactor (vertexPoint triangulation from) (vertexPoint triangulation to) query)+     in TwoWeights from (1 - factor) to factor+  weightsFor query (InFace face) =+    case innerFaceVertices triangulation face of+      Nothing -> NoWeights+      Just (a, b, c) ->+        case barycentricCoordinates+          (vertexPoint triangulation a)+          (vertexPoint triangulation b)+          (vertexPoint triangulation c)+          query of+          Nothing -> NoWeights+          Just (wa, wb, wc) -> ThreeWeights a wa b wb c wc+  weightsFor _ EmptyTriangulation = NoWeights+  weightsFor _ (OutsideConvexHull _) = NoWeights++-- | Calculate Sibson coordinates using fixed-capacity reusable scratch storage.+-- The only per-query heap object is the returned boxed vector.+naturalNeighborWeights+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Maybe LocationHint+  -> QueryPoint+  -> ST s (NaturalNeighborResult)+naturalNeighborWeights workspace hint queryPoint = do+  (!count, !locationStats, !stats) <- queryNaturalNeighborWorkspace workspace hint queryPoint+  values <- V.generateM count $ \index -> do+    rawVertex <- MUV.unsafeRead (nnWeightVertex workspace) index+    weight <- MUV.unsafeRead (nnWeightValue workspace) index+    pure (VertexId rawVertex, weight)+  pure NaturalNeighborResult+    { naturalNeighborValues = values+    , naturalNeighborLocationStats = locationStats+    , naturalNeighborStats = stats+    }++-- | Strictly fold the Sibson coordinates held in a reusable workspace. Unlike+-- 'naturalNeighborWeights', this does not allocate a result vector. It is the+-- canonical path for repeated interpolation and other reductions.+foldNaturalNeighborWeights+  :: (accumulator -> VertexId -> Double -> accumulator)+  -> accumulator+  -> NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Maybe LocationHint+  -> QueryPoint+  -> ST s (accumulator, LocationStats, InterpolationStats)+foldNaturalNeighborWeights combine initial workspace hint query = do+  (!count, !locationStats, !stats) <- queryNaturalNeighborWorkspace workspace hint query+  value <- go 0 initial count+  pure (value, locationStats, stats)+ where+  go !index !accumulator !count+    | index >= count = pure accumulator+    | otherwise = do+        rawVertex <- MUV.unsafeRead (nnWeightVertex workspace) index+        weight <- MUV.unsafeRead (nnWeightValue workspace) index+        let !nextAccumulator = combine accumulator (VertexId rawVertex) weight+        go (index + 1) nextAccumulator count++queryNaturalNeighborWorkspace+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Maybe LocationHint+  -> QueryPoint+  -> ST s (Int, LocationStats, InterpolationStats)+queryNaturalNeighborWorkspace workspace hint queryPoint = do+  let !triangulation = nnTriangulation workspace+      !query = queryPointValue queryPoint+      (!location, !locationStats) = locatePointWithHint triangulation hint queryPoint+  (!count, !stats) <- case location of+    OnVertex vertex -> do+      writeWeight workspace 0 vertex 1+      pure (1, InterpolationStats 0 1 0 False)+    OnEdge edge+      | isBoundaryEdge triangulation (asUndirected edge) -> do+          let !from = origin triangulation edge+              !to = destination triangulation edge+              !factor = clamp 0 1 (projectionFactor (vertexPoint triangulation from) (vertexPoint triangulation to) query)+          writeWeight workspace 0 from (1 - factor)+          writeWeight workspace 1 to factor+          pure (2, InterpolationStats 0 2 0 False)+      | otherwise ->+          let !left = incidentFace triangulation edge+              !right = incidentFace triangulation (reverseEdge edge)+              !start = if left /= outerFace then left else right+           in sibsonQuery workspace query start+    InFace face -> sibsonQuery workspace query face+    EmptyTriangulation -> pure (0, InterpolationStats 0 0 0 False)+    OutsideConvexHull _ -> pure (0, InterpolationStats 0 0 0 False)+  pure (count, locationStats, stats)++sibsonQuery+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Point+  -> FaceId+  -> ST s (Int, InterpolationStats)+sibsonQuery workspace query startFace = do+  generation <- nextFaceGeneration workspace+  (cavityCount, faceTests) <- discoverCavity workspace generation query startFace+  boundaryCount <- collectBoundary workspace generation cavityCount+  orderedCount <- orderBoundary workspace boundaryCount+  if orderedCount < 3+    then fallbackBarycentric workspace query startFace faceTests cavityCount+    else do+      cellOkay <- buildInsertionCell workspace query orderedCount+      if not cellOkay+        then fallbackBarycentric workspace query startFace faceTests cavityCount+        else do+          weightCount <- buildStolenAreas workspace generation query orderedCount+          normalized <- normalizeWeights workspace weightCount+          if normalized+            then pure (weightCount, InterpolationStats cavityCount weightCount faceTests False)+            else fallbackBarycentric workspace query startFace faceTests cavityCount++-- The query cavity is exactly the set of faces whose circumcircles contain the+-- inserted point. Generation marks make clearing O(1).+discoverCavity+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Word32+  -> Point+  -> FaceId+  -> ST s (Int, Int)+discoverCavity workspace generation query (FaceId rawStart) = do+  MUV.unsafeWrite (nnFaceSeenMarks workspace) (fromIntegral rawStart) generation+  MUV.unsafeWrite (nnFaceQueue workspace) 0 rawStart+  go 1 0 0+ where+  !triangulation = nnTriangulation workspace+  go !queueSize !cavitySize !tests+    | queueSize <= 0 = pure (cavitySize, tests)+    | otherwise = do+        let !slot = queueSize - 1+        rawFace <- MUV.unsafeRead (nnFaceQueue workspace) slot+        let !face = FaceId rawFace+            !inside = containsQuery triangulation query face+            !tests' = tests + 1+        if not inside+          then go slot cavitySize tests'+          else do+            MUV.unsafeWrite (nnFaceMarks workspace) (fromIntegral rawFace) generation+            MUV.unsafeWrite (nnCavityFaces workspace) cavitySize rawFace+            nextQueue <- pushNeighbors triangulation workspace generation slot face+            go nextQueue (cavitySize + 1) tests'++containsQuery+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> FaceId+  -> Bool+containsQuery triangulation query face =+  case innerFaceVertices triangulation face of+    Nothing -> False+    Just (a, b, c) ->+      -- Strictly inside, matching spade's contained_in_circumference: an+      -- exactly cocircular face is NOT part of the cavity, so its opposite+      -- vertex is not a natural neighbour. A '/= LT' reading would include+      -- such a vertex with a zero stolen area and diverge from spade's+      -- neighbour set on cocircular queries.+      inCircle+        (vertexPoint triangulation a)+        (vertexPoint triangulation b)+        (vertexPoint triangulation c)+        query+        == GT++pushNeighbors+  :: Triangulation mode vertex directed undirected face+  -> NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Word32+  -> Int+  -> FaceId+  -> ST s Int+pushNeighbors triangulation workspace generation start face =+  case innerFaceDirectedEdges triangulation face of+    Nothing -> pure start+    Just (e0, e1, e2) -> do+      size1 <- pushOne start e0+      size2 <- pushOne size1 e1+      pushOne size2 e2+ where+  pushOne !size edge =+    let !adjacent@(FaceId raw) = incidentFace triangulation (reverseEdge edge)+        !index = fromIntegral raw+     in if adjacent == outerFace+          then pure size+          else do+            seen <- MUV.unsafeRead (nnFaceSeenMarks workspace) index+            if seen == generation+              then pure size+              else do+                MUV.unsafeWrite (nnFaceSeenMarks workspace) index generation+                MUV.unsafeWrite (nnFaceQueue workspace) size raw+                pure (size + 1)++collectBoundary+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Word32+  -> Int+  -> ST s Int+collectBoundary workspace generation cavityCount = goFaces 0 0+ where+  !triangulation = nnTriangulation workspace+  goFaces !index !boundarySize+    | index >= cavityCount = pure boundarySize+    | otherwise = do+        rawFace <- MUV.unsafeRead (nnCavityFaces workspace) index+        nextSize <- case innerFaceDirectedEdges triangulation (FaceId rawFace) of+          Nothing -> pure boundarySize+          Just (e0, e1, e2) -> do+            size1 <- appendIfBoundary boundarySize e0+            size2 <- appendIfBoundary size1 e1+            appendIfBoundary size2 e2+        goFaces (index + 1) nextSize+  appendIfBoundary !size edge = do+    let adjacent@(FaceId rawAdjacent) = incidentFace triangulation (reverseEdge edge)+    outside <- if adjacent == outerFace+      then pure True+      else (/= generation) <$> MUV.unsafeRead (nnFaceMarks workspace) (fromIntegral rawAdjacent)+    if outside+      then case edge of+        DirectedEdgeId raw -> MUV.unsafeWrite (nnBoundaryEdges workspace) size raw >> pure (size + 1)+      else pure size++orderBoundary+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Int+  -> ST s Int+orderBoundary _ 0 = pure 0+orderBoundary workspace count = do+  generation <- nextOriginGeneration workspace+  install generation 0+  firstRaw <- MUV.unsafeRead (nnBoundaryEdges workspace) 0+  follow generation firstRaw firstRaw 0+ where+  !triangulation = nnTriangulation workspace+  install !generation !index+    | index >= count = pure ()+    | otherwise = do+        rawEdge <- MUV.unsafeRead (nnBoundaryEdges workspace) index+        let !from = vertexIndex (origin triangulation (DirectedEdgeId rawEdge))+        MUV.unsafeWrite (nnOriginMarks workspace) from generation+        MUV.unsafeWrite (nnOriginEdge workspace) from rawEdge+        install generation (index + 1)+  follow !generation !firstRaw !currentRaw !index+    | index >= count =+        if currentRaw == firstRaw then pure count else pure 0+    | otherwise = do+        MUV.unsafeWrite (nnOrderedEdges workspace) index currentRaw+        let !to = vertexIndex (destination triangulation (DirectedEdgeId currentRaw))+        marked <- MUV.unsafeRead (nnOriginMarks workspace) to+        if marked /= generation+          then pure 0+          else do+            nextRaw <- MUV.unsafeRead (nnOriginEdge workspace) to+            if nextRaw == firstRaw && index + 1 == count+              then pure count+              else if nextRaw == firstRaw+                then pure 0+                else follow generation firstRaw nextRaw (index + 1)++buildInsertionCell+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Point+  -> Int+  -> ST s Bool+buildInsertionCell workspace query count = go 0+ where+  !triangulation = nnTriangulation workspace+  go !index+    | index >= count = pure True+    | otherwise = do+        rawEdge <- MUV.unsafeRead (nnOrderedEdges workspace) index+        let !edge = DirectedEdgeId rawEdge+            !from = vertexPoint triangulation (origin triangulation edge)+            !to = vertexPoint triangulation (destination triangulation edge)+        case circumcenter (subtractPoint to query) (subtractPoint from query) (Point 0 0) of+          Nothing -> pure False+          Just (Point x y)+            | isFinite x && isFinite y -> do+                MUV.unsafeWrite (nnInsertionX workspace) index x+                MUV.unsafeWrite (nnInsertionY workspace) index y+                go (index + 1)+            | otherwise -> pure False++buildStolenAreas+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Word32+  -> Point+  -> Int+  -> ST s Int+buildStolenAreas workspace generation query count = do+  lastRaw <- MUV.unsafeRead (nnOrderedEdges workspace) (count - 1)+  lastX <- MUV.unsafeRead (nnInsertionX workspace) (count - 1)+  lastY <- MUV.unsafeRead (nnInsertionY workspace) (count - 1)+  go 0 (DirectedEdgeId lastRaw) (Point lastX lastY)+ where+  !triangulation = nnTriangulation workspace+  go !index !lastEdge !lastPoint+    | index >= count = pure count+    | otherwise = do+        rawStop <- MUV.unsafeRead (nnOrderedEdges workspace) index+        firstX <- MUV.unsafeRead (nnInsertionX workspace) index+        firstY <- MUV.unsafeRead (nnInsertionY workspace) index+        let !stopEdge = DirectedEdgeId rawStop+            !first = Point firstX firstY+        area <- stolenArea workspace generation query stopEdge first lastEdge lastPoint+        case area of+          Nothing -> pure 0+          Just polygonArea -> do+            writeWeight workspace index (origin triangulation stopEdge) polygonArea+            go (index + 1) stopEdge first++stolenArea+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Word32+  -> Point+  -> DirectedEdgeId+  -> Point+  -> DirectedEdgeId+  -> Point+  -> ST s (Maybe Double)+stolenArea workspace generation query stopEdge first initialEdge initialPoint =+  walk initialEdge initialPoint initialPositive initialNegative 0+ where+  !triangulation = nnTriangulation workspace+  -- The boundary loop runs counterclockwise around the cavity, so the fan+  -- walk around each boundary vertex necessarily runs clockwise: the+  -- shoelace sequence first, lastPoint, circumcenters... is the clockwise+  -- traversal of the stolen polygon, and positive - negative is the+  -- NEGATED twice-area. The result is negated here so the returned value is+  -- the positive twice-area 'normalizeWeights' requires. (spade's identical+  -- walk leaves the sum negative and cancels the sign in its total; its+  -- "ordered ccw" comment is wrong.)+  !initialPositive = pointX first * pointY initialPoint+  !initialNegative = pointY first * pointX initialPoint+  !target = reverseEdge stopEdge+  !limit = numDirectedEdges triangulation + 1+  walk !lastEdge !lastPoint !positive !negative !steps+    | steps >= limit = pure Nothing+    | face == outerFace = pure Nothing+    | otherwise = do+        center <- cachedFaceCircumcenter workspace generation query face+        case center of+          Nothing -> pure Nothing+          Just current ->+            let !positive' = positive + pointX lastPoint * pointY current+                !negative' = negative + pointY lastPoint * pointX current+                !nextEdge = reverseEdge (next triangulation lastEdge)+             in if nextEdge == target+                  then+                    let !closedPositive = positive' + pointX current * pointY first+                        !closedNegative = negative' + pointY current * pointX first+                     in pure (Just (closedNegative - closedPositive))+                  else walk nextEdge current positive' negative' (steps + 1)+   where+    face = incidentFace triangulation lastEdge++-- Each fan turns around the vertex two consecutive boundary edges share, so a+-- cavity face is walked once per vertex it has on the boundary loop: twice for+-- two, three times for a face whose whole triangle is on the loop, which is+-- every face of a single-face cavity. Without this plane each of those visits+-- pays two divisions and a dozen multiply-adds for a value already in hand.+--+-- The cached value is the one 'faceCircumcenterRelative' returned, stored as+-- its own coordinates and handed back unchanged; nothing is recomputed from a+-- rearrangement, so a hit and a miss are the same bits. Soundness needs only+-- that the query point cannot change while an entry is readable, which the+-- generation supplies: it is minted once per Sibson query and every stamp from+-- an earlier query is strictly smaller.+--+-- A 'Nothing' is not recorded. It cannot repeat: the first one aborts this+-- fan, and 'buildStolenAreas' abandons the query on the spot.+cachedFaceCircumcenter+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Word32+  -> Point+  -> FaceId+  -> ST s (Maybe (Point))+cachedFaceCircumcenter workspace generation query face@(FaceId rawFace) = do+  stamp <- MUV.unsafeRead (nnCircumcenterMarks workspace) slot+  if stamp == generation+    then do+      x <- MUV.unsafeRead (nnCircumcenterX workspace) slot+      y <- MUV.unsafeRead (nnCircumcenterY workspace) slot+      pure (Just (Point x y))+    else case faceCircumcenterRelative (nnTriangulation workspace) query face of+      Nothing -> pure Nothing+      Just center@(Point x y) -> do+        MUV.unsafeWrite (nnCircumcenterX workspace) slot x+        MUV.unsafeWrite (nnCircumcenterY workspace) slot y+        MUV.unsafeWrite (nnCircumcenterMarks workspace) slot generation+        pure (Just center)+ where+  !slot = fromIntegral rawFace++faceCircumcenterRelative+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> FaceId+  -> Maybe (Point)+faceCircumcenterRelative triangulation query face = do+  (a, b, c) <- innerFaceVertices triangulation face+  center <- circumcenter+    (subtractPoint (vertexPoint triangulation a) query)+    (subtractPoint (vertexPoint triangulation b) query)+    (subtractPoint (vertexPoint triangulation c) query)+  if finitePoint center then Just center else Nothing++normalizeWeights+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Int+  -> ST s Bool+normalizeWeights _ 0 = pure False+normalizeWeights workspace count = do+  (!total, !minimumWeight, !finite) <- firstPass 0 0 0 True+  let !tolerance = max 1.0e-12 (128 * scalarEpsilon)+  if not finite || total == 0 || minimumWeight < negate tolerance+    then pure False+    else do+      clampedTotal <- clampPass 0 0+      if clampedTotal <= 0 || not (isFinite clampedTotal)+        then pure False+        else normalizePass 0 clampedTotal >> pure True+ where+  firstPass !index !total !minimumWeight !finite+    | index >= count = pure (total, minimumWeight, finite)+    | otherwise = do+        weight <- MUV.unsafeRead (nnWeightValue workspace) index+        let !minimumWeight' = if index == 0 then weight else min minimumWeight weight+        firstPass (index + 1) (total + weight) minimumWeight' (finite && isFinite weight)+  clampPass !index !total+    | index >= count = pure total+    | otherwise = do+        weight <- MUV.unsafeRead (nnWeightValue workspace) index+        let !clamped = max 0 weight+        MUV.unsafeWrite (nnWeightValue workspace) index clamped+        clampPass (index + 1) (total + clamped)+  normalizePass !index !total+    | index >= count = pure ()+    | otherwise = do+        weight <- MUV.unsafeRead (nnWeightValue workspace) index+        MUV.unsafeWrite (nnWeightValue workspace) index (weight / total)+        normalizePass (index + 1) total++fallbackBarycentric+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Point+  -> FaceId+  -> Int+  -> Int+  -> ST s (Int, InterpolationStats)+fallbackBarycentric workspace query face faceTests cavityCount =+  case innerFaceVertices triangulation face of+    Nothing -> pure (0, InterpolationStats cavityCount 0 faceTests True)+    Just (a, b, c) ->+      case barycentricCoordinates+        (vertexPoint triangulation a)+        (vertexPoint triangulation b)+        (vertexPoint triangulation c)+        query of+        Nothing -> pure (0, InterpolationStats cavityCount 0 faceTests True)+        Just (wa, wb, wc) -> do+          writeWeight workspace 0 a wa+          writeWeight workspace 1 b wb+          writeWeight workspace 2 c wc+          pure (3, InterpolationStats cavityCount 3 faceTests True)+ where+  triangulation = nnTriangulation workspace++writeWeight+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Int+  -> VertexId+  -> Double+  -> ST s ()+writeWeight workspace index (VertexId vertex) weight = do+  MUV.unsafeWrite (nnWeightVertex workspace) index vertex+  MUV.unsafeWrite (nnWeightValue workspace) index weight++-- | Sample the nearest vertex, or return 'Nothing' for an empty mesh.+interpolateNearest+  :: (VertexId -> value)+  -> Triangulation mode vertex directed undirected face+  -> Maybe VertexId+  -> QueryPoint+  -> Maybe value+interpolateNearest sample triangulation hint query = sample . fst <$> nearestNeighbor triangulation hint query++-- | Interpolate scalar vertex samples in the cell containing the query.+interpolateBarycentric+  :: (VertexId -> Double)+  -> Triangulation mode vertex directed undirected face+  -> Maybe LocationHint+  -> QueryPoint+  -> Maybe Double+interpolateBarycentric sample triangulation hint query =+  case fst (barycentricWeights triangulation hint query) of+    NoWeights -> Nothing+    OneWeight vertex -> Just (sample vertex)+    TwoWeights a wa b wb -> Just (wa * sample a + wb * sample b)+    ThreeWeights a wa b wb c wc -> Just (wa * sample a + wb * sample b + wc * sample c)++interpolateNaturalNeighbor+  :: (VertexId -> Double)+  -> NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Maybe LocationHint+  -> QueryPoint+  -> ST s (Maybe Double, InterpolationStats)+interpolateNaturalNeighbor sample workspace hint query = do+  (total, _, stats) <-+    foldNaturalNeighborWeights+      (\accumulator vertex weight -> accumulator + weight * sample vertex)+      0+      workspace+      hint+      query+  pure (if interpolationNaturalNeighbors stats == 0 then Nothing else Just total, stats)++estimateGradient+  :: (VertexId -> Double)+  -> Triangulation mode vertex directed undirected face+  -> VertexId+  -> (Double, Double)+estimateGradient sample triangulation vertex =+  case vertexOutEdge triangulation vertex of+    Nothing -> (0, 0)+    Just start ->+      let !nextEdge = counterClockwise triangulation start+       in if nextEdge == start+            then (0, 0)+            else+              let (!nx, !ny, !nz) = walk start start 0 0 0 0+               in if nz /= 0 && isFinite nz then (-nx / nz, -ny / nz) else (0, 0)+ where+  Point vx vy = vertexPoint triangulation vertex+  !vz = sample vertex+  !bound = numDirectedEdges triangulation + 1++  walk !start !current !steps !sumX !sumY !sumZ+    | steps >= bound = (sumX, sumY, sumZ)+    | otherwise =+        let !nextEdge = counterClockwise triangulation current+            !leftVertex = destination triangulation current+            !rightVertex = destination triangulation nextEdge+            (!nextX, !nextY, !nextZ) = accumulate sumX sumY sumZ leftVertex rightVertex+         in if nextEdge == start+              then (nextX, nextY, nextZ)+              else walk start nextEdge (steps + 1) nextX nextY nextZ++  accumulate !sumX !sumY !sumZ leftVertex rightVertex =+    let Point lx ly = vertexPoint triangulation leftVertex+        Point rx ry = vertexPoint triangulation rightVertex+        !lz = sample leftVertex+        !rz = sample rightVertex+        !d0x = lx - vx+        !d0y = ly - vy+        !d0z = lz - vz+        !d1x = rx - vx+        !d1y = ry - vy+        !d1z = rz - vz+        !normalX = d0y * d1z - d0z * d1y+        !normalY = d0z * d1x - d0x * d1z+        !normalZ = d0x * d1y - d0y * d1x+     in if normalZ > 0+          then (sumX + normalX, sumY + normalY, sumZ + normalZ)+          else (sumX, sumY, sumZ)++estimateGradients+  :: (VertexId -> Double)+  -> Triangulation mode vertex directed undirected face+  -> V.Vector (Double, Double)+estimateGradients sample triangulation =+  V.generate (numVertices triangulation) $ \index ->+    estimateGradient sample triangulation (VertexId (fromIntegral index))++interpolateNaturalNeighborGradient+  :: (VertexId -> Double)+  -> (VertexId -> (Double, Double))+  -> Double+  -> NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Maybe LocationHint+  -> QueryPoint+  -> ST s (Maybe Double, InterpolationStats)+interpolateNaturalNeighborGradient sample gradient flatness workspace hint queryPoint+  | flatness < 0 || not (isFinite flatness) = pure (Nothing, InterpolationStats 0 0 0 False)+  | otherwise = do+      (!count, _, !stats) <- queryNaturalNeighborWorkspace workspace hint queryPoint+      if count == 0+        then pure (Nothing, stats)+        else do+          accumulation <- accumulate 0 count Nothing (0, 0, 0, 0, 0)+          pure (finish accumulation, stats)+ where+  !query = queryPointValue queryPoint+  !triangulation = nnTriangulation workspace++  -- 'flatness' is 0.5 or 1 in practice and @**@ is an exp/log pair per natural+  -- neighbour per query, so both are answered directly. The two shortcuts do+  -- not stand on the same ground.+  --+  -- The identity is exact. @x@ raised to 1 is @x@, which is already a float,+  -- and rounding an exactly representable result admits only that result, so+  -- any implementation faithful to within an ulp returns it.+  --+  -- The square root is not exact and does not need to be. IEEE-754 mandates a+  -- correctly rounded 'sqrt'; @pow@ is a recommended operation carrying no such+  -- requirement. Where the two disagree it is therefore in the last ulp, and it+  -- is 'sqrt' that holds the correctly rounded answer — this substitution can+  -- only move the result toward it. Against this platform's libm they in fact+  -- agree on every non-negative binary32 and on every non-negative binary64+  -- sampled, which is a measurement and not a proof.+  --+  -- They part company at negative zero, where @pow@ answers @+0@ and 'sqrt'+  -- answers @-0@. A sum of two squares is never negative zero, and were it one+  -- the sole consumer below tests @== 0@, which both zeroes satisfy alike.+  raiseToFlatness squared+    | flatness == 0.5 = sqrt squared+    | flatness == 1 = squared+    | otherwise = squared ** flatness++  accumulate !index !count !exact !totals+    | index >= count = pure (exact, totals)+    | otherwise = do+        rawVertex <- MUV.unsafeRead (nnWeightVertex workspace) index+        weight <- MUV.unsafeRead (nnWeightValue workspace) index+        let !vertex = VertexId rawVertex+            !point = vertexPoint triangulation vertex+            !exact' =+              case exact of+                Just _ -> exact+                Nothing+                  | query == point -> Just (sample vertex)+                  | otherwise -> Nothing+            !totals' = contribution totals vertex weight+        accumulate (index + 1) count exact' totals'++  finish+    :: (Maybe Double, (Double, Double, Double, Double, Double))+    -> Maybe Double+  finish (Just value, _) = Just value+  finish (Nothing, (!sumC0, !sumC1, !sumC1Weights, !alphaNumerator, !beta))+    | sumC1Weights == 0 = Just sumC0+    | otherwise =+        let !alpha = alphaNumerator / sumC1Weights+            !c1 = sumC1 / sumC1Weights+            !denominator = alpha + beta+         in if denominator == 0 || not (isFinite denominator)+              then Just sumC0+              else Just ((alpha * sumC0 + beta * c1) / denominator)++  contribution (!sumC0, !sumC1, !sumC1Weights, !alpha, !beta) vertex weight =+    let Point qx qy = query+        Point vx vy = vertexPoint triangulation vertex+        !dx = qx - vx+        !dy = qy - vy+        !radiusSquared = dx * dx + dy * dy+        !radiusPower = raiseToFlatness radiusSquared+        !c1Weight = if radiusPower == 0 then 0 else weight / radiusPower+        (!gx, !gy) = gradient vertex+        !height = sample vertex+        !zeta = height + dx * gx + dy * gy+     in ( sumC0 + height * weight+        , sumC1 + zeta * c1Weight+        , sumC1Weights + c1Weight+        , alpha + c1Weight * radiusSquared+        , beta + weight * radiusSquared+        )++vertexIndex :: VertexId -> Int+vertexIndex (VertexId raw) = fromIntegral raw+{-# INLINE vertexIndex #-}++subtractPoint :: Point -> Point -> Point+subtractPoint (Point ax ay) (Point bx by) = Point (ax - bx) (ay - by)+{-# INLINE subtractPoint #-}++finitePoint :: Point -> Bool+finitePoint (Point x y) = isFinite x && isFinite y+{-# INLINE finitePoint #-}++clamp :: Ord value => value -> value -> value -> value+clamp low high = max low . min high+{-# INLINE clamp #-}
+ src-dual/Moonlight/Triangulation/Voronoi.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | The Voronoi dual, addressed by its own handle family: every cell, edge and+-- vertex is a view of the Delaunay mesh rather than a second structure.+module Moonlight.Triangulation.Voronoi+  ( VoronoiFaceId (..)+  , DirectedVoronoiEdgeId (..)+  , UndirectedVoronoiEdgeId (..)+  , VoronoiVertexId (..)+  , VoronoiEdgeGeometry (..)+  , voronoiFaces+  , directedVoronoiEdges+  , undirectedVoronoiEdges+  , asDelaunayDirectedEdge+  , asDelaunayUndirectedEdge+  , asDirectedVoronoiEdge+  , asUndirectedVoronoiEdge+  , reverseVoronoiEdge+  , voronoiNext+  , voronoiPrevious+  , voronoiFrom+  , voronoiTo+  , voronoiIncidentFace+  , voronoiFaceSite+  , voronoiFaceAdjacentEdges+  , voronoiVertexPosition+  , voronoiVertexOutgoingEdges+  , voronoiDirectionVector+  , voronoiEdgeGeometry+  , faceCircumcenter+  ) where++import Control.DeepSeq (NFData)+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (directedEdges, undirectedEdges, vertices)+import Moonlight.Triangulation.Math+import Moonlight.Triangulation.Types++-- The dual uses the exact same fixed-index space as the primal DCEL. These+-- newtypes add semantic separation without allocating or owning any dual mesh.+newtype VoronoiFaceId = VoronoiFaceId { unVoronoiFaceId :: VertexId }+  deriving stock (Show)+  deriving newtype (Eq, Ord, NFData)++newtype DirectedVoronoiEdgeId = DirectedVoronoiEdgeId { unDirectedVoronoiEdgeId :: DirectedEdgeId }+  deriving stock (Show)+  deriving newtype (Eq, Ord, NFData)++newtype UndirectedVoronoiEdgeId = UndirectedVoronoiEdgeId { unUndirectedVoronoiEdgeId :: UndirectedEdgeId }+  deriving stock (Show)+  deriving newtype (Eq, Ord, NFData)++data VoronoiVertexId+  = InnerVoronoiVertex !FaceId+  | OuterVoronoiVertex !DirectedVoronoiEdgeId+  deriving stock (Eq, Ord, Show)++data VoronoiEdgeGeometry+  = VoronoiSegment !(Point) !(Point)+  | VoronoiRay !(Point) !(Point)+  | VoronoiLine !(Point) !(Point)+  deriving stock (Eq, Ord, Show)++voronoiFaces :: Triangulation mode vertex directed undirected face -> [VoronoiFaceId]+voronoiFaces triangulation = map VoronoiFaceId (vertices triangulation)+{-# INLINE voronoiFaces #-}++-- Every primal directed edge is one directed edge in the dual. Boundary+-- handles naturally represent half-infinite edges through OuterVoronoiVertex.+directedVoronoiEdges :: Triangulation mode vertex directed undirected face -> [DirectedVoronoiEdgeId]+directedVoronoiEdges triangulation = map DirectedVoronoiEdgeId (directedEdges triangulation)+{-# INLINE directedVoronoiEdges #-}++undirectedVoronoiEdges :: Triangulation mode vertex directed undirected face -> [UndirectedVoronoiEdgeId]+undirectedVoronoiEdges triangulation = map UndirectedVoronoiEdgeId (undirectedEdges triangulation)+{-# INLINE undirectedVoronoiEdges #-}++asDelaunayDirectedEdge :: DirectedVoronoiEdgeId -> DirectedEdgeId+asDelaunayDirectedEdge = unDirectedVoronoiEdgeId+{-# INLINE asDelaunayDirectedEdge #-}++asDelaunayUndirectedEdge :: UndirectedVoronoiEdgeId -> UndirectedEdgeId+asDelaunayUndirectedEdge = unUndirectedVoronoiEdgeId+{-# INLINE asDelaunayUndirectedEdge #-}++asDirectedVoronoiEdge :: DirectedEdgeId -> DirectedVoronoiEdgeId+asDirectedVoronoiEdge = DirectedVoronoiEdgeId+{-# INLINE asDirectedVoronoiEdge #-}++asUndirectedVoronoiEdge :: UndirectedEdgeId -> UndirectedVoronoiEdgeId+asUndirectedVoronoiEdge = UndirectedVoronoiEdgeId+{-# INLINE asUndirectedVoronoiEdge #-}++reverseVoronoiEdge :: DirectedVoronoiEdgeId -> DirectedVoronoiEdgeId+reverseVoronoiEdge (DirectedVoronoiEdgeId edge) = DirectedVoronoiEdgeId (reverseEdge edge)+{-# INLINE reverseVoronoiEdge #-}++-- Dual next/previous rotate around the primal origin site.+voronoiNext+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> DirectedVoronoiEdgeId+voronoiNext triangulation (DirectedVoronoiEdgeId edge) =+  DirectedVoronoiEdgeId (counterClockwise triangulation edge)+{-# INLINE voronoiNext #-}++voronoiPrevious+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> DirectedVoronoiEdgeId+voronoiPrevious triangulation (DirectedVoronoiEdgeId edge) =+  DirectedVoronoiEdgeId (clockwise triangulation edge)+{-# INLINE voronoiPrevious #-}++voronoiFrom+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> VoronoiVertexId+voronoiFrom triangulation edge@(DirectedVoronoiEdgeId primal)+  | face == outerFace = OuterVoronoiVertex edge+  | otherwise = InnerVoronoiVertex face+ where+  face = incidentFace triangulation primal+{-# INLINE voronoiFrom #-}++voronoiTo+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> VoronoiVertexId+voronoiTo triangulation = voronoiFrom triangulation . reverseVoronoiEdge+{-# INLINE voronoiTo #-}++voronoiIncidentFace+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> VoronoiFaceId+voronoiIncidentFace triangulation (DirectedVoronoiEdgeId edge) =+  VoronoiFaceId (origin triangulation edge)+{-# INLINE voronoiIncidentFace #-}++voronoiFaceSite :: VoronoiFaceId -> VertexId+voronoiFaceSite = unVoronoiFaceId+{-# INLINE voronoiFaceSite #-}++voronoiFaceAdjacentEdges+  :: Triangulation mode vertex directed undirected face+  -> VoronoiFaceId+  -> [DirectedVoronoiEdgeId]+voronoiFaceAdjacentEdges triangulation (VoronoiFaceId site) =+  map DirectedVoronoiEdgeId (vertexOutgoingEdges triangulation site)+{-# INLINE voronoiFaceAdjacentEdges #-}++-- A caller reaches this through 'voronoiFrom' or 'voronoiTo', which build the+-- endpoint sum immediately before it is taken apart again. Only an unfolding at+-- the consumer lets the two meet, so the constructor never reaches the heap.+voronoiVertexPosition+  :: Triangulation mode vertex directed undirected face+  -> VoronoiVertexId+  -> Maybe (Point)+voronoiVertexPosition triangulation vertex = case vertex of+  InnerVoronoiVertex face -> faceCircumcenter triangulation face+  OuterVoronoiVertex _ -> Nothing+{-# INLINE voronoiVertexPosition #-}++voronoiVertexOutgoingEdges+  :: Triangulation mode vertex directed undirected face+  -> VoronoiVertexId+  -> Maybe [DirectedVoronoiEdgeId]+voronoiVertexOutgoingEdges triangulation vertex = case vertex of+  OuterVoronoiVertex _ -> Nothing+  InnerVoronoiVertex face ->+    map DirectedVoronoiEdgeId . faceDirectedEdges triangulation <$> nonOuter face+ where+  nonOuter face+    | face == outerFace = Nothing+    | otherwise = Just face+{-# INLINE voronoiVertexOutgoingEdges #-}++voronoiDirectionVector+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> Point+voronoiDirectionVector triangulation (DirectedVoronoiEdgeId edge) =+  case vertexPoint triangulation (origin triangulation edge) of+    Point ax ay -> case vertexPoint triangulation (destination triangulation edge) of+      Point bx by -> Point (ay - by) (bx - ax)++-- The circumcentre stands on the absolute vertex positions, which is a+-- different value from the query-relative one the Sibson pipeline caches: that+-- one rescales the differences it was handed, so translating the inputs moves+-- the rounding and the two do not differ by the translation. The interpolation+-- workspace's plane therefore cannot serve this function, and the repetition+-- here is across calls rather than within one — a sweep recomputes each face+-- once per incident dual edge, while a single call touches two distinct faces.+-- That threefold repetition is what a dual which is a view rather than a+-- structure costs, and the referent pays it identically, so no cache is owed.+faceCircumcenter+  :: Triangulation mode vertex directed undirected face+  -> FaceId+  -> Maybe (Point)+faceCircumcenter triangulation face+  | face == outerFace = Nothing+  | otherwise = case adjacentEdge triangulation face of+      Nothing -> Nothing+      Just e0 ->+        let !e1 = next triangulation e0+            !e2 = next triangulation e1+         in if next triangulation e2 /= e0+              then Nothing+              else+                circumcenter+                  (vertexPoint triangulation (origin triangulation e0))+                  (vertexPoint triangulation (origin triangulation e1))+                  (vertexPoint triangulation (origin triangulation e2))+{-# INLINE faceCircumcenter #-}++-- The endpoint classification 'voronoiFrom' and 'voronoiTo' publish is two face+-- reads and two comparisons; taken through those observations it is also two+-- sum values built and immediately scrutinized. The geometry reads the faces+-- itself so that the classification stays in registers.+voronoiEdgeGeometry+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> Maybe (VoronoiEdgeGeometry)+voronoiEdgeGeometry triangulation edge@(DirectedVoronoiEdgeId primal)+  | innerFrom, innerTo =+      VoronoiSegment <$> faceCircumcenter triangulation fromFace <*> faceCircumcenter triangulation toFace+  | innerFrom = do+      start <- faceCircumcenter triangulation fromFace+      pure (VoronoiRay start (normalize (voronoiDirectionVector triangulation edge)))+  | innerTo = do+      end <- faceCircumcenter triangulation toFace+      pure (VoronoiRay end (normalize (negatePoint (voronoiDirectionVector triangulation edge))))+  | otherwise =+      let !center = midpoint+            (vertexPoint triangulation (origin triangulation primal))+            (vertexPoint triangulation (destination triangulation primal))+       in Just (VoronoiLine center (normalize (voronoiDirectionVector triangulation edge)))+ where+  !fromFace = incidentFace triangulation primal+  !toFace = incidentFace triangulation (reverseEdge primal)+  !innerFrom = fromFace /= outerFace+  !innerTo = toFace /= outerFace++normalize :: Point -> Point+normalize (Point x y)+  | scale == 0 = Point 0 0+  | otherwise =+      let !scaledX = x / scale+          !scaledY = y / scale+          !length' = sqrt (scaledX * scaledX + scaledY * scaledY)+       in Point (scaledX / length') (scaledY / length')+ where+  !scale = max (abs x) (abs y)++negatePoint :: Point -> Point+negatePoint (Point x y) = Point (-x) (-y)++{-# INLINE normalize #-}+{-# INLINE negatePoint #-}
+ src-dual/Moonlight/Triangulation/Voronoi/Handles.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++module Moonlight.Triangulation.Voronoi.Handles+  ( VoronoiFaceHandle+  , DirectedVoronoiEdgeHandle+  , UndirectedVoronoiEdgeHandle+  , VoronoiVertexHandle+  , voronoiFaceHandle+  , directedVoronoiEdgeHandle+  , undirectedVoronoiEdgeHandle+  , vertexAsVoronoiFaceH+  , directedEdgeAsVoronoiH+  , undirectedEdgeAsVoronoiH+  , innerFaceAsVoronoiVertexH+  , fixVoronoiFace+  , fixDirectedVoronoiEdge+  , fixUndirectedVoronoiEdge+  , fixVoronoiVertex+  , voronoiEdgeReverseH+  , voronoiEdgeNextH+  , voronoiEdgePreviousH+  , voronoiEdgeFromH+  , voronoiEdgeToH+  , voronoiEdgeFaceH+  , voronoiEdgeAsUndirectedH+  , voronoiEdgeAsDelaunayH+  , voronoiFaceSiteH+  , voronoiFaceAdjacentEdgesH+  , voronoiVertexPositionH+  , voronoiVertexOutEdgesH+  , voronoiVertexAsDelaunayFaceH+  , voronoiVertexAsOuterEdgeH+  , voronoiEdgeDirectionH+  , voronoiEdgeGeometryH+  ) where++import Moonlight.Triangulation.Handles.Dynamic+import Moonlight.Triangulation.Math (midpoint)+import Moonlight.Triangulation.Types+import Moonlight.Triangulation.Voronoi++-- | Zero-copy dual handles. Each dual value contains exactly one primal handle,+-- so it cannot accidentally combine an identifier from one triangulation with+-- the storage of another.+newtype VoronoiFaceHandle mode vertex directed undirected face =+  VoronoiFaceHandle (VertexHandle mode vertex directed undirected face)++newtype DirectedVoronoiEdgeHandle mode vertex directed undirected face =+  DirectedVoronoiEdgeHandle (DirectedEdgeHandle mode vertex directed undirected face)++newtype UndirectedVoronoiEdgeHandle mode vertex directed undirected face =+  UndirectedVoronoiEdgeHandle (UndirectedEdgeHandle mode vertex directed undirected face)++data VoronoiVertexHandle mode vertex directed undirected face+  = InnerVoronoiVertexHandle+      !(FaceHandle InnerTag mode vertex directed undirected face)+  | OuterVoronoiVertexHandle+      !(DirectedVoronoiEdgeHandle mode vertex directed undirected face)++instance Show (VoronoiFaceHandle mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixVoronoiFace++instance Show (DirectedVoronoiEdgeHandle mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixDirectedVoronoiEdge++instance Show (UndirectedVoronoiEdgeHandle mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixUndirectedVoronoiEdge++instance Show (VoronoiVertexHandle mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixVoronoiVertex++voronoiFaceHandle+  :: Triangulation mode vertex directed undirected face+  -> VoronoiFaceId+  -> Maybe (VoronoiFaceHandle mode vertex directed undirected face)+voronoiFaceHandle triangulation (VoronoiFaceId site) =+  VoronoiFaceHandle <$> vertexHandle triangulation site++vertexAsVoronoiFaceH+  :: VertexHandle mode vertex directed undirected face+  -> VoronoiFaceHandle mode vertex directed undirected face+vertexAsVoronoiFaceH = VoronoiFaceHandle++directedVoronoiEdgeHandle+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> Maybe (DirectedVoronoiEdgeHandle mode vertex directed undirected face)+directedVoronoiEdgeHandle triangulation (DirectedVoronoiEdgeId edge) =+  DirectedVoronoiEdgeHandle <$> directedEdgeHandle triangulation edge++directedEdgeAsVoronoiH+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> DirectedVoronoiEdgeHandle mode vertex directed undirected face+directedEdgeAsVoronoiH = DirectedVoronoiEdgeHandle++undirectedVoronoiEdgeHandle+  :: Triangulation mode vertex directed undirected face+  -> UndirectedVoronoiEdgeId+  -> Maybe (UndirectedVoronoiEdgeHandle mode vertex directed undirected face)+undirectedVoronoiEdgeHandle triangulation (UndirectedVoronoiEdgeId edge) =+  UndirectedVoronoiEdgeHandle <$> undirectedEdgeHandle triangulation edge++undirectedEdgeAsVoronoiH+  :: UndirectedEdgeHandle mode vertex directed undirected face+  -> UndirectedVoronoiEdgeHandle mode vertex directed undirected face+undirectedEdgeAsVoronoiH = UndirectedVoronoiEdgeHandle++innerFaceAsVoronoiVertexH+  :: FaceHandle InnerTag mode vertex directed undirected face+  -> VoronoiVertexHandle mode vertex directed undirected face+innerFaceAsVoronoiVertexH = InnerVoronoiVertexHandle++fixVoronoiFace :: VoronoiFaceHandle mode vertex directed undirected face -> VoronoiFaceId+fixVoronoiFace (VoronoiFaceHandle site) = VoronoiFaceId (fixVertex site)+{-# INLINE fixVoronoiFace #-}++fixDirectedVoronoiEdge+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+fixDirectedVoronoiEdge (DirectedVoronoiEdgeHandle edge) =+  DirectedVoronoiEdgeId (fixDirectedEdge edge)+{-# INLINE fixDirectedVoronoiEdge #-}++fixUndirectedVoronoiEdge+  :: UndirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> UndirectedVoronoiEdgeId+fixUndirectedVoronoiEdge (UndirectedVoronoiEdgeHandle edge) =+  UndirectedVoronoiEdgeId (fixUndirectedEdge edge)+{-# INLINE fixUndirectedVoronoiEdge #-}++fixVoronoiVertex+  :: VoronoiVertexHandle mode vertex directed undirected face+  -> VoronoiVertexId+fixVoronoiVertex (InnerVoronoiVertexHandle face) =+  InnerVoronoiVertex (fixedFaceId (fixFace face))+fixVoronoiVertex (OuterVoronoiVertexHandle edge) =+  OuterVoronoiVertex (fixDirectedVoronoiEdge edge)+{-# INLINE fixVoronoiVertex #-}++voronoiEdgeReverseH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> DirectedVoronoiEdgeHandle mode vertex directed undirected face+voronoiEdgeReverseH (DirectedVoronoiEdgeHandle edge) =+  DirectedVoronoiEdgeHandle (directedEdgeReverse edge)++voronoiEdgeNextH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> DirectedVoronoiEdgeHandle mode vertex directed undirected face+voronoiEdgeNextH (DirectedVoronoiEdgeHandle edge) =+  DirectedVoronoiEdgeHandle (directedEdgeCounterClockwise edge)++voronoiEdgePreviousH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> DirectedVoronoiEdgeHandle mode vertex directed undirected face+voronoiEdgePreviousH (DirectedVoronoiEdgeHandle edge) =+  DirectedVoronoiEdgeHandle (directedEdgeClockwise edge)++voronoiEdgeFromH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> VoronoiVertexHandle mode vertex directed undirected face+voronoiEdgeFromH edge@(DirectedVoronoiEdgeHandle primal) =+  case faceAsInner (directedEdgeFace primal) of+    Just inner -> InnerVoronoiVertexHandle inner+    Nothing -> OuterVoronoiVertexHandle edge++voronoiEdgeToH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> VoronoiVertexHandle mode vertex directed undirected face+voronoiEdgeToH = voronoiEdgeFromH . voronoiEdgeReverseH++voronoiEdgeFaceH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> VoronoiFaceHandle mode vertex directed undirected face+voronoiEdgeFaceH (DirectedVoronoiEdgeHandle edge) =+  VoronoiFaceHandle (directedEdgeFrom edge)++voronoiEdgeAsUndirectedH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> UndirectedVoronoiEdgeHandle mode vertex directed undirected face+voronoiEdgeAsUndirectedH (DirectedVoronoiEdgeHandle edge) =+  UndirectedVoronoiEdgeHandle (directedEdgeAsUndirected edge)++voronoiEdgeAsDelaunayH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> DirectedEdgeHandle mode vertex directed undirected face+voronoiEdgeAsDelaunayH (DirectedVoronoiEdgeHandle edge) = edge++voronoiFaceSiteH+  :: VoronoiFaceHandle mode vertex directed undirected face+  -> VertexHandle mode vertex directed undirected face+voronoiFaceSiteH (VoronoiFaceHandle site) = site++voronoiFaceAdjacentEdgesH+  :: VoronoiFaceHandle mode vertex directed undirected face+  -> [DirectedVoronoiEdgeHandle mode vertex directed undirected face]+voronoiFaceAdjacentEdgesH (VoronoiFaceHandle site) =+  map DirectedVoronoiEdgeHandle (vertexHandleOutEdges site)++voronoiVertexPositionH+  :: VoronoiVertexHandle mode vertex directed undirected face+  -> Maybe (Point)+voronoiVertexPositionH (InnerVoronoiVertexHandle face) = innerFaceCircumcenter face+voronoiVertexPositionH (OuterVoronoiVertexHandle _) = Nothing++voronoiVertexOutEdgesH+  :: VoronoiVertexHandle mode vertex directed undirected face+  -> Maybe [DirectedVoronoiEdgeHandle mode vertex directed undirected face]+voronoiVertexOutEdgesH (InnerVoronoiVertexHandle face) =+  Just (map DirectedVoronoiEdgeHandle (faceAdjacentEdges face))+voronoiVertexOutEdgesH (OuterVoronoiVertexHandle _) = Nothing++voronoiVertexAsDelaunayFaceH+  :: VoronoiVertexHandle mode vertex directed undirected face+  -> Maybe (FaceHandle InnerTag mode vertex directed undirected face)+voronoiVertexAsDelaunayFaceH (InnerVoronoiVertexHandle face) = Just face+voronoiVertexAsDelaunayFaceH (OuterVoronoiVertexHandle _) = Nothing++voronoiVertexAsOuterEdgeH+  :: VoronoiVertexHandle mode vertex directed undirected face+  -> Maybe (DirectedVoronoiEdgeHandle mode vertex directed undirected face)+voronoiVertexAsOuterEdgeH (InnerVoronoiVertexHandle _) = Nothing+voronoiVertexAsOuterEdgeH (OuterVoronoiVertexHandle edge) = Just edge++voronoiEdgeDirectionH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> Point+voronoiEdgeDirectionH (DirectedVoronoiEdgeHandle primal) =+  let (Point ax ay, Point bx by) = directedEdgePositions primal+   in Point (ay - by) (bx - ax)++voronoiEdgeGeometryH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> Maybe (VoronoiEdgeGeometry)+voronoiEdgeGeometryH edge@(DirectedVoronoiEdgeHandle primal) =+  case (voronoiEdgeFromH edge, voronoiEdgeToH edge) of+    (InnerVoronoiVertexHandle fromFace, InnerVoronoiVertexHandle toFace) ->+      VoronoiSegment <$> innerFaceCircumcenter fromFace <*> innerFaceCircumcenter toFace+    (InnerVoronoiVertexHandle fromFace, OuterVoronoiVertexHandle _) -> do+      start <- innerFaceCircumcenter fromFace+      pure (VoronoiRay start (normalizePoint (voronoiEdgeDirectionH edge)))+    (OuterVoronoiVertexHandle _, InnerVoronoiVertexHandle toFace) -> do+      end <- innerFaceCircumcenter toFace+      pure (VoronoiRay end (normalizePoint (negatePoint (voronoiEdgeDirectionH edge))))+    (OuterVoronoiVertexHandle _, OuterVoronoiVertexHandle _) ->+      let (from, to) = directedEdgePositions primal+       in Just (VoronoiLine (midpoint from to) (normalizePoint (voronoiEdgeDirectionH edge)))++normalizePoint :: Point -> Point+normalizePoint (Point x y)+  | scale == 0 = Point 0 0+  | otherwise =+      let !scaledX = x / scale+          !scaledY = y / scale+          !length' = sqrt (scaledX * scaledX + scaledY * scaledY)+       in Point (scaledX / length') (scaledY / length')+ where+  !scale = max (abs x) (abs y)++negatePoint :: Point -> Point+negatePoint (Point x y) = Point (-x) (-y)++-- The handle verbs cross the same component boundary as the fixed-index ones+-- and carry their unfoldings for the same reason. 'voronoiVertexPositionH'+-- reaches its arithmetic through 'innerFaceCircumcenter', whose own worker+-- publishes no unfolding, so it stops at that call until the dcel layer says+-- otherwise.+
+ src-parallel/Moonlight/Triangulation/Parallel.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Bounded concurrent interpretation of the canonical join tournament. This+-- layer owns effects only: pairing and pair-schedule semantics remain in the+-- pure build planner.+module Moonlight.Triangulation.Parallel+  ( unionsConcurrently+  ) where++import Control.Concurrent.Async (concurrently)+import Control.DeepSeq (NFData, force)+import Control.Exception (evaluate)+import Data.List.NonEmpty (NonEmpty)+import Moonlight.Triangulation.Internal.Join+  ( TournamentPlan (..)+  , joinNormalForm+  , planTournament+  )+import Moonlight.Triangulation.Internal.Representation (Triangulation)+import Moonlight.Triangulation.Internal.Types (BuildError, ConstraintMode (Unconstrained))+import Moonlight.Triangulation.JoinSemilattice (JoinSemilattice)++-- | Execute the same deterministic tournament as sequential @unions@, with+-- no more than the requested number of leaf computations live at once. A+-- non-positive request means one worker; requesting more workers than leaves+-- is harmless. Each child is fully evaluated before its parent becomes+-- runnable, so thunks do not smuggle unbounded work across the boundary.+unionsConcurrently+  :: (JoinSemilattice annotation, NFData annotation)+  => Int+  -> NonEmpty (Triangulation 'Unconstrained annotation () () ())+  -> IO (Either BuildError (Triangulation 'Unconstrained annotation () () ()))+unionsConcurrently requestedWorkers operands =+  executeTournamentConcurrently+    (max 1 requestedWorkers)+    (planTournament operands)++executeTournamentConcurrently+  :: (JoinSemilattice annotation, NFData annotation)+  => Int+  -> TournamentPlan (Triangulation 'Unconstrained annotation () () ())+  -> IO (Either BuildError (Triangulation 'Unconstrained annotation () () ()))+executeTournamentConcurrently workers tournament =+  case tournament of+    TournamentLeaf mesh -> Right <$> evaluate (force mesh)+    TournamentNode left right+      | workers <= 1 ->+            publishUnion+            =<< ((,)+                  <$> executeTournamentConcurrently 1 left+                  <*> executeTournamentConcurrently 1 right+                )+      | otherwise -> do+          let !leftLeaves = tournamentLeaves left+              !rightLeaves = tournamentLeaves right+              !available = min workers (leftLeaves + rightLeaves)+              !leftWorkers =+                max 1 (min leftLeaves (available * leftLeaves `quot` (leftLeaves + rightLeaves)))+              !rightWorkers = max 1 (available - leftWorkers)+          concurrently+            (executeTournamentConcurrently leftWorkers left)+            (executeTournamentConcurrently rightWorkers right)+            >>= publishUnion++publishUnion+  :: (JoinSemilattice annotation, NFData annotation)+  => ( Either BuildError (Triangulation 'Unconstrained annotation () () ())+     , Either BuildError (Triangulation 'Unconstrained annotation () () ())+     )+  -> IO (Either BuildError (Triangulation 'Unconstrained annotation () () ()))+publishUnion (Left failure, _) = pure (Left failure)+publishUnion (Right _, Left failure) = pure (Left failure)+publishUnion (Right leftMesh, Right rightMesh) =+  evaluate (force (joinNormalForm leftMesh rightMesh))++tournamentLeaves :: TournamentPlan mesh -> Int+tournamentLeaves tournament =+  case tournament of+    TournamentLeaf _ -> 1+    TournamentNode left right -> tournamentLeaves left + tournamentLeaves right+{-# INLINE tournamentLeaves #-}
+ src-public/Moonlight/Triangulation.hs view
@@ -0,0 +1,326 @@+-- | The equational surface: a triangulation is a value of its site set.+module Moonlight.Triangulation+  ( -- * The object — a triangulation is a value of its site set+    Triangulation+  , DelaunayTriangulation+  , ConstrainedDelaunayTriangulation+  , ConstraintMode (..)+  , Point (..)+  , QueryPoint+  , queryPointValue+  , PointValidationError (..)+  , mkQueryPoint+  , HasPosition (..)+  , ElementDefaults (..)+  , unitElementDefaults+  , JoinSemilattice (..)+    -- | An identifier is admitted by the triangulation that issued it. The+    -- observations below index without a second bounds check, so the+    -- constructors are withheld here and the projections are not: an+    -- identifier can be read, compared and carried, and can only be obtained+    -- from a mesh. "Moonlight.Triangulation.Handles.HandleDefs" exports the+    -- constructors for a caller who is willing to own that obligation.+  , VertexId+  , unVertexId+  , FaceId+  , unFaceId+  , DirectedEdgeId+  , unDirectedEdgeId+  , UndirectedEdgeId+  , unUndirectedEdgeId+  , reverseEdge+  , asUndirected+  , normalizedDirected+  , reversedDirected+  , directedPair+  , isNormalized++    -- * Generation — @delaunay@; canonical observation factors through the site set+  , delaunay+  , BuildResult+  , buildTriangulation+  , buildInputVertices+  , BuildError (..)+  , CoordinateError (..)+  , NonFiniteValue (..)++    -- * The annotation functor — payloads annotate geometry, never author it;+    -- the mesh is the same mesh before and after+  , mapVertices+  , vertexData+  , setVertexData++    -- * Finite-set algebra and its normal form — support order is observable,+    -- intersection can combine heterogeneous annotations, and each+    -- construction returns its obstruction rather than an instance that lies+  , canonicalize+  , SiteRelation (..)+  , siteRelation+  , union+  , unions+  , intersection+  , intersectionWith+  , difference+  , symmetricDifference++    -- * The constraint layer — 'constrainedDelaunay' is the partial map from+    -- (sites, segments), defined exactly on realizable segment sets and+    -- naming the corridor that blocked it where it is not+  , constrainedDelaunay+  , fromDelaunay+  , constraintEdges+  , isConstraintEdge+  , CdtError (..)+  , CorridorObstruction (..)+  , CanonicalSegment+  , segmentStart+  , segmentEnd+  , ConstraintConflict+  , conflictFirstSegment+  , conflictSecondSegment+  , ConstrainedUnionError (..)+  , ConstrainedExtensionResult+  , constrainedExtensionTriangulation+  , constrainedExtensionConstraintOutcomes+  , constrainedExtensionConstraintStats+  , constrainedExtensionBuildStats+  , ConstrainedSeamSource (..)+  , ConstrainedSeamFaceEvidence+  , constrainedSeamSourceFace+  , constrainedSeamTargetFace+  , constrainedSeamFaceFirstPoint+  , constrainedSeamFaceSecondPoint+  , constrainedSeamFaceThirdPoint+  , ConstrainedSeamConstraintEvidence+  , constrainedSeamConstraintSegment+  , constrainedSeamConstraintRecovery+  , ConstrainedSeamResult+  , constrainedSeamResultTriangulation+  , constrainedSeamLeftFaceEvidence+  , constrainedSeamRightFaceEvidence+  , constrainedSeamNewFaces+  , constrainedSeamLeftConstraintEvidence+  , constrainedSeamRightConstraintEvidence+  , constrainedSeamConstraintStats+  , constrainedSeamBuildStats+  , constraintSegments+  , unionConstrainedWith+  , unionConstrained+  , joinSeparatedConstrainedWith+  , extendConstrainedWith++    -- * Refinement — budget-bounded, composed after any operation above rather+    -- than configured into it; 'refinementComplete' reports sufficiency, not+    -- effort+  , refine+  , refineWithinDomain+  , validateRefinementParameters+  , RefinementParameters (..)+  , defaultRefinementParameters+  , RefinementReceipt+  , RefinementDomainResult+  , RefinementResult+  , refinementDomainResult+  , refinementDomainReceipt+  , refinedTriangulation+  , refinementVisitedJoinFaces+  , refinementVisitedProtectedFaces+  , refinementCreatedFaces+  , refinementTouchedEdges+  , refinementRemovedEdges+  , refinementInterfaceBoundaryReads+  , refinementAttemptedBoundaryCrossings+  , refinementAddedVertices+  , refinementExcludedFaces+  , refinementComplete+  , withMinimumAngle+  , radiusEdgeRatioForAngle++    -- * Observations — pure functions of the value: incidence, location,+    -- interpolation and barrier parity, none of which build a second mesh+  , numVertices+  , vertices+  , vertexPoint+  , vertexPoints+  , numFaces+  , innerFaces+  , outerFace+  , faceDirectedEdges+  , faceVertices+  , innerFaceVertexTriples+  , vertexOutgoingEdges+  , numUndirectedEdges+  , undirectedEdges+  , undirectedEndpoints+  , origin+  , destination+  , incidentFace+  , isBoundaryEdge+  , nearestNeighbor+  , NearestStats (..)+  , interpolateNearest+  , interpolateBarycentric+  , LocationHint (..)+  , facesAtEvenBarrierDepth++    -- * Discharge — the invariants the constructors guarantee, checkable on a+    -- value built by any route; every violation is a value carrying its witness+  , validateTriangulation+  , InvariantViolation (..)+  ) where++import Moonlight.Triangulation.BulkLoad (delaunay)+import Moonlight.Triangulation.Dcel+  ( destination+  , faceDirectedEdges+  , faceVertices+  , innerFaceVertexTriples+  , incidentFace+  , isBoundaryEdge+  , isConstraintEdge+  , numFaces+  , numUndirectedEdges+  , numVertices+  , origin+  , outerFace+  , setVertexData+  , undirectedEndpoints+  , vertexData+  , vertexOutgoingEdges+  , vertexPoint+  , vertexPoints+  )+import Moonlight.Triangulation.FloodFillIterator (facesAtEvenBarrierDepth)+import Moonlight.Triangulation.Handles.HandleDefs+  ( DirectedEdgeId (..)+  , FaceId (..)+  , UndirectedEdgeId (..)+  , VertexId (..)+  , asUndirected+  , directedPair+  , isNormalized+  , normalizedDirected+  , reverseEdge+  , reversedDirected+  )+import Moonlight.Triangulation.Handles.Iterators.FixedIterators+  ( innerFaces+  , undirectedEdges+  , vertices+  )+import Moonlight.Triangulation.Internal.Canonical (canonicalize)+import Moonlight.Triangulation.Internal.Cdt.Build+  ( constrainedDelaunay+  , fromDelaunay+  )+import Moonlight.Triangulation.Internal.Cdt.Query (constraintEdges)+import Moonlight.Triangulation.Internal.Cdt.Types+  ( CanonicalSegment+  , CdtError (..)+  , ConstrainedUnionError (..)+  , ConstrainedExtensionResult+  , ConstrainedSeamConstraintEvidence+  , ConstrainedSeamFaceEvidence+  , ConstrainedSeamResult+  , ConstrainedSeamSource (..)+  , ConstraintConflict+  , CorridorObstruction (..)+  , constrainedExtensionBuildStats+  , constrainedExtensionConstraintOutcomes+  , constrainedExtensionConstraintStats+  , constrainedExtensionTriangulation+  , constrainedSeamBuildStats+  , constrainedSeamConstraintRecovery+  , constrainedSeamConstraintSegment+  , constrainedSeamConstraintStats+  , constrainedSeamFaceFirstPoint+  , constrainedSeamFaceSecondPoint+  , constrainedSeamFaceThirdPoint+  , constrainedSeamLeftConstraintEvidence+  , constrainedSeamLeftFaceEvidence+  , constrainedSeamNewFaces+  , constrainedSeamResultTriangulation+  , constrainedSeamRightConstraintEvidence+  , constrainedSeamRightFaceEvidence+  , constrainedSeamSourceFace+  , constrainedSeamTargetFace+  , conflictFirstSegment+  , conflictSecondSegment+  , segmentEnd+  , segmentStart+  )+import Moonlight.Triangulation.Internal.Cdt.Union+  ( constraintSegments+  , extendConstrainedWith+  , joinSeparatedConstrainedWith+  , unionConstrained+  , unionConstrainedWith+  )+import Moonlight.Triangulation.Internal.Representation+  ( BuildResult+  , ConstrainedDelaunayTriangulation+  , DelaunayTriangulation+  , RefinementDomainResult+  , RefinementReceipt+  , RefinementResult+  , Triangulation+  , buildInputVertices+  , buildTriangulation+  , refinementDomainReceipt+  , refinementDomainResult+  , refinedTriangulation+  , refinementInterfaceBoundaryReads+  , refinementAttemptedBoundaryCrossings+  , refinementAddedVertices+  , refinementComplete+  , refinementCreatedFaces+  , refinementExcludedFaces+  , refinementRemovedEdges+  , refinementTouchedEdges+  , refinementVisitedJoinFaces+  , refinementVisitedProtectedFaces+  )+import Moonlight.Triangulation.Internal.Types+  ( BuildError (..)+  , ConstraintMode (..)+  , CoordinateError (..)+  , ElementDefaults (..)+  , HasPosition (..)+  , InvariantViolation (..)+  , LocationHint (..)+  , NearestStats (..)+  , NonFiniteValue (..)+  , Point (..)+  , PointValidationError (..)+  , QueryPoint+  , RefinementParameters (..)+  , SiteRelation (..)+  , defaultRefinementParameters+  , queryPointValue+  , unitElementDefaults+  )+import Moonlight.Triangulation.Interpolation+  ( interpolateBarycentric+  , interpolateNearest+  , nearestNeighbor+  )+import Moonlight.Triangulation.Math (mkQueryPoint)+import Moonlight.Triangulation.Payload (mapVertices)+import Moonlight.Triangulation.JoinSemilattice (JoinSemilattice (..))+import Moonlight.Triangulation.Refinement+  ( radiusEdgeRatioForAngle+  , refine+  , refineWithinDomain+  , validateRefinementParameters+  , withMinimumAngle+  )+import Moonlight.Triangulation.SetAlgebra+  ( difference+  , intersection+  , intersectionWith+  , siteRelation+  , symmetricDifference+  , union+  , unions+  )+import Moonlight.Triangulation.Validation (validateTriangulation)
+ src-serialize/Moonlight/Triangulation/Serialization.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | The versioned binary surface: encode a triangulation to bytes and read it+-- back. Decoding refuses a payload whose format version or coordinate encoding this+-- build does not own, rather than reinterpreting it.+module Moonlight.Triangulation.Serialization+  ( SerializationError (..)+  , serializationVersion+  , encodeTriangulation+  , decodeTriangulation+  ) where++import Control.Monad (replicateM, unless, when)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)+import Data.Binary (Binary (..))+import Data.Binary.Get+  ( Get+  , getDoublebe+  , getWord16be+  , getWord32be+  , getWord64be+  , getWord8+  , runGetOrFail+  )+import Data.Binary.Put+  ( Put+  , putDoublebe+  , putWord16be+  , putWord32be+  , putWord64be+  , putWord8+  , runPut+  )+import qualified Data.ByteString.Lazy as BL+import Data.Foldable (traverse_)+import qualified Data.IntSet as IntSet+import Data.Int (Int64)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Map.Strict as Map+import Data.Proxy (Proxy (..))+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import Data.Word (Word16, Word64, Word8)+import Moonlight.Triangulation.Internal.BoxedPaged (boxedFromVector, boxedToVector)+import Moonlight.Triangulation.Internal.Paged (fromLocalVector, fromVector, toVector)+import Moonlight.Triangulation.Internal.PointIndex (buildPointIndex)+import Moonlight.Triangulation.Handles.HandleDefs+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Math (mkQueryPoint)+import Moonlight.Triangulation.Validation (validateTriangulation)++instance Binary (Point) where+  put (Point x y) = putDoublebe x >> putDoublebe y+  get = Point <$> getDoublebe <*> getDoublebe++instance Binary VertexId where+  put (VertexId value) = putWord32be value+  get = VertexId <$> getWord32be++instance Binary FaceId where+  put (FaceId value) = putWord32be value+  get = FaceId <$> getWord32be++instance Binary DirectedEdgeId where+  put (DirectedEdgeId value) = putWord32be value+  get = DirectedEdgeId <$> getWord32be++instance Binary UndirectedEdgeId where+  put (UndirectedEdgeId value) = putWord32be value+  get = UndirectedEdgeId <$> getWord32be++-- | Every way serialization refuses, each naming its witness.+data SerializationError+  = BinaryDecodeFailure !Int64 !String+  | TrailingBytes !Int64+  | InvalidFormatMagic !Word64+  | UnsupportedFormatVersion !Word16+  | ConstraintModeTagMismatch !Word8 !Word8+  | CoordinateEncodingTagMismatch !Word8 !Word8+  | EncodedCountExceedsInt !Word64+  | SerializedCoordinateLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | SerializedVertexPayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | SerializedVertexOutgoingLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | SerializedDirectedEdgeCountOdd {-# UNPACK #-} !Int+  | SerializedNextLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | SerializedPreviousLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | SerializedFaceReferenceLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | SerializedDirectedPayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | SerializedUndirectedPayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | SerializedConstraintLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | SerializedMissingOuterFace+  | SerializedFacePayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | InvalidSerializedPoint {-# UNPACK #-} !Int !PointValidationError+  | NonCanonicalSerializedConstraintFlag !UndirectedEdgeId !Word8+  | SerializedConstraintCountMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | UnconstrainedSerializedConstraints {-# UNPACK #-} !Int+  | DuplicateSerializedCoordinates {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | DecodedInvariantViolations !(NonEmpty InvariantViolation)+  deriving stock (Eq, Show)++type Decoder = ExceptT SerializationError Get++-- | The envelope version this module writes.+serializationVersion :: Word16+serializationVersion = 4++formatMagic :: Word64+formatMagic = 0x5350414445485307 -- "SPADEHS" + canonical geometry-owned format family++binary64EncodingTag :: Word8+binary64EncodingTag = 2++-- | Write the versioned binary envelope.+encodeTriangulation+  :: forall mode vertex directed undirected face. (KnownConstraintMode mode, Binary vertex, Binary directed, Binary undirected, Binary face)+  => Triangulation mode vertex directed undirected face+  -> BL.ByteString+encodeTriangulation triangulation = runPut $ do+  putWord64be formatMagic+  putWord16be serializationVersion+  putWord8 (modeTag (constraintModeValue (modeProxy triangulation)))+  putWord8 binary64EncodingTag+  let ElementDefaults directedDefault undirectedDefault faceDefault = triElementDefaults triangulation+  put directedDefault+  put undirectedDefault+  put faceDefault+  -- Geometry and payloads are independent components. Persist the authoritative+  -- coordinate pages rather than attempting to recover them from annotations.+  putUVector putDoublebe (toVector (triPointX triangulation))+  putUVector putDoublebe (toVector (triPointY triangulation))+  putBoxedVector put (boxedToVector (triVertexData triangulation))+  putUVector putWord32be (toVector (triVertexOut triangulation))+  -- The wire format stores the four topology planes separately; the interleaved+  -- arena is a resident layout, not a serialization concern.+  let topology = toVector (triHalfTopology triangulation)+      plane field = U.generate (U.length topology `quot` 4) (\edge -> topology U.! (4 * edge + field))+  putUVector putWord32be (plane 0)+  putUVector putWord32be (plane 1)+  putUVector putWord32be (plane 2)+  putUVector putWord32be (plane 3)+  putBoxedVector put (boxedToVector (triDirectedData triangulation))+  putBoxedVector put (boxedToVector (triUndirectedData triangulation))+  putUVector putWord32be (toVector (triFaceEdge triangulation))+  putBoxedVector put (boxedToVector (triFaceData triangulation))+  putUVector putWord8 (toVector (triConstraint triangulation))+  putCount (fromIntegral (triConstraintCount triangulation))++-- | Decode one exact, versioned finite DCEL. Coordinate uniqueness and the+-- complete topology, geometry, and Delaunay/CDT invariants are checked before+-- the opaque value is returned.+decodeTriangulation+  :: forall mode vertex directed undirected face.+     ( KnownConstraintMode mode+     , Binary vertex+     , Binary directed+     , Binary undirected+     , Binary face+     )+  => BL.ByteString+  -> Either SerializationError (Triangulation mode vertex directed undirected face)+decodeTriangulation bytes =+  case runGetOrFail (runExceptT getTriangulation) bytes of+    Left (_, offset, message) -> Left (BinaryDecodeFailure offset message)+    Right (_, _, Left failure) -> Left failure+    Right (remaining, _, Right triangulation)+      | not (BL.null remaining) -> Left (TrailingBytes (BL.length remaining))+      | otherwise ->+          case validateTriangulation triangulation of+            [] -> Right triangulation+            firstViolation : remainingViolations ->+              Left (DecodedInvariantViolations (firstViolation :| remainingViolations))+ where+  getTriangulation :: Decoder (Triangulation mode vertex directed undirected face)+  getTriangulation = do+    magic <- lift getWord64be+    unless (magic == formatMagic) (throwE (InvalidFormatMagic magic))+    version <- lift getWord16be+    unless (version == serializationVersion) (throwE (UnsupportedFormatVersion version))+    encodedMode <- lift getWord8+    let expectedMode = modeTag (constraintModeValue (Proxy :: Proxy mode))+    unless (encodedMode == expectedMode) (throwE (ConstraintModeTagMismatch expectedMode encodedMode))+    encodedScalar <- lift getWord8+    let expectedScalar = binary64EncodingTag+    unless (encodedScalar == expectedScalar) (throwE (CoordinateEncodingTagMismatch expectedScalar encodedScalar))+    defaults <- ElementDefaults <$> lift get <*> lift get <*> lift get+    pointXs <- getUVector (lift getDoublebe)+    pointYs <- getUVector (lift getDoublebe)+    vertexDataVector <- getBoxedVector (lift get)+    vertexOut <- getUVector (lift getWord32be)+    halfOrigin <- getUVector (lift getWord32be)+    halfNext <- getUVector (lift getWord32be)+    halfPrev <- getUVector (lift getWord32be)+    halfFace <- getUVector (lift getWord32be)+    directedDataVector <- getBoxedVector (lift get)+    undirectedDataVector <- getBoxedVector (lift get)+    faceEdge <- getUVector (lift getWord32be)+    faceDataVector <- getBoxedVector (lift get)+    constraints <- getUVector (lift getWord8)+    cachedConstraintCount <- getCount++    let vertexCount = U.length pointXs+        pointYCount = U.length pointYs+        vertexPayloadCount = V.length vertexDataVector+        vertexOutgoingCount = U.length vertexOut+        halfCount = U.length halfOrigin+        nextCount = U.length halfNext+        previousCount = U.length halfPrev+        faceReferenceCount = U.length halfFace+        edgeCount = halfCount `quot` 2+        faceCount = U.length faceEdge+        directedPayloadCount = V.length directedDataVector+        undirectedPayloadCount = V.length undirectedDataVector+        constraintCount = U.length constraints+        facePayloadCount = V.length faceDataVector+        points = zipWith Point (U.toList pointXs) (U.toList pointYs)+    unless (pointYCount == vertexCount) (throwE (SerializedCoordinateLengthMismatch vertexCount pointYCount))+    unless (vertexPayloadCount == vertexCount) (throwE (SerializedVertexPayloadLengthMismatch vertexPayloadCount vertexCount))+    unless (vertexOutgoingCount == vertexCount) (throwE (SerializedVertexOutgoingLengthMismatch vertexOutgoingCount vertexCount))+    unless (even halfCount) (throwE (SerializedDirectedEdgeCountOdd halfCount))+    unless (nextCount == halfCount) (throwE (SerializedNextLengthMismatch nextCount halfCount))+    unless (previousCount == halfCount) (throwE (SerializedPreviousLengthMismatch previousCount halfCount))+    unless (faceReferenceCount == halfCount) (throwE (SerializedFaceReferenceLengthMismatch faceReferenceCount halfCount))+    unless (directedPayloadCount == halfCount) (throwE (SerializedDirectedPayloadLengthMismatch directedPayloadCount halfCount))+    unless (undirectedPayloadCount == edgeCount) (throwE (SerializedUndirectedPayloadLengthMismatch undirectedPayloadCount edgeCount))+    unless (constraintCount == edgeCount) (throwE (SerializedConstraintLengthMismatch constraintCount edgeCount))+    unless (faceCount >= 1) (throwE SerializedMissingOuterFace)+    unless (facePayloadCount == faceCount) (throwE (SerializedFacePayloadLengthMismatch facePayloadCount faceCount))+    traverse_ (uncurry validateStoredPoint) (zip [0 ..] points)++    case U.ifoldr (\index flag found -> if flag /= 0 && flag /= 1 then Just (index, flag) else found) Nothing constraints of+      Nothing -> pure ()+      Just (index, flag) ->+        throwE+          ( NonCanonicalSerializedConstraintFlag+              (UndirectedEdgeId (fromIntegral index))+              flag+          )+    let actualConstraintCount = U.foldl' (\count flag -> if flag == 1 then count + 1 else count) 0 constraints+    unless (cachedConstraintCount == actualConstraintCount) (throwE (SerializedConstraintCountMismatch cachedConstraintCount actualConstraintCount))+    when (expectedMode == 0 && actualConstraintCount /= 0) (throwE (UnconstrainedSerializedConstraints actualConstraintCount))++    let distinctPoints = Map.fromList (map (\point -> (point, ())) points)+        distinctPointCount = Map.size distinctPoints+    unless (distinctPointCount == vertexCount) (throwE (DuplicateSerializedCoordinates vertexCount distinctPointCount))++    let pointXStore = fromLocalVector 0 pointXs+        pointYStore = fromLocalVector 0 pointYs+        topologyStore =+          fromVector maxBound $+            U.generate (4 * halfCount) $ \slot ->+              let (edge, field) = slot `quotRem` 4+               in case field of+                    0 -> halfOrigin U.! edge+                    1 -> halfNext U.! edge+                    2 -> halfPrev U.! edge+                    _ -> halfFace U.! edge+        constraintEdgeIndex =+          U.ifoldl'+            (\edges index flag ->+               if flag == 1 then IntSet.insert index edges else edges+            )+            IntSet.empty+            constraints+    pure+      Triangulation+        { triPointX = pointXStore+        , triPointY = pointYStore+        , triPointIndex = buildPointIndex pointXStore pointYStore+        , triVertexOut = fromLocalVector maxBound vertexOut+        , triVertexData = boxedFromVector Nothing vertexDataVector+        , triHalfTopology = topologyStore+        , triDirectedData = boxedFromVector (Just (defaultDirectedEdgeData defaults)) directedDataVector+        , triUndirectedData = boxedFromVector (Just (defaultUndirectedEdgeData defaults)) undirectedDataVector+        , triFaceEdge = fromLocalVector maxBound faceEdge+        , triFaceData = boxedFromVector (Just (defaultFaceData defaults)) faceDataVector+        , triConstraint = fromVector 0 constraints+        , triConstraintCount = cachedConstraintCount+        , triConstraintEdges = constraintEdgeIndex+        , triElementDefaults = defaults+        }++validateStoredPoint :: Int -> Point -> Decoder ()+validateStoredPoint index point =+  case mkQueryPoint point of+    Left failure -> throwE (InvalidSerializedPoint index failure)+    Right _ -> pure ()++modeProxy :: Triangulation mode vertex directed undirected face -> Proxy mode+modeProxy _ = Proxy++modeTag :: ConstraintMode -> Word8+modeTag Unconstrained = 0+modeTag Constrained = 1++putCount :: Word64 -> Put+putCount = putWord64be++getCount :: Decoder Int+getCount = do+  raw <- lift getWord64be+  when (raw > fromIntegral (maxBound :: Int)) (throwE (EncodedCountExceedsInt raw))+  pure (fromIntegral raw)++putUVector :: U.Unbox a => (a -> Put) -> U.Vector a -> Put+putUVector putElement values = do+  putCount (fromIntegral (U.length values))+  U.mapM_ putElement values++getUVector :: U.Unbox a => Decoder a -> Decoder (U.Vector a)+getUVector getElement = do+  count <- getCount+  U.fromList <$> replicateM count getElement++putBoxedVector :: (a -> Put) -> V.Vector a -> Put+putBoxedVector putElement values = do+  putCount (fromIntegral (V.length values))+  V.mapM_ putElement values++getBoxedVector :: Decoder a -> Decoder (V.Vector a)+getBoxedVector getElement = do+  count <- getCount+  V.fromList <$> replicateM count getElement
+ test/algebra/Main.hs view
@@ -0,0 +1,9 @@+module Main (main) where++import qualified Moonlight.Triangulation.AlgebraSpec as AlgebraSpec+import qualified Moonlight.Triangulation.ScheduleAgreementSpec as ScheduleAgreementSpec++main :: IO ()+main = do+  AlgebraSpec.tests+  ScheduleAgreementSpec.tests
+ test/algebra/Moonlight/Triangulation/AlgebraFixtures.hs view
@@ -0,0 +1,268 @@+-- | The operand meshes and mesh observations both algebra slices are stated+-- over, built against the facade alone.+module Moonlight.Triangulation.AlgebraFixtures+  ( Mesh+  , PointMesh+  , meshOf+  , pointMeshOf+  , operands+  , separatedOperands+  , cocircularRing+  , collinearSites+  , latticeSites+  , pointsOf+  , dedupeAscending+  , siteList+  , siteSet+  , edgeKeys+  , assertMesh+  , assertMeshEquivalent+  , pairs+  , triples+  , advance+  , scramble+  , randomSites+  ) where++import Data.List (sortBy)+import Data.Ord (comparing)+import qualified Data.Set as Set+import qualified Data.Vector as V+import Data.Word (Word64)+import Moonlight.Triangulation+  ( DelaunayTriangulation+  , Point (Point)+  , VertexId+  , buildTriangulation+  , canonicalize+  , delaunay+  , mapVertices+  , numFaces+  , numUndirectedEdges+  , numVertices+  , undirectedEdges+  , undirectedEndpoints+  , unitElementDefaults+  , vertexPoint+  , vertices+  )+import Support (requireRight)++-- | The carrier. Geometry and nothing else: no vertex payload to need a+-- commutative combining rule, no element payloads to survive a rewrite that+-- destroys the elements they labelled.+type Mesh = DelaunayTriangulation ()++-- | The same carrier with its exact coordinate retained as the vertex+-- annotation. Annotation-preserving set laws use it to construct their+-- expected values without reaching below the public facade.+type PointMesh = DelaunayTriangulation (Point)++-- ── operands ─────────────────────────────────────────────────────────────────++-- | The site families the laws are exercised over.+--+-- Sized so that the cubic sweep in the associativity law stays cheap. Coverage+-- here is by /kind/ of degeneracy, not by count: what breaks a join is a+-- cocircular quad whose tie-break went the other way, or a mesh with no faces+-- at all, and neither of those becomes more likely at ten thousand sites.+families :: [(String, [Point])]+families =+  [ ("void", [])+  , ("single", [Point 3 (-7)])+  , ("pair", [Point 0 0, Point 4 1])+  , ("collinear", collinearSites)+  , ("cocircular", cocircularRing)+  , ("lattice", latticeSites)+  , ("repeated", concatMap (replicate 3) [Point 0 0, Point 5 0, Point 0 5, Point 5 5, Point 2 3])+  , ("scattered", randomSites 0xC0FFEEBABE 32)+  , ("extreme", [Point 1.0e-8 1.0e-8, Point 1.0e8 (-1.0e8), Point (-1.0e8) 1.0e8, Point 0 0, Point 1 1])+  ]++-- | Exactly cocircular lattice points on @x² + y² = 625@.+--+-- Trigonometric points would be cocircular only to within rounding, and the+-- rule this is here to exercise — the diagonal tie-break that fires when the+-- lifted quadrilateral is exactly flat — would then never fire at all.+cocircularRing :: [Point]+cocircularRing =+  [ Point (fromIntegral (signX * x)) (fromIntegral (signY * y))+  | (x, y) <- [(25, 0), (0, 25), (7, 24), (24, 7), (15, 20), (20, 15)] :: [(Int, Int)]+  , signX <- [1, -1]+  , signY <- [1, -1]+  ]++collinearSites :: [Point]+collinearSites = [Point (fromIntegral k) (2 * fromIntegral k - 1) | k <- [0 .. 9 :: Int]]++latticeSites :: [Point]+latticeSites = [Point (fromIntegral i) (fromIntegral j) | i <- [0 .. 4 :: Int], j <- [0 .. 4 :: Int]]++-- | The meshes every pairwise and triple law runs over.+--+-- Chosen for overlap structure rather than for size: disjoint operands, nested+-- ones, partially overlapping ones, the empty one, and — the case that matters+-- most — two meshes standing on the /same/ sites built in different orders, so+-- they are geometrically identical and structurally distinct.+operands :: IO [(String, Mesh)]+operands = do+  let sites name = maybe [] id (lookup name families)+      lattice = sites "lattice"+  void' <- meshOf "void" []+  single <- meshOf "single" (sites "single")+  collinear <- meshOf "collinear" (sites "collinear")+  ring <- meshOf "cocircular" (sites "cocircular")+  lower <- meshOf "lattice-lower" (take 15 lattice)+  upper <- meshOf "lattice-upper" (drop 10 lattice)+  repeated <- meshOf "repeated" (sites "repeated")+  scatterA <- meshOf "scattered" (sites "scattered")+  scatterB <- meshOf "scattered-scrambled" (scramble 0x5EED (sites "scattered"))+  pure+    [ ("void", void')+    , ("single", single)+    , ("collinear", collinear)+    , ("cocircular", ring)+    , ("lattice-lower", lower)+    , ("lattice-upper", upper)+    , ("repeated", repeated)+    , ("scattered", scatterA)+    , ("scattered-scrambled", scatterB)+    ]++-- | Operand pairs whose sites are separated by a vertical line, which is the+-- stratum a seam schedule is defined on and the one the old-edge identity is+-- sharpest over: with no shared site, every edge is unambiguously left, right+-- or cross.+separatedOperands :: IO [((String, Mesh), (String, Mesh))]+separatedOperands =+  traverse+    ( \(name, seed, count, shift) -> do+        let sites = randomSites seed count+        left <- meshOf (name <> "-left") sites+        right <- meshOf (name <> "-right") [Point (x + shift) y | Point x y <- sites]+        pure ((name <> "-left", left), (name <> "-right", right))+    )+    [ ("split-distant", 0x51DE1, 60, 1000)+    , ("split-near", 0x51DE2, 60, 3)+    , ("split-abutting", 0x51DE3, 60, 2.05)+    ]++-- ── construction ─────────────────────────────────────────────────────────────++meshOf :: String -> [Point] -> IO Mesh+meshOf label points = mapVertices (const ()) <$> pointMeshOf label points++pointMeshOf :: String -> [Point] -> IO PointMesh+pointMeshOf label points =+  buildTriangulation+    <$> requireRight ("build " <> label) (delaunay unitElementDefaults (V.fromList points))++pointsOf :: [(Double, Double)] -> [Point]+pointsOf keys = [Point x y | (x, y) <- keys]++dedupeAscending :: [(Double, Double)] -> [Point]+dedupeAscending sorted = [Point x y | (x, y) <- dropAdjacentDuplicates sorted]++dropAdjacentDuplicates :: Eq a => [a] -> [a]+dropAdjacentDuplicates (first : second : rest)+  | first == second = dropAdjacentDuplicates (second : rest)+  | otherwise = first : dropAdjacentDuplicates (second : rest)+dropAdjacentDuplicates rest = rest++-- ── observation ──────────────────────────────────────────────────────────────++siteKey :: Mesh -> VertexId -> (Double, Double)+siteKey mesh vertex = let Point x y = vertexPoint mesh vertex in (x, y)++siteList :: Mesh -> [(Double, Double)]+siteList mesh = [siteKey mesh vertex | vertex <- vertices mesh]++siteSet :: Mesh -> Set.Set (Double, Double)+siteSet = Set.fromList . siteList++edgeKeys :: Mesh -> Set.Set ((Double, Double), (Double, Double))+edgeKeys mesh =+  Set.fromList+    [ if left <= right then (left, right) else (right, left)+    | edge <- undirectedEdges mesh+    , let (from, to) = undirectedEndpoints mesh edge+    , let left = siteKey mesh from+    , let right = siteKey mesh to+    ]++-- | What a mesh looks like when two of them were supposed to be equal.+--+-- The interesting failure is the one where the coordinate-keyed edge sets+-- agree and the values do not: that is the join having become correct only up+-- to DCEL isomorphism, which is precisely what these laws exist to forbid, and+-- a report that only printed counts would hide it.+assertMesh :: String -> Mesh -> Mesh -> IO ()+assertMesh label expected actual+  | expected == actual = pure ()+  | otherwise = fail (label <> ": " <> report)+ where+  report+    | expectedEdges == actualEdges =+        "same geometry, different representation — "+          <> meshCounts expected+          <> " vs "+          <> meshCounts actual+    | otherwise =+        meshCounts expected+          <> " vs "+          <> meshCounts actual+          <> "; edges only in expected: "+          <> show (take 4 (Set.toList (Set.difference expectedEdges actualEdges)))+          <> "; only in actual: "+          <> show (take 4 (Set.toList (Set.difference actualEdges expectedEdges)))+  expectedEdges = edgeKeys expected+  actualEdges = edgeKeys actual++assertMeshEquivalent :: String -> Mesh -> Mesh -> IO ()+assertMeshEquivalent label expected actual = do+  canonicalExpected <-+    requireRight (label <> ": canonical expected") (canonicalize expected)+  canonicalActual <-+    requireRight (label <> ": canonical actual") (canonicalize actual)+  assertMesh label canonicalExpected canonicalActual++meshCounts :: Mesh -> String+meshCounts mesh =+  show (numVertices mesh)+    <> "v/"+    <> show (numUndirectedEdges mesh)+    <> "e/"+    <> show (numFaces mesh)+    <> "f"++-- ── combinatorics and pseudo-randomness ──────────────────────────────────────++pairs :: [a] -> [(a, a)]+pairs values = [(left, right) | left <- values, right <- values]++triples :: [a] -> [(a, a, a)]+triples values = [(a, b, c) | a <- values, b <- values, c <- values]++advance :: Word64 -> Word64+advance state = state * 6364136223846793005 + 1442695040888963407++randomWords :: Word64 -> Int -> [Word64]+randomWords seed count = take count (drop 1 (iterate advance seed))++-- | A deterministic permutation: decorate, sort by the key, discard it.+scramble :: Word64 -> [a] -> [a]+scramble seed values =+  map snd (sortBy (comparing fst) (zip (randomWords seed (length values)) values))++randomSites :: Word64 -> Int -> [Point]+randomSites seed count =+  [ Point (unitCoordinate first) (unitCoordinate second)+  | (first, second) <- take count (chunkPairs (randomWords seed (2 * count)))+  ]++chunkPairs :: [a] -> [(a, a)]+chunkPairs (first : second : rest) = (first, second) : chunkPairs rest+chunkPairs _ = []++unitCoordinate :: Word64 -> Double+unitCoordinate value = 2 * fromIntegral (value `div` 2048) / 9007199254740992 - 1
+ test/algebra/Moonlight/Triangulation/AlgebraSpec.hs view
@@ -0,0 +1,880 @@+{-# 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]+    ]
+ test/algebra/Moonlight/Triangulation/ScheduleAgreementSpec.hs view
@@ -0,0 +1,72 @@+-- | The schedule-agreement slice: the seam merge publishes what the reference+-- rebuild publishes. It travels and dies with the schedule it names.+module Moonlight.Triangulation.ScheduleAgreementSpec (tests) where++import Control.Monad (forM_, when)+import Data.IORef (modifyIORef', newIORef, readIORef)+import Moonlight.Triangulation (Point (Point), canonicalize, union)+import Moonlight.Triangulation.AlgebraFixtures+  ( assertMesh+  , meshOf+  , operands+  , separatedOperands+  , siteList+  )+import Moonlight.Triangulation.Internal.Join.Seam (executeSeam, planSeam)+import Support (requireRight)++tests :: IO ()+tests = do+  testSeamAgreesWithReference+  putStrLn "schedule agreement: ok"++-- | The seam schedule and the reference schedule are the same function.+--+-- A join has one meaning and several internal schedules, so this is the law+-- that lets a second one exist at all: for every input where the seam applies,+-- it must publish the value the rebuild publishes — not an isomorphic mesh, the+-- same value, once both are canonically numbered.+--+-- The guard matters more than the equality. 'executeSeam' can only be reached+-- with the opaque proof returned by 'planSeam'; the run fails if too few cases+-- obtain that proof, so the reference cannot quietly be compared with itself.+testSeamAgreesWithReference :: IO ()+testSeamAgreesWithReference = do+  separable <- separatedOperands+  overlapping <- operands+  taken <- newIORef (0 :: Int)+  forM_ separable $ \((leftName, left), (rightName, right)) -> do+    let label = "seam " <> leftName <> " / " <> rightName+    seamPlan <- case planSeam left right of+      Nothing ->+        fail (label <> ": the operands are separated but planSeam refused them")+      Just admitted -> do+        modifyIORef' taken (+ 1)+        pure admitted+    rawRebuild <- meshOf label [Point x y | (x, y) <- siteList left <> siteList right]+    rebuilt <- requireRight (label <> ", canonical rebuild") (canonicalize rawRebuild)+    seamed <- requireRight (label <> ", direct seam") (executeSeam seamPlan left right)+    canonicalSeam <- requireRight (label <> ", canonical seam") (canonicalize seamed)+    assertMesh (label <> ", against a rebuild") rebuilt canonicalSeam+    joined <- requireRight (label <> ", through union") (union left right)+    canonicalJoined <- requireRight (label <> ", canonical union") (canonicalize joined)+    assertMesh (label <> ", through the operator") rebuilt canonicalJoined+  forM_ [(l, r) | l <- overlapping, r <- overlapping] $ \((leftName, left), (rightName, right)) ->+    case planSeam left right of+      Nothing -> pure ()+      Just seamPlan -> do+        rawRebuild <-+          meshOf+            ("seam admission " <> leftName <> " / " <> rightName)+            [Point x y | (x, y) <- siteList left <> siteList right]+        rebuilt <- requireRight "seam admission canonical rebuild" (canonicalize rawRebuild)+        seamed <- requireRight "seam admission" (executeSeam seamPlan left right)+        canonicalSeam <- requireRight "seam admission canonical seam" (canonicalize seamed)+        assertMesh+          ("seam admission " <> leftName <> " / " <> rightName)+          rebuilt+          canonicalSeam+        modifyIORef' taken (+ 1)+  count <- readIORef taken+  when (count < 3) $+    fail ("seam agreement: only " <> show count <> " cases entered the seam, so the law asserted nothing")
+ test/coherence/Main.hs view
@@ -0,0 +1,13 @@+-- | Compile every test slice against the union of their dependencies. Empty+-- imports make module and instance collisions observable without executing the+-- four focused behavioral suites twice.+module Main (main) where++import Moonlight.Triangulation.AlgebraSpec ()+import Moonlight.Triangulation.NativeSpec ()+import Moonlight.Triangulation.ParallelSpec ()+import Moonlight.Triangulation.ScheduleAgreementSpec ()+import Moonlight.Triangulation.SerializationSpec ()++main :: IO ()+main = pure ()
+ test/native/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.NativeSpec as NativeSpec++main :: IO ()+main = NativeSpec.tests
+ test/native/Moonlight/Triangulation/FilteredPredicateOptimizationSpec.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE NumericUnderscores #-}+{-# OPTIONS_GHC -O1 #-}++-- | The allocation law for the optimized filtered-predicate artifact. This+-- module remains at O1 when the surrounding behavioral body is compiled at O0;+-- without the simplifier, the loop does not unbox and the witness is vacuous.+module Moonlight.Triangulation.FilteredPredicateOptimizationSpec+  ( assertFilteredPredicatesSkipExactOracle+  ) where++import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Monad (unless)+import GHC.Stats (allocated_bytes, getRTSStats, getRTSStatsEnabled)+import Moonlight.Triangulation.Math+  ( inCircle+  , inCircleDetApprox+  , orient2d+  , orientDetApprox+  )+import Moonlight.Triangulation.Types (Point (..))+import System.Mem (performGC)+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import Data.Word (Word64)++-- | A filtered predicate must not evaluate its exact oracle when the floating+-- approximation already certifies the sign. The exact path allocates+-- 'Integer's, so equal-shaped certified and degenerate folds expose whether+-- that fallback remains genuinely conditional.+assertFilteredPredicatesSkipExactOracle :: IO ()+assertFilteredPredicatesSkipExactOracle = do+  enabled <- getRTSStatsEnabled+  unless enabled $ fail "allocation counters unavailable: the suite must run with -T"+  let count = 20_000+      bigScale = 2 ^^ (200 :: Int) :: Double+      smallScale = 2 ^^ (-200 :: Int) :: Double+      orientCertified =+        V.generate+          count+          (\index -> Point (fromIntegral index * bigScale) (if even index then 0 else smallScale))+      orientDegenerate =+        V.generate+          count+          (\index -> Point (fromIntegral index * bigScale) (fromIntegral index * smallScale))+      zigzag = V.generate count (\index -> Point (fromIntegral index) (if even index then 0 else 1))+      collinear = V.generate count (\index -> Point (fromIntegral index) (fromIntegral index))+      orientationIndices = U.enumFromN 0 (max 0 (count - 2))+      circleIndices = U.enumFromN 0 (max 0 (count - 3))+  _ <- evaluate (force orientCertified)+  _ <- evaluate (force orientDegenerate)+  _ <- evaluate (force zigzag)+  _ <- evaluate (force collinear)+  _ <- evaluate (force orientationIndices)+  _ <- evaluate (force circleIndices)+  certifiedSupport <- allocationOf (sumTripleRelations approximateOrientation orientationIndices orientCertified)+  fallbackSupport <- allocationOf (sumTripleRelations approximateOrientation orientationIndices orientDegenerate)+  certified <- allocationOf (sumTripleRelations orient2d orientationIndices orientCertified)+  fallback <- allocationOf (sumTripleRelations orient2d orientationIndices orientDegenerate)+  let certifiedOracle = allocationBeyondApproximation certified certifiedSupport+      fallbackOracle = allocationBeyondApproximation fallback fallbackSupport+  unless (fallbackOracle > 0) $+    fail "degenerate orientations allocated nothing: the measurement is not observing the oracle"+  unless (certifiedOracle * 8 < fallbackOracle) $+    fail+      ( "orient2d evaluates its exact oracle on certified input: "+          <> show certifiedOracle+          <> " excess bytes certified versus "+          <> show fallbackOracle+          <> " excess bytes degenerate (raw "+          <> show certified+          <> " versus "+          <> show fallback+          <> ")"+      )+  certifiedCircleSupport <- allocationOf (sumQuadRelations approximateInCircle circleIndices zigzag)+  fallbackCircleSupport <- allocationOf (sumQuadRelations approximateInCircle circleIndices collinear)+  certifiedCircle <- allocationOf (sumQuadRelations inCircle circleIndices zigzag)+  fallbackCircle <- allocationOf (sumQuadRelations inCircle circleIndices collinear)+  let certifiedCircleOracle = allocationBeyondApproximation certifiedCircle certifiedCircleSupport+      fallbackCircleOracle = allocationBeyondApproximation fallbackCircle fallbackCircleSupport+  unless (fallbackCircleOracle > 0) $+    fail "degenerate incircles allocated nothing: the measurement is not observing the oracle"+  unless (certifiedCircleOracle * 8 < fallbackCircleOracle) $+    fail+      ( "inCircle evaluates its exact oracle on certified input: "+          <> show certifiedCircleOracle+          <> " excess bytes certified versus "+          <> show fallbackCircleOracle+          <> " excess bytes degenerate (raw "+          <> show certifiedCircle+          <> " versus "+          <> show fallbackCircle+          <> ")"+      )++allocationOf :: Int -> IO Word64+allocationOf work = do+  performGC+  before <- allocated_bytes <$> getRTSStats+  _ <- evaluate work+  performGC+  after <- allocated_bytes <$> getRTSStats+  pure (after - before)++allocationBeyondApproximation :: Word64 -> Word64 -> Word64+allocationBeyondApproximation measured support = measured - min measured support++sumTripleRelations+  :: (Point -> Point -> Point -> Ordering)+  -> U.Vector Int+  -> V.Vector (Point)+  -> Int+sumTripleRelations relation indices points =+  U.foldl'+    (\accumulated index ->+       accumulated+         + fromEnum+           ( relation+               (V.unsafeIndex points index)+               (V.unsafeIndex points (index + 1))+               (V.unsafeIndex points (index + 2))+           )+    )+    0+    indices+{-# INLINE sumTripleRelations #-}++sumQuadRelations+  :: (Point -> Point -> Point -> Point -> Ordering)+  -> U.Vector Int+  -> V.Vector (Point)+  -> Int+sumQuadRelations relation indices points =+  U.foldl'+    (\accumulated index ->+       accumulated+         + fromEnum+           ( relation+               (V.unsafeIndex points index)+               (V.unsafeIndex points (index + 1))+               (V.unsafeIndex points (index + 2))+               (V.unsafeIndex points (index + 3))+           )+    )+    0+    indices+{-# INLINE sumQuadRelations #-}++approximateOrientation :: Point -> Point -> Point -> Ordering+approximateOrientation a b c = compare (orientDetApprox a b c) 0+{-# INLINE approximateOrientation #-}++approximateInCircle :: Point -> Point -> Point -> Point -> Ordering+approximateInCircle a b c d = compare (inCircleDetApprox a b c d) 0+{-# INLINE approximateInCircle #-}
+ test/native/Moonlight/Triangulation/NativeSpec.hs view
@@ -0,0 +1,2956 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | The native core slice: everything that needs no serialization surface.+module Moonlight.Triangulation.NativeSpec (tests) where++import Control.DeepSeq (NFData, force)+import Control.Exception (evaluate)+import Control.Monad (forM_, unless, void, when)+import Control.Monad.ST (runST, stToIO)+import GHC.Float (castDoubleToWord64)+import Data.Maybe (isJust)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.List (sort)+import qualified Data.Vector as V+import Data.Primitive.PrimArray (indexPrimArray, primArrayFromList, sizeofPrimArray)+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32, Word64)+import Moonlight.Triangulation.BulkLoad+import Moonlight.Triangulation.Cdt+import Moonlight.Triangulation.Dcel+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.FloodFillIterator+import Moonlight.Triangulation.Handles+import Moonlight.Triangulation.HintGenerator+import Moonlight.Triangulation.Interpolation+import Moonlight.Triangulation.IntersectionIterator+import Moonlight.Triangulation.Math+import Moonlight.Triangulation.Payload+import Moonlight.Triangulation.FilteredPredicateOptimizationSpec+  ( assertFilteredPredicatesSkipExactOracle+  )+import Moonlight.Triangulation.PointLocation+import Moonlight.Triangulation.Refinement+import Moonlight.Triangulation.Removal+import Moonlight.Triangulation.Scalar+import Moonlight.Triangulation.Session+import Moonlight.Triangulation.Types+import Moonlight.Triangulation.Validation+import Moonlight.Triangulation.Voronoi+import Moonlight.Triangulation.Handles.Dynamic qualified as Dynamic+import Moonlight.Triangulation.Handles.Iterators.DynamicIterators qualified as DynamicIterators+import Moonlight.Triangulation.Internal.Canonical (canonicalize)+import Moonlight.Triangulation.Internal.Paged (Paged, fromVector, toVector)+import Moonlight.Triangulation.Internal.PointIndex+  ( MutablePointIndexUpdate (..)+  , lookupMutablePoint+  , newMutablePointIndex+  , relocateMutablePoint+  , removeMutablePoint+  , seedMutablePointIndex+  )+import Moonlight.Triangulation.Internal.Representation qualified as Internal+import Moonlight.Triangulation.Voronoi.Handles qualified as VoronoiDynamic+import GHC.Generics (Generic)+import Support (assertEqual, assertValid, requireQueryPoint, requireRight)++tests :: IO ()+tests = do+  testConstructors+  testPredicates+  testParaboloidLift+  assertFilteredPredicatesSkipExactOracle+  testValidationRejectsCorruptedMeshes+  testRefinementCompletionIsAFixpoint+  testScalarFormat+  testWideDistanceNearestNeighbor+  testIncrementalLocationDescent+  testPersistentInsertionReusesFrozenLocation+  testCircleSweepBulkLoad+  testMixedEditSession+  testBulkRemovalAgreement+  testMutablePointIndexWraparoundBackshift+  testBatchIdentityIndexBatchToEmpty+  testBatchIdentityIndexToSingletonActive+  testBulkIdentityIndexDoesNotEscapeRemovalBatch+  testHierarchyRemovalAgreement+  testHandlesAndFiniteDcel+  testDegenerateConstruction+  testPersistentLocalUpdates+  testGenericPayloads+  testPayloadMaps+  testPayloadTraversals+  testRewritePayloadIdentity+  testPointLocationAndHints+  testHierarchyNestingLaw+  testSibsonInterpolation+  testVoronoiDual+  testRemoval+  testConstrainedDelaunay+  testAnnotatedConstrainedUnion+  testAsymmetricConstrainedExtension+  testLargeAsymmetricConstrainedExtension+  testSeparatedConstrainedSeam+  testConstrainedRefinement+  testCheckedLocalRefinement+  testRepeatedBoundaryAdjacentRefinement+  testTraversal+  testRandomizedConstruction+  testErrors+  putStrLn "all native core tests passed"++data SampleVertex = SampleVertex+  { samplePosition :: !(Point)+  , sampleLabel :: !Int+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++instance HasPosition SampleVertex where+  position = samplePosition+++testConstructors :: IO ()+testConstructors = do+  let vacant = empty unitElementDefaults :: DelaunayTriangulation (Point)+  originQuery <- requireQueryPoint "empty location query" (Point 0 0)+  assertValid "empty" vacant+  assertEqual "empty vertex count" 0 (numVertices vacant)+  assertEqual "empty directed edge count" 0 (numDirectedEdges vacant)+  assertEqual "empty face count" 1 (numFaces vacant)+  assertEqual "empty locates nowhere" EmptyTriangulation (locatePoint vacant originQuery)+  built <- requirePointBuild "clear source" [Point 0 0, Point 1 0, Point 0 1]+  assertEqual "clear returns the origin" vacant (clear (buildTriangulation built))++type NativeMesh = Triangulation 'Unconstrained (Point) () () ()++-- | A named corruption of a mesh that was valid one line earlier, paired with+-- the violation it must provoke. Validation that has never been made to fail is+-- evidence only that it ran.+data Corruption = Corruption+  { corruptionName :: String+  , corruptMesh :: NativeMesh -> NativeMesh+  , provokes :: InvariantViolation -> Bool+  }++-- Sheared so that no four sites are cocircular: on a square grid the diagonal+-- of every cell is a free choice, and a fixture that admits two answers cannot+-- witness a wrong one.+corruptionFixture :: [Point]+corruptionFixture =+  [ Point (fromIntegral column + 0.25 * fromIntegral row) (1.3 * fromIntegral row)+  | column <- [0 .. 3 :: Int]+  , row <- [0 .. 3 :: Int]+  ]++rewritePlane :: (U.Unbox a, Num a) => (U.Vector a -> U.Vector a) -> Paged a -> Paged a+rewritePlane edit = fromVector 0 . edit . toVector++slot :: U.Unbox a => Int -> a -> U.Vector a -> U.Vector a+slot at value = (U.// [(at, value)])++-- Past the end of every plane in the fixture, and far from the sentinels the+-- packed representation reserves for absence.+beyond :: NativeMesh -> Word32+beyond mesh = fromIntegral (numDirectedEdges mesh + numVertices mesh + 64)++onTopology :: (NativeMesh -> U.Vector Word32 -> U.Vector Word32) -> NativeMesh -> NativeMesh+onTopology edit mesh =+  mesh {Internal.triHalfTopology = rewritePlane (edit mesh) (Internal.triHalfTopology mesh)}++-- The half-edge plane has stride four — origin, next, previous, face — so the+-- first four entries below are one surgery distinguished only by which field+-- the out-of-range index lands on.+structuralCorruptions :: [Corruption]+structuralCorruptions =+  [ Corruption+      "edge origin names an absent vertex"+      (onTopology (slot 0 . beyond))+      (\case EdgeOriginOutOfRange {} -> True; _ -> False)+  , Corruption+      "edge next names an absent edge"+      (onTopology (slot 1 . beyond))+      (\case EdgeNextOutOfRange {} -> True; _ -> False)+  , Corruption+      "edge previous names an absent edge"+      (onTopology (slot 2 . beyond))+      (\case EdgePreviousOutOfRange {} -> True; _ -> False)+  , Corruption+      "edge face names an absent face"+      (onTopology (slot 3 . beyond))+      (\case EdgeFaceOutOfRange {} -> True; _ -> False)+  , Corruption+      "vertex outgoing names an absent edge"+      ( \mesh ->+          mesh+            { Internal.triVertexOut =+                rewritePlane (slot 0 (beyond mesh)) (Internal.triVertexOut mesh)+            }+      )+      (\case VertexOutgoingOutOfRange {} -> True; _ -> False)+  , Corruption+      "a coordinate plane is one short"+      (\mesh -> mesh {Internal.triPointX = rewritePlane U.init (Internal.triPointX mesh)})+      (\case CoordinatePlaneLengthMismatch {} -> True; _ -> False)+  , Corruption+      "every inner face wound clockwise"+      (\mesh -> mesh {Internal.triPointY = rewritePlane (U.map negate) (Internal.triPointY mesh)})+      (\case InnerFaceNotCounterClockwise {} -> True; _ -> False)+  ]++-- Structural corruption is caught before geometry is read, so the empty-circle+-- law needs a mesh that stays well formed and merely stops being Delaunay.+delaunayCorruptions :: [Corruption]+delaunayCorruptions =+  [ Corruption+      "one site dragged through its neighbours' circumcircles"+      (\mesh -> mesh {Internal.triPointX = rewritePlane (slot 5 40) (Internal.triPointX mesh)})+      (\case LocallyIllegalDelaunayEdge {} -> True; _ -> False)+  ]++-- A surgery that changed nothing would report the oracle as unarmed when in+-- truth it was never asked anything, so the mutant must differ before its+-- rejection means a thing.+assertRejects+  :: String -> (NativeMesh -> [InvariantViolation]) -> NativeMesh -> Corruption -> IO ()+assertRejects oracle check pristine corruption = do+  let mutant = corruptMesh corruption pristine+      label = oracle <> " / " <> corruptionName corruption+      reported = check mutant+  when (mutant == pristine) $ fail (label <> ": the surgery changed nothing")+  unless (any (provokes corruption) reported) $+    fail (label <> ": admitted, reporting " <> show reported)++testValidationRejectsCorruptedMeshes :: IO ()+testValidationRejectsCorruptedMeshes = do+  built <- requirePointBuild "corruption fixture" corruptionFixture+  let pristine = buildTriangulation built+  assertValid "corruption fixture" pristine+  mapM_ (assertRejects "topology" validateTopology pristine) structuralCorruptions+  mapM_ (assertRejects "delaunay" validateDelaunay pristine) delaunayCorruptions++-- Twin half-edges are arithmetic complements, so a crossing's undirected+-- identity is its handle halved. Comparing cardinality alone would admit a+-- traversal that returned the right number of the wrong crossings.+crossingIdentity :: Intersection -> Either Int Int+crossingIdentity = \case+  EdgeIntersection edge -> Right (fromIntegral (unDirectedEdgeId edge) `quot` 2)+  EdgeOverlap edge -> Right (fromIntegral (unDirectedEdgeId edge) `quot` 2)+  VertexIntersection vertex -> Left (fromIntegral (unVertexId vertex))++-- | What @refinementComplete@ claims is that the quality worklist drained. The+-- assertable content of that claim is a fixpoint: a second pass under the same+-- parameters can admit nothing. The complementary run is budget-starved, where+-- the run must stop short and spend exactly what it was given.+testRefinementCompletionIsAFixpoint :: IO ()+testRefinementCompletionIsAFixpoint = do+  -- Barrier parity needs constraints to bound a domain: on an unconstrained+  -- mesh every face sits at depth zero, so excluding outer faces excludes all+  -- of them and the worklist drains having refined nothing.+  bounded <-+    requireRight "refinement fixpoint domain" $+      constrainedDelaunay+        unitElementDefaults+        (V.fromList [Point 0 0, Point 8 0, Point 8 8, Point 0 8])+        (V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)])+  let source = buildTriangulation bounded+      parameters =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just 500+          , refineMaxArea = Just 3+          , refineExcludeOuterFaces = True+          }+  drained <- requireRight "drained refinement" (refine id parameters source)+  unless (refinementComplete drained) $+    fail "the refinement budget was too small to drain the worklist"+  -- Without this the fixpoint below is vacuous: a run that refined nothing+  -- trivially admits nothing on a second pass.+  unless (refinementAddedVertices drained > 0) $+    fail "the drained run inserted no Steiner points, so the fixpoint proves nothing"+  assertValid "drained refinement" (refinedTriangulation drained)+  again <- requireRight "second refinement pass" (refine id parameters (refinedTriangulation drained))+  assertEqual+    "a drained worklist admits nothing on a second pass"+    0+    (refinementAddedVertices again)+  starved <-+    requireRight+      "starved refinement"+      (refine id parameters {refineMaxAdditionalVertices = Just 3} source)+  when (refinementComplete starved) $+    fail "a three-vertex budget reported a drained worklist"+  assertEqual "a starved run spends exactly its budget" 3 (refinementAddedVertices starved)++testScalarFormat :: IO ()+testScalarFormat = do+  let binary64 = scalarBinaryFormat+  assertEqual "binary64 radix" 2 (formatRadix binary64)+  assertEqual "binary64 mantissa" 53 (formatMantissaDigits binary64)+  assertEqual "binary64 unit roundoff" (encodeFloat 1 (-53)) (scalarUnitRoundoff :: Double)++testWideDistanceNearestNeighbor :: IO ()+testWideDistanceNearestNeighbor = do+  let largePoints = V.fromList+        [ Point 0 0+        , Point 1.0e20 0+        , Point 2.0e20 0+        , Point 1.0e20 1.0e19+        ] :: V.Vector (Point)+  largeBuild <- requireRight "wide-distance build" (delaunay unitElementDefaults largePoints)+  let largeTriangulation = buildTriangulation largeBuild+  assertValid "wide-distance triangulation" largeTriangulation+  query <- requireQueryPoint "wide-distance query" (Point 1.05e20 0)+  case nearestNeighbor largeTriangulation Nothing query of+    Nothing -> fail "wide-distance nearest-neighbor returned Nothing"+    Just (nearest, _) -> assertEqual "wide-distance nearest-neighbor" (VertexId 1) nearest++data IncrementalLocationEvidence = IncrementalLocationEvidence+  { incrementalTriangulation :: !(DelaunayTriangulation (Point))+  , incrementalWalkSteps :: {-# UNPACK #-} !Int+  , incrementalFallbacks :: {-# UNPACK #-} !Int+  }++testIncrementalLocationDescent :: IO ()+testIncrementalLocationDescent = do+  small <- collectIncrementalLocationEvidence 500+  large <- collectIncrementalLocationEvidence 1000+  assertEqual "incremental location fallbacks/500" 0 (incrementalFallbacks small)+  assertEqual "incremental location fallbacks/1000" 0 (incrementalFallbacks large)+  unless (2 * incrementalWalkSteps large < 7 * incrementalWalkSteps small) $+    fail+      ( "incremental location approached quadratic growth: "+          <> show (incrementalWalkSteps small, incrementalWalkSteps large)+      )+  assertValid "incremental location descent/1000" (incrementalTriangulation large)++collectIncrementalLocationEvidence :: Int -> IO IncrementalLocationEvidence+collectIncrementalLocationEvidence count =+  V.foldM' insertAndAccumulate initialEvidence (V.fromList (randomPoints 0xc1ac_10ca count))+ where+  initialEvidence =+    IncrementalLocationEvidence+      { incrementalTriangulation = empty unitElementDefaults+      , incrementalWalkSteps = 0+      , incrementalFallbacks = 0+      }++  insertAndAccumulate evidence point = do+    result <- requireRight "incremental location descent" (insert (incrementalTriangulation evidence) point)+    let stats = insertionStats result+    pure+      IncrementalLocationEvidence+        { incrementalTriangulation = insertionTriangulation result+        , incrementalWalkSteps = incrementalWalkSteps evidence + statLocationWalkSteps stats+        , incrementalFallbacks = incrementalFallbacks evidence + statLocationFallbacks stats+        }++-- A persistent insertion locates on the frozen mesh before opening its dense+-- transaction. The thaw preserves every extant handle, so a lawful frozen+-- location can be interpreted directly without a second mutable walk. A+-- degenerate-line outside witness lacks the terminal-edge evidence its mutable+-- interpreter requires, so that one stratum deliberately retains the mutable+-- fallback. Exercise every frozen stratum, including the singleton's edge-less+-- outside witness, rather than testing only the ordinary face case.+testPersistentInsertionReusesFrozenLocation :: IO ()+testPersistentInsertionReusesFrozenLocation = do+  let vacant = empty unitElementDefaults :: DelaunayTriangulation (Point)+  emptyLocation <- assertPersistentInsertionFromFrozenLocation "empty" Inserted vacant (Point 0 0)+  assertEqual "empty insertion frozen location" EmptyTriangulation emptyLocation++  singletonBuild <- requirePointBuild "singleton frozen location" [Point 0 0]+  singletonLocation <-+    assertPersistentInsertionFromFrozenLocation+      "singleton outside insertion"+      Inserted+      (buildTriangulation singletonBuild)+      (Point 2 0)+  assertEqual "singleton insertion frozen location" (OutsideConvexHull Nothing) singletonLocation++  lineBuild <- requirePointBuild "line frozen locations" [Point 0 0, Point 2 0, Point 4 0]+  let line = buildTriangulation lineBuild+  lineEdgeLocation <- assertPersistentInsertionFromFrozenLocation "line edge insertion" Inserted line (Point 1 0)+  case lineEdgeLocation of+    OnEdge _ -> pure ()+    other -> fail ("line edge insertion located " <> show other)+  lineOutsideLocation <- assertPersistentInsertionFromFrozenLocation "line extension" Inserted line (Point 6 0)+  case lineOutsideLocation of+    OutsideConvexHull (Just _) -> pure ()+    other -> fail ("line extension located " <> show other)++  triangleBuild <- requirePointBuild "area frozen locations" [Point 0 0, Point 4 0, Point 0 4]+  let triangle = buildTriangulation triangleBuild+  faceLocation <- assertPersistentInsertionFromFrozenLocation "face insertion" Inserted triangle (Point 1 1)+  case faceLocation of+    InFace _ -> pure ()+    other -> fail ("face insertion located " <> show other)+  edgeLocation <- assertPersistentInsertionFromFrozenLocation "area edge insertion" Inserted triangle (Point 2 0)+  case edgeLocation of+    OnEdge _ -> pure ()+    other -> fail ("area edge insertion located " <> show other)+  hullLocation <- assertPersistentInsertionFromFrozenLocation "hull insertion" Inserted triangle (Point 5 1)+  case hullLocation of+    OutsideConvexHull (Just _) -> pure ()+    other -> fail ("hull insertion located " <> show other)+  duplicateLocation <- assertPersistentInsertionFromFrozenLocation "duplicate insertion" AlreadyPresent triangle (Point 0 0)+  assertEqual "duplicate insertion frozen location" (OnVertex (VertexId 0)) duplicateLocation++assertPersistentInsertionFromFrozenLocation+  :: String+  -> InsertionDisposition+  -> DelaunayTriangulation (Point)+  -> Point+  -> IO Location+assertPersistentInsertionFromFrozenLocation label expectedDisposition source point = do+  query <- requireQueryPoint (label <> " frozen query") point+  let (located, walked) = locatePointWithHint source Nothing query+      sourceVertices = numVertices source+      usesMutableFallback =+        case located of+          OutsideConvexHull (Just _) -> numInnerFaces source == 0+          _ -> False+  result <- requireRight (label <> " insert") (insert source point)+  ((referenceVertex, referenceDisposition), reference, _) <-+    requireRight (label <> " session reference") $+      withSession source 1 (insertVertexAt point point)+  let stats = insertionStats result+      expectedVertices =+        case expectedDisposition of+          Inserted -> sourceVertices + 1+          AlreadyPresent -> sourceVertices+      expectedUnique =+        case expectedDisposition of+          Inserted -> 1+          AlreadyPresent -> 0+      expectedExisting =+        case expectedDisposition of+          Inserted -> 0+          AlreadyPresent -> 1+  assertEqual (label <> " disposition") expectedDisposition (insertionDisposition result)+  assertEqual (label <> " session disposition") referenceDisposition (insertionDisposition result)+  assertEqual (label <> " session vertex") referenceVertex (insertionVertex result)+  assertEqual+    (label <> " exact-location topology matches session")+    (canonicalEdges reference)+    (canonicalEdges (insertionTriangulation result))+  assertEqual (label <> " source remains unchanged") sourceVertices (numVertices source)+  assertEqual (label <> " result vertex count") expectedVertices (numVertices (insertionTriangulation result))+  assertEqual (label <> " input count") 1 (statInputPoints stats)+  assertEqual (label <> " unique count") expectedUnique (statUniquePoints stats)+  assertEqual (label <> " existing count") expectedExisting (statExistingPoints stats)+  assertEqual (label <> " duplicate count") expectedExisting (statDuplicatePoints stats)+  if usesMutableFallback+    then do+      let assertAtLeast counter expected actual =+            unless+              (actual >= expected)+              ( fail+                  ( label+                      <> " "+                      <> counter+                      <> " includes frozen evidence: expected at least "+                      <> show expected+                      <> ", got "+                      <> show actual+                  )+              )+      assertAtLeast "walk steps" (locationWalkSteps walked) (statLocationWalkSteps stats)+      assertAtLeast "walk maximum" (locationWalkSteps walked) (statLocationMaxWalk stats)+      assertAtLeast+        "fallback count"+        (if locationUsedFallback walked then 1 else 0)+        (statLocationFallbacks stats)+    else do+      assertEqual (label <> " frozen walk steps") (locationWalkSteps walked) (statLocationWalkSteps stats)+      assertEqual (label <> " frozen walk maximum") (locationWalkSteps walked) (statLocationMaxWalk stats)+      assertEqual+        (label <> " frozen fallback count")+        (if locationUsedFallback walked then 1 else 0)+        (statLocationFallbacks stats)+  assertValid (label <> " result") (insertionTriangulation result)+  pure located++-- Circle sweep must be a construction schedule, not a second topology. It is+-- compared against the arrival-order session kernel on the same exact inputs.+-- | One session, both verbs. The reason the two published sessions became one:+-- a caller who removes and inserts had to thaw twice and pay the O(n)+-- publication a session exists to delete.+--+-- Graded against the oracle that needs no second implementation — the Delaunay+-- triangulation of a point set in general position is unique, so a mixed edit+-- must land exactly where a fresh bulk load of the surviving set lands.+testMixedEditSession :: IO ()+testMixedEditSession = do+  let original = V.fromList (randomPoints 0x5eed1e 400)+      doomed = V.take 120 original+      survivors = V.drop 120 original+      arrivals = V.fromList (randomPoints 0xa7717a1 90)+  (_, edited, stats) <-+    requireRight "mixed session" $+      withSession+        (buildTriangulation (either (error . show) id (delaunay unitElementDefaults original)))+        (V.length arrivals)+        ( do+            V.mapM_ (\point -> removeAt point >>= maybe (refuse (RemovalVertexOutOfRange (VertexId 0) 0)) (const (pure ()))) doomed+            V.mapM_ insertVertex arrivals+        )+  fresh <- requireRight "fresh rebuild" (delaunay unitElementDefaults (survivors <> arrivals))+  assertEqual+    "mixed edit equals a fresh build of the surviving set"+    (canonicalEdges (buildTriangulation fresh))+    (canonicalEdges edited)+  assertValid "mixed edit session" edited+  assertEqual+    "the whole transaction charged one counter set"+    (V.length arrivals)+    (statInputPoints stats)++-- The bulk removal verb must land exactly where the singleton fold lands, on+-- both sides of its locate-strategy crossover: a small batch keeps the+-- per-question walk, a large one buys the identity index once. Same removals,+-- same order, same survivor either way.+testBulkRemovalAgreement :: IO ()+testBulkRemovalAgreement = do+  let original = V.fromList (randomPoints 0xb01dca7 400)+      base = buildTriangulation (either (error . show) id (delaunay unitElementDefaults original))+      run label doomed = do+        (outcomes, survived, _) <-+          requireRight (label <> " bulk removal") (withSession base 0 (removeManyAt doomed))+        V.imapM_+          ( \index outcome ->+              maybe (fail (label <> " bulk removal missed index " <> show index)) (const (pure ())) outcome+          )+          outcomes+        (_, folded, _) <-+          requireRight (label <> " singleton removal fold") $+            withSession+              base+              0+              ( V.mapM_+                  (\point -> removeAt point >>= maybe (refuse (RemovalVertexOutOfRange (VertexId 0) 0)) (const (pure ())))+                  doomed+              )+        assertEqual+          (label <> " bulk removal equals singleton descent")+          (canonicalEdges folded)+          (canonicalEdges survived)+        assertValid (label <> " bulk removal") survived+  run "walking" (V.take 40 original)+  run "indexed" (V.take 120 original)++-- The three fixture positions hash to home slot 15 in the 16-slot table made+-- for three keys. They therefore occupy 15, 0, and 1 in insertion order. The+-- middle deletion exercises both wraparound and backward shift, while the+-- coordinate overwrite models the tail move performed before the table handle+-- is renamed by 'swapRemoveVertex'.+testMutablePointIndexWraparoundBackshift :: IO ()+testMutablePointIndexWraparoundBackshift = do+  (removed, first, movedBeforeRelocation, relocated, movedAfterRelocation) <-+    requireRight "mutable point-index wraparound/backshift law" wraparoundLaw+  case removed of+    MutablePointIndexUpdated -> pure ()+    MutablePointIndexInvalidated -> fail "mutable point-index middle delete invalidated a valid table"+  assertEqual "mutable point-index first wraparound occupant" (Just 0) first+  assertEqual "mutable point-index shifted tail before relocation" (Just 2) movedBeforeRelocation+  case relocated of+    MutablePointIndexUpdated -> pure ()+    MutablePointIndexInvalidated -> fail "mutable point-index tail relocation invalidated a valid table"+  assertEqual "mutable point-index relocated tail" (Just 1) movedAfterRelocation+ where+  wraparoundLaw = runST $ do+    pointXs <- MUV.replicate 3 (0 :: Double)+    pointYs <- MUV.replicate 3 (0 :: Double)+    MUV.unsafeWrite pointXs 0 (-20)+    MUV.unsafeWrite pointYs 0 (-15)+    MUV.unsafeWrite pointXs 1 (-20)+    MUV.unsafeWrite pointYs 1 0+    MUV.unsafeWrite pointXs 2 (-20)+    MUV.unsafeWrite pointYs 2 7+    table <- newMutablePointIndex 3+    seeded <- seedMutablePointIndex table 3 (MUV.unsafeRead pointXs) (MUV.unsafeRead pointYs)+    case seeded of+      Left failure -> pure (Left failure)+      Right () -> do+        -- The tail has moved into slot one before identity transport begins.+        MUV.unsafeWrite pointXs 1 (-20)+        MUV.unsafeWrite pointYs 1 7+        removed <-+          removeMutablePoint table (MUV.unsafeRead pointXs) (MUV.unsafeRead pointYs) (-20) 0 1+        first <-+          lookupMutablePoint table (MUV.unsafeRead pointXs) (MUV.unsafeRead pointYs) (-20) (-15)+        movedBeforeRelocation <-+          lookupMutablePoint table (MUV.unsafeRead pointXs) (MUV.unsafeRead pointYs) (-20) 7+        relocated <- relocateMutablePoint table (-20) 7 2 1+        movedAfterRelocation <-+          lookupMutablePoint table (MUV.unsafeRead pointXs) (MUV.unsafeRead pointYs) (-20) 7+        pure+          ( Right+              ( removed+              , first+              , movedBeforeRelocation+              , relocated+              , movedAfterRelocation+              )+          )++-- A dense table must also close lawfully when it removes every vertex. The+-- point-keyed query after freeze forces the empty published derivation rather+-- than retaining an impossible ST table.+testBatchIdentityIndexBatchToEmpty :: IO ()+testBatchIdentityIndexBatchToEmpty = do+  let points = V.fromList (randomPoints 0x7a110bad 32)+  built <- requireRight "batch identity empty base" (delaunay unitElementDefaults points)+  (outcomes, emptied, _) <-+    requireRight "batch identity removes every point" $+      withSession (buildTriangulation built) 0 (removeManyAt points)+  unless (V.all isJust outcomes) $+    fail "batch identity table missed a point while removing to empty"+  assertEqual "batch identity empty vertex count" 0 (numVertices emptied)+  assertValid "batch identity empty result" emptied+  absent <- requireRight "empty published identity lookup" (locateAndRemove emptied (Point 0 0))+  case absent of+    Nothing -> pure ()+    Just _ -> fail "empty published identity lookup manufactured a removal"++-- A dense batch discards its ST table before the next singleton handle rewrite.+-- 'excise' must therefore activate and transport the ordinary persistent index+-- without consulting the expired batch representation.+testBatchIdentityIndexToSingletonActive :: IO ()+testBatchIdentityIndexToSingletonActive = do+  let original = V.fromList (randomPoints 0x51a91e 64)+      doomed = V.take 32 original+      survivors = V.drop 32 original+  built <- requireRight "batch-to-singleton identity base" (delaunay unitElementDefaults original)+  (singletonOutcome, transitioned, _) <-+    requireRight "batch-to-singleton identity session" $+      withSession (buildTriangulation built) 0 $ do+        _ <- removeManyAt doomed+        excise (VertexId 0)+  let singletonPoint = removalOutcomePoint singletonOutcome+      expected = V.filter (/= singletonPoint) survivors+  fresh <- requireRight "batch-to-singleton fresh rebuild" (delaunay unitElementDefaults expected)+  assertEqual+    "batch-to-singleton identity topology"+    (canonicalEdges (buildTriangulation fresh))+    (canonicalEdges transitioned)+  assertValid "batch-to-singleton identity result" transitioned+  case V.find (/= singletonPoint) survivors of+    Nothing -> fail "batch-to-singleton fixture exhausted every survivor"+    Just remaining -> do+      located <- requireRight "batch-to-singleton published lookup" (locateAndRemove transitioned remaining)+      case located of+        Nothing -> fail "batch-to-singleton published lookup missed a survivor"+        Just removal -> assertValid "batch-to-singleton published removal" (removalTriangulation removal)++-- The mutable identity table is an internal section of @removeManyAt@, never a+-- session-wide owner. An insertion after the dense batch invalidates it, the+-- subsequent removal walks correctly, and the frozen mesh must rederive the+-- published identity cache from its final coordinate authority.+testBulkIdentityIndexDoesNotEscapeRemovalBatch :: IO ()+testBulkIdentityIndexDoesNotEscapeRemovalBatch = do+  let original = V.fromList (randomPoints 0x5a11ce 400)+      doomed = V.take 120 original+      survivors = V.drop 120 original+      arrival = Point (-0.25) 0.75+  baseBuild <- requireRight "bulk identity section base" (delaunay unitElementDefaults original)+  (_, edited, _) <-+    requireRight "bulk identity section mixed session" $+      withSession (buildTriangulation baseBuild) 1 $ do+        _ <- removeManyAt doomed+        _ <- insertVertexAt arrival arrival+        removeAt arrival >>= maybe (refuse (RemovalVertexOutOfRange (VertexId 0) 0)) (const (pure ()))+  fresh <- requireRight "bulk identity section fresh survivor rebuild" (delaunay unitElementDefaults survivors)+  assertEqual+    "bulk identity section mixed program equals fresh survivors"+    (canonicalEdges (buildTriangulation fresh))+    (canonicalEdges edited)+  assertValid "bulk identity section mixed session" edited+  case V.uncons survivors of+    Nothing -> fail "bulk identity section test has no survivor"+    Just (survivor, _) -> do+      located <- requireRight "published lazy identity lookup" (locateAndRemove edited survivor)+      case located of+        Nothing -> fail "published lazy identity lookup missed survivor"+        Just removal -> assertValid "published lazy identity removal" (removalTriangulation removal)++-- The hierarchy-hinted removal program must land exactly where the unhinted+-- session lands. The guesses are all computed against the original base, so+-- later removals in the batch answer for guesses whose slots swap-compaction+-- has renamed — the walk must correct every one of them. The repaired+-- hierarchy must equal the reference rebuild over the same survivor.+testHierarchyRemovalAgreement :: IO ()+testHierarchyRemovalAgreement = do+  let original = V.fromList (randomPoints 0x5eed1e55 400)+      base = buildTriangulation (either (error . show) id (delaunay unitElementDefaults original))+  hierarchy <- requireRight "hierarchy build" (buildHierarchyHint defaultHierarchyBranchFactor base)+  let run label doomed = do+        (outcomes, survived, repaired) <-+          requireRight (label <> " hinted removal") (removeManyWithHierarchy hierarchy base doomed)+        V.imapM_+          ( \index outcome ->+              maybe (fail (label <> " hinted removal missed index " <> show index)) (const (pure ())) outcome+          )+          outcomes+        (_, folded, _) <-+          requireRight (label <> " unhinted session") (withSession base 0 (removeManyAt doomed))+        reference <- requireRight (label <> " reference rebuild") (rebuildHierarchyHint hierarchy folded)+        assertEqual+          (label <> " hinted removal equals unhinted session")+          (canonicalEdges folded)+          (canonicalEdges survived)+        assertEqual (label <> " repaired hierarchy equals reference rebuild") reference repaired+        assertValid (label <> " hinted removal") survived+  run "sparse" (V.take 40 original)+  run "dense" (V.take 120 original)++testCircleSweepBulkLoad :: IO ()+testCircleSweepBulkLoad = do+  let points = V.fromList (randomPoints 0xc1ac1e 1500)+  swept <- requireRight "circle-sweep build" (delaunay unitElementDefaults points)+  (_, sessioned, _) <-+    requireRight "session build" $+      withSession (empty unitElementDefaults) (V.length points) $+        V.mapM_ insertVertex points+  assertEqual+    "circle-sweep/session topology"+    (canonicalEdges sessioned)+    (canonicalEdges (buildTriangulation swept))+  assertValid "circle-sweep build" (buildTriangulation swept)+  assertValid "session build" sessioned++testPredicates :: IO ()+testPredicates = do+  let a, b, c :: Point+      a = Point 0 0+      b = Point 1 0+      c = Point 0 1+  assertEqual "orientation left" GT (orient2d a b c)+  assertEqual "orientation right" LT (orient2d b a c)+  assertEqual "orientation collinear" EQ (orient2d a b (Point 0.5 0))+  assertEqual "incircle inside" GT (inCircle a b c (Point 0.25 0.25))+  assertEqual "incircle boundary" EQ (inCircle a b c (Point 1 1))+  assertEqual "incircle outside" LT (inCircle a b c (Point 2 2))+  assertEqual "underflow mitigation" (Point 0 1) (mitigateUnderflow (Point 1.0e-44 1 :: Point))+  _ <- requireRight "point validation" (validatePoint Nothing (Point 0 1 :: Point))+  let large = encodeFloat 1 180 :: Double+      ulp = encodeFloat 1 128 :: Double+  assertEqual+    "large exact orientation"+    GT+    (orient2d (Point large large) (Point (large + ulp) large) (Point large (large + ulp)))+  assertEqual+    "large exact cocircularity"+    EQ+    (inCircle+      (Point large large)+      (Point (large + ulp) large)+      (Point large (large + ulp))+      (Point (large + ulp) (large + ulp)))++testHandlesAndFiniteDcel :: IO ()+testHandlesAndFiniteDcel = do+  built <- requirePointBuild "handle algebra" [Point 0 0, Point 3 0, Point 0 2, Point 0.4 0.7]+  let triangulation = buildTriangulation built+  assertValid "handle algebra" triangulation+  assertEqual "one outer face" (numInnerFaces triangulation + 1) (numFaces triangulation)+  forM_ (directedEdges triangulation) $ \edge -> do+    assertEqual "double reversal" edge (reverseEdge (reverseEdge edge))+    assertEqual "next/previous" edge (previous triangulation (next triangulation edge))+    assertEqual "previous/next" edge (next triangulation (previous triangulation edge))+  forM_ (undirectedEdges triangulation) $ \edge -> do+    let (forward, backward) = directedPair edge+    assertEqual "pair reversal" backward (reverseEdge forward)+    assertEqual "undirected projection" edge (asUndirected forward)+  assertEqual "vertex iterator" (numVertices triangulation) (length (vertices triangulation))+  assertEqual+    "dense vertex projection"+    (V.fromList (fmap (vertexPoint triangulation) (vertices triangulation)))+    (vertexPoints triangulation)+  assertEqual "edge iterator" (numUndirectedEdges triangulation) (length (undirectedEdges triangulation))+  assertEqual "face iterator" (numInnerFaces triangulation) (length (innerFaces triangulation))+  assertEqual+    "dense inner-face projection"+    (Just (V.toList (innerFaceVertexTriples triangulation)))+    (traverse (Dcel.innerFaceVertices triangulation) (innerFaces triangulation))+  assertEqual "dynamic vertex iterator" (numVertices triangulation) (length (DynamicIterators.vertexHandles triangulation))+  assertEqual "dynamic edge iterator" (numDirectedEdges triangulation) (length (DynamicIterators.directedEdgeHandles triangulation))+  assertEqual "dynamic face iterator" (numInnerFaces triangulation) (length (DynamicIterators.innerFaceHandles triangulation))+  unless (geometryTopologyBytes triangulation > topologyIndexBytes triangulation) $+    fail "geometry byte accounting omitted coordinates"+  vertex0 <- requireJust "dynamic vertex handle" (Dynamic.vertexHandle triangulation (VertexId 0))+  assertEqual "dynamic vertex fix" (VertexId 0) (Dynamic.fixVertex vertex0)+  assertEqual "dynamic vertex position" (vertexPoint triangulation (VertexId 0)) (Dynamic.vertexHandlePosition vertex0)+  case Dynamic.vertexHandleOutEdge vertex0 of+    Nothing -> fail "connected dynamic vertex has no outgoing edge"+    Just edge -> do+      assertEqual "dynamic edge reversal" (Dynamic.fixDirectedEdge edge) (Dynamic.fixDirectedEdge (Dynamic.directedEdgeReverse (Dynamic.directedEdgeReverse edge)))+      assertEqual "dynamic edge next/previous" (Dynamic.fixDirectedEdge edge) (Dynamic.fixDirectedEdge (Dynamic.directedEdgePrevious (Dynamic.directedEdgeNext edge)))+      let face = Dynamic.directedEdgeFace edge+      if Dynamic.faceIsOuter face+        then pure ()+        else case Dynamic.faceAsInner face of+          Nothing -> fail "non-outer dynamic face did not refine to InnerTag"+          Just inner -> do+            _ <- requireJust "inner dynamic face vertices" (Dynamic.innerFaceVertices inner)+            case Dynamic.innerFaceCircumcenter inner of+              Nothing -> fail "inner dynamic face has no circumcenter"+              Just _ -> pure ()++testDegenerateConstruction :: IO ()+testDegenerateConstruction = do+  emptyBuild <- requirePointBuild "empty" []+  emptyQuery <- requireQueryPoint "empty location" (Point 0 0)+  assertEqual "empty vertices" 0 (numVertices (buildTriangulation emptyBuild))+  assertEqual "empty location" EmptyTriangulation (locatePoint (buildTriangulation emptyBuild) emptyQuery)+  assertValid "empty" (buildTriangulation emptyBuild)++  singleton <- requirePointBuild "singleton" [Point 2 3]+  singletonQuery <- requireQueryPoint "singleton lookup" (Point 2 3)+  assertEqual "singleton lookup" (OnVertex (VertexId 0)) (locatePoint (buildTriangulation singleton) singletonQuery)+  assertValid "singleton" (buildTriangulation singleton)++  duplicates <- requirePointBuild "duplicates" [Point 0 0, Point 1 0, Point (-0.0) 0, Point 1 0, Point 2 0]+  assertEqual "deduplicated count" 3 (numVertices (buildTriangulation duplicates))+  assertEqual+    "stable duplicate mapping"+    (primArrayFromList [0, 1, 0, 1, 2])+    (buildInputVertices duplicates)+  assertValid "duplicates" (buildTriangulation duplicates)++  -- Deduplicating a signed zero is not the same claim as storing it canonically:+  -- the first only needs '==', which already identifies the two, while anything+  -- reading the bit pattern — a radix ordering, a byte-for-byte cross-check —+  -- reads the sign bit and gets a coordinate below every other. Both ingest+  -- paths canonicalize, and both are held to it here rather than to the weaker+  -- statement that comparison happens to survive.+  let bits point = (castDoubleToWord64 (pointX point), castDoubleToWord64 (pointY point))+  signedZero <- requirePointBuild "signed zero" [Point (-0.0) (-0.0), Point 1 0, Point 0 1]+  assertEqual "bulk load stores a canonical zero"+    (0, 0) (bits (vertexPoint (buildTriangulation signedZero) (VertexId 0)))+  incremental <-+    requireRight "signed zero insert"+      (insert (empty unitElementDefaults :: DelaunayTriangulation (Point)) (Point (-0.0) (-0.0)))+  assertEqual "insertion stores a canonical zero"+    (0, 0) (bits (vertexPoint (insertionTriangulation incremental) (VertexId 0)))++  collinear <- requirePointBuild "collinear" [Point 0 4, Point 0 0, Point 0 3, Point 0 2, Point 0 1]+  let line = buildTriangulation collinear+  assertEqual "line edge count" 4 (numUndirectedEdges line)+  assertEqual "line face count" 0 (numInnerFaces line)+  assertValid "collinear terminal splits" line++testPersistentLocalUpdates :: IO ()+testPersistentLocalUpdates = do+  base <- requirePointBuild "persistent base" (randomPoints 0x5eed 4095)+  let triangulation = buildTriangulation base+      query = Point 0.000_123 (-0.000_271)+  inserted <- requireRight "persistent insert" (insert triangulation query)+  assertEqual "persistent source remains unchanged" 4095 (numVertices triangulation)+  assertEqual "persistent result appends one vertex" 4096 (numVertices (insertionTriangulation inserted))+  assertValid "persistent insertion result" (insertionTriangulation inserted)++  let payloads = V.fromList+        [ SampleVertex (Point 0 0) 10+        , SampleVertex (Point 1 0) 20+        , SampleVertex (Point 0 1) 30+        ]+      defaults = ElementDefaults (0 :: Int) False ("face" :: String)+  payloadBuild <- requireRight "payload base" (delaunay defaults payloads)+  duplicate <- requireRight "payload-only replacement" (insert (buildTriangulation payloadBuild) (SampleVertex (Point 1 0) 99))+  assertEqual "payload update disposition" AlreadyPresent (insertionDisposition duplicate)+  assertEqual "payload replacement" 99 (sampleLabel (vertexData (insertionTriangulation duplicate) (VertexId 1)))++testGenericPayloads :: IO ()+testGenericPayloads = do+  let defaults = ElementDefaults (7 :: Int) False ("new-face" :: String)+      payloads = V.fromList+        [ SampleVertex (Point 0 0) 1+        , SampleVertex (Point 2 0) 2+        , SampleVertex (Point 0 2) 3+        , SampleVertex (Point 0.5 0.5) 4+        ]+  built <- requireRight "generic payload build" (delaunay defaults payloads)+  let triangulation = buildTriangulation built+  assertValid "generic payload build" triangulation+  assertEqual "vertex payload" 4 (sampleLabel (vertexData triangulation (VertexId 3)))+  forM_ (directedEdges triangulation) $ \edge -> assertEqual "directed default" 7 (directedEdgeData triangulation edge)+  forM_ (undirectedEdges triangulation) $ \edge -> assertEqual "undirected default" False (undirectedEdgeData triangulation edge)+  forM_ (allFaces triangulation) $ \face -> assertEqual "face default" "new-face" (faceData triangulation face)+  (firstEdge, firstFace) <- case (directedEdges triangulation, innerFaces triangulation) of+    (edge : _, face : _) -> pure (edge, face)+    _ -> fail "generic payload build produced no inner topology"+  let firstUndirected = asUndirected firstEdge+      changed = setFaceData (setUndirectedEdgeData (setDirectedEdgeData triangulation firstEdge 42) firstUndirected True) firstFace "changed"+  assertEqual "directed payload update" 42 (directedEdgeData changed firstEdge)+  assertEqual "undirected payload update" True (undirectedEdgeData changed firstUndirected)+  assertEqual "face payload update" "changed" (faceData changed firstFace)+  -- Geometry owns the points, so a payload carrying a different position is not+  -- a contradiction to be refused — it is a payload whose position nobody reads.+  let moved = setVertexData triangulation (VertexId 0) (SampleVertex (Point 9 9) 0)+  assertEqual "a payload position does not site a vertex"+    (vertexPoint triangulation (VertexId 0)) (vertexPoint moved (VertexId 0))+  assertEqual "the payload is stored as given"+    (Point 9 9) (samplePosition (vertexData moved (VertexId 0)))++-- The payload layer over a fixed geometry is a product of four free components.+-- Each is a functor and each is checked as such; nothing in the product can+-- disturb the geometry underneath it.+testPayloadMaps :: IO ()+testPayloadMaps = do+  let defaults = ElementDefaults (7 :: Int) ("new-undirected" :: String) ("new-face" :: String)+      payloads = V.fromList+        [ SampleVertex (Point 0 0) 1+        , SampleVertex (Point 4 0) 2+        , SampleVertex (Point 4 4) 3+        , SampleVertex (Point 0 4) 4+        , SampleVertex (Point 1 2) 5+        ]+  built <- requireRight "payload map build" (delaunay defaults payloads)+  let plain = buildTriangulation built+      -- Distinct payloads everywhere: a map that permuted its component would+      -- be invisible against uniform defaults.+      withDirected = foldl' (\t (label, edge) -> setDirectedEdgeData t edge label) plain (zip [100 ..] (directedEdges plain))+      withUndirected = foldl' (\t (label, edge) -> setUndirectedEdgeData t edge ("u-" <> show label)) withDirected (zip [(0 :: Int) ..] (undirectedEdges withDirected))+      sample = foldl' (\t (label, face) -> setFaceData t face ("f-" <> show label)) withUndirected (zip [(0 :: Int) ..] (allFaces withUndirected))+      endpoints ::+        Triangulation mode vertex directed undirected face ->+        [(VertexId, VertexId)]+      endpoints t = [(origin t edge, destination t edge) | edge <- directedEdges t]++  -- Identity. Equality on a triangulation compares geometry, topology,+  -- constraint flags and element defaults as well as payloads, so this single+  -- equation states that each map disturbs nothing but the component it names.+  assertEqual "mapDirectedEdges identity" sample (mapDirectedEdges id sample)+  assertEqual "mapUndirectedEdges identity" sample (mapUndirectedEdges id sample)+  assertEqual "mapFaces identity" sample (mapFaces id sample)+  assertEqual "mapVertices identity" sample (mapVertices id sample)++  assertEqual "mapDirectedEdges composition"+    (mapDirectedEdges ((* 2) . (+ 1)) sample)+    (mapDirectedEdges (* 2) (mapDirectedEdges (+ 1) sample))+  assertEqual "mapFaces composition"+    (mapFaces (("<" <>) . (<> ">")) sample)+    (mapFaces ("<" <>) (mapFaces (<> ">") sample))++  -- Commutation with the accessors. Identity and composition are blind to the+  -- indexing; this is the law that pins each payload to its own handle.+  let directedMapped = mapDirectedEdges (+ 1) sample+      undirectedMapped = mapUndirectedEdges ("<" <>) sample+      facesMapped = mapFaces ("<" <>) sample+  forM_ (directedEdges sample) $ \edge ->+    assertEqual "mapDirectedEdges commutes with directedEdgeData"+      (directedEdgeData sample edge + 1) (directedEdgeData directedMapped edge)+  forM_ (undirectedEdges sample) $ \edge ->+    assertEqual "mapUndirectedEdges commutes with undirectedEdgeData"+      ("<" <> undirectedEdgeData sample edge) (undirectedEdgeData undirectedMapped edge)+  forM_ (allFaces sample) $ \face ->+    assertEqual "mapFaces commutes with faceData"+      ("<" <> faceData sample face) (faceData facesMapped face)++  -- The components are independent, and none of them is geometry.+  assertEqual "face and directed maps commute"+    (mapFaces ("<" <>) (mapDirectedEdges (+ 1) sample))+    (mapDirectedEdges (+ 1) (mapFaces ("<" <>) sample))+  assertEqual "mapFaces preserves topology" (endpoints sample) (endpoints facesMapped)+  assertEqual "mapFaces preserves the face count" (numFaces sample) (numFaces facesMapped)+  forM_ (vertices sample) $ \vertex ->+    assertEqual "mapFaces preserves geometry" (vertexPoint sample vertex) (vertexPoint facesMapped vertex)++  -- The element default is a payload and must travel with them: every element a+  -- later insertion creates is handed the default, so a map that reindexed the+  -- stored payloads and left the default behind would produce a triangulation+  -- whose future elements disagree with its present ones. Every stored payload+  -- here differs from the default, so carrying the wrong one is visible.+  grownFaces <- insertionTriangulation <$> requireRight "insertion into mapped faces" (insert facesMapped (SampleVertex (Point 2 1) 6))+  grownUndirected <- insertionTriangulation <$> requireRight "insertion into mapped undirected edges" (insert undirectedMapped (SampleVertex (Point 2 1) 6))+  grownDirected <- insertionTriangulation <$> requireRight "insertion into mapped directed edges" (insert directedMapped (SampleVertex (Point 2 1) 6))+  unless (numFaces grownFaces > numFaces facesMapped) $ fail "the insertion created no face"+  unless ("<new-face" `elem` map (faceData grownFaces) (allFaces grownFaces)) $+    fail ("new faces did not receive the mapped default: " <> show (map (faceData grownFaces) (allFaces grownFaces)))+  unless ("<new-undirected" `elem` map (undirectedEdgeData grownUndirected) (undirectedEdges grownUndirected)) $+    fail "new undirected edges did not receive the mapped default"+  unless (8 `elem` map (directedEdgeData grownDirected) (directedEdges grownDirected)) $+    fail "new directed edges did not receive the mapped default"++  -- Vertices, the component that used to be special. The map is total, and the+  -- one thing worth insisting on is that a function which does its worst to the+  -- stored position still cannot move a vertex.+  let relabelled = mapVertices (\v -> v{sampleLabel = sampleLabel v * 10}) sample+      collapsed = mapVertices (\v -> v{samplePosition = Point 9 9}) sample+  forM_ (vertices sample) $ \vertex -> do+    assertEqual "mapVertices commutes with vertexData"+      (sampleLabel (vertexData sample vertex) * 10) (sampleLabel (vertexData relabelled vertex))+    assertEqual "mapVertices preserves geometry" (vertexPoint sample vertex) (vertexPoint relabelled vertex)+    assertEqual "a payload map cannot move a vertex"+      (vertexPoint sample vertex) (vertexPoint collapsed vertex)+  assertEqual "mapVertices composes"+    (mapVertices (\v -> v{sampleLabel = sampleLabel v + 1}) relabelled)+    (mapVertices (\v -> v{sampleLabel = sampleLabel v * 10 + 1}) sample)++  -- The sharpest statement of freedom available: the image type has no+  -- 'HasPosition' instance at all. This does not typecheck under a vertex+  -- component that geometry reads through.+  let projected = mapVertices sampleLabel sample+  forM_ (vertices sample) $ \vertex -> do+    assertEqual "a vertex payload need not have a position"+      (sampleLabel (vertexData sample vertex)) (vertexData projected vertex)+    assertEqual "projecting payloads away preserves geometry"+      (vertexPoint sample vertex) (vertexPoint projected vertex)++testPayloadTraversals :: IO ()+testPayloadTraversals = do+  let defaults = ElementDefaults (7 :: Int) ("new-undirected" :: String) ("new-face" :: String)+      payloads = V.fromList+        [ SampleVertex (Point 0 0) 1+        , SampleVertex (Point 4 0) 2+        , SampleVertex (Point 4 4) 3+        , SampleVertex (Point 0 4) 4+        , SampleVertex (Point 1 2) 5+        ]+  built <- requireRight "payload traversal build" (delaunay defaults payloads)+  let plain = buildTriangulation built+      withDirected = foldl' (\t (label, edge) -> setDirectedEdgeData t edge label) plain (zip [100 ..] (directedEdges plain))+      withUndirected = foldl' (\t (label, edge) -> setUndirectedEdgeData t edge ("u-" <> show label)) withDirected (zip [(0 :: Int) ..] (undirectedEdges withDirected))+      sample = foldl' (\t (label, face) -> setFaceData t face ("f-" <> show label)) withUndirected (zip [(0 :: Int) ..] (allFaces withUndirected))++  -- 'overPayloads' is the traversal under 'Identity', so this is the traversal+  -- identity law. It also says that rebuilding a payload store from its own+  -- contents is not observable, which is the part a paged store could get+  -- wrong: the traversal materializes pages the map would have left absent.+  assertEqual "vertexPayloads identity" sample (overPayloads vertexPayloads id sample)+  assertEqual "directedPayloads identity" sample (overPayloads directedPayloads id sample)+  assertEqual "undirectedPayloads identity" sample (overPayloads undirectedPayloads id sample)+  assertEqual "facePayloads identity" sample (overPayloads facePayloads id sample)++  -- Each traversal and its named map are one function. The effectful+  -- generalization is not allowed a second opinion about what relabeling means.+  assertEqual "vertexPayloads agrees with mapVertices"+    (mapVertices sampleLabel sample) (overPayloads vertexPayloads sampleLabel sample)+  assertEqual "directedPayloads agrees with mapDirectedEdges"+    (mapDirectedEdges (* 2) sample) (overPayloads directedPayloads (* 2) sample)+  assertEqual "undirectedPayloads agrees with mapUndirectedEdges"+    (mapUndirectedEdges ("<" <>) sample) (overPayloads undirectedPayloads ("<" <>) sample)+  assertEqual "facePayloads agrees with mapFaces"+    (mapFaces ("<" <>) sample) (overPayloads facePayloads ("<" <>) sample)++  assertEqual "facePayloads composes"+    (overPayloads facePayloads (("<" <>) . (<> ">")) sample)+    (overPayloads facePayloads ("<" <>) (overPayloads facePayloads (<> ">") sample))++  -- The class instances range over the face payload, being the last parameter.+  assertEqual "fmap is the face payload map" (mapFaces ("<" <>) sample) (fmap ("<" <>) sample)+  assertEqual "traverse is facePayloads"+    (Just (overPayloads facePayloads ("<" <>) sample))+    (traverse (Just . ("<" <>)) sample)+  assertEqual "the Foldable instance is the face traversal"+    (payloadList facePayloads sample) (foldr (:) [] sample)++  -- Visit order, and the element default's place in it. A fold that skipped+  -- the default would report the triangulation as holding one fewer face+  -- payload than it holds.+  assertEqual "vertexPayloads visits the vertices in order"+    (map (vertexData sample) (vertices sample))+    (payloadList vertexPayloads sample)+  assertEqual "facePayloads visits the faces and then the default"+    (map (faceData sample) (allFaces sample) <> [defaultFaceData (Internal.triElementDefaults sample)])+    (payloadList facePayloads sample)++  -- The point of the exercise: relabeling under an effect, with a refusal+  -- reaching the caller instead of a half-relabelled triangulation.+  let refuseAtThree :: SampleVertex -> Either String Int+      refuseAtThree v = if sampleLabel v == 3 then Left "vertex three refuses" else Right (sampleLabel v * 10)+      keepLabel :: SampleVertex -> Either String Int+      keepLabel = Right . sampleLabel+      decorate :: String -> Either String String+      decorate = Right . ("<" <>)+  assertEqual "an effectful relabel short-circuits"+    (Left "vertex three refuses") (vertexPayloads refuseAtThree sample)+  relabelled <- requireRight "effectful relabel" (vertexPayloads keepLabel sample)+  assertEqual "a successful effectful relabel is the pure one"+    (mapVertices sampleLabel sample) relabelled++  -- The default travels through the traversal, and travels exactly once: the+  -- store's fill and the element defaults are written from a single visit, so+  -- an element created afterwards inherits precisely what the traversal made.+  traversedFaces <- requireRight "effectful face relabel" (facePayloads decorate sample)+  grown <- insertionTriangulation <$> requireRight "insertion after traversal" (insert traversedFaces (SampleVertex (Point 2 1) 6))+  unless (numFaces grown > numFaces traversedFaces) $ fail "the insertion created no face"+  unless ("<new-face" `elem` map (faceData grown) (allFaces grown)) $+    fail ("new faces did not receive the traversed default: " <> show (map (faceData grown) (allFaces grown)))++-- | The in-circle predicate is the orientation of the four points lifted to+-- the paraboloid @z = x² + y²@. The referent is that 4×4 determinant evaluated+-- exactly over 'Rational' — deliberately not the translated 3×3 the instances+-- expand, which would only be the implementation checking its own algebra.+testParaboloidLift :: IO ()+testParaboloidLift = do+  let lifted :: Point -> (Rational, Rational, Rational)+      lifted (Point x y) =+        let (rx, ry) = (toRational x, toRational y) in (rx, ry, rx * rx + ry * ry)+      minor3+        :: (Rational, Rational, Rational)+        -> (Rational, Rational, Rational)+        -> (Rational, Rational, Rational)+        -> Rational+      minor3 (a1, a2, a3) (b1, b2, b3) (c1, c2, c3) =+        a1 * (b2 * c3 - b3 * c2) - a2 * (b1 * c3 - b3 * c1) + a3 * (b1 * c2 - b2 * c1)+      -- Laplace expansion of the lifted determinant along its column of ones.+      liftedOrientation+        :: (Rational, Rational, Rational)+        -> (Rational, Rational, Rational)+        -> (Rational, Rational, Rational)+        -> (Rational, Rational, Rational)+        -> Rational+      liftedOrientation a b c d =+        negate (minor3 b c d) + minor3 a c d - minor3 a b d + minor3 a b c+      predicted :: Point -> Point -> Point -> Point -> Ordering+      predicted a b c d = compare (liftedOrientation (lifted a) (lifted b) (lifted c) (lifted d)) 0+      measured :: Point -> Point -> Point -> Point -> Ordering+      measured (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy) =+        inCircleCoordinates ax ay bx by cx cy dx dy+      quadruples :: [Point] -> [(Point, Point, Point, Point)]+      quadruples (a : b : c : d : rest) = (a, b, c, d) : quadruples rest+      quadruples _ = []++  forM_ (quadruples (randomPoints 0x51ca_0b17 1600)) $ \(a, b, c, d) ->+    assertEqual ("in-circle is the lifted orientation at " <> show (a, b, c, d))+      (predicted a b c d) (measured a b c d)++  -- Exactly cocircular quadruples, which are exactly the ones the floating+  -- filter must decline to answer. Every Pythagorean point of the radius-5+  -- circle is representable without rounding, so 'EQ' here is a fact about the+  -- geometry rather than about the arithmetic.+  let ring =+        [ Point x y+        | (x, y) <-+            [ (5, 0), (0, 5), (-5, 0), (0, -5)+            , (3, 4), (4, 3), (-3, 4), (-4, 3)+            , (3, -4), (4, -3), (-3, -4), (-4, -3)+            ]+        ] :: [Point]+      indexed = zip [(0 :: Int) ..] ring+      cocircular =+        [ (a, b, c, d)+        | (i, a) <- indexed, (j, b) <- indexed, j > i+        , (k, c) <- indexed, k > j, (l, d) <- indexed, l > k+        ]+  unless (length cocircular == 495) $ fail ("expected 495 cocircular quadruples, got " <> show (length cocircular))+  forM_ cocircular $ \(a, b, c, d) -> do+    assertEqual ("cocircular points are cocircular at " <> show (a, b, c, d)) EQ (measured a b c d)+    assertEqual ("the lift agrees on cocircularity at " <> show (a, b, c, d)) EQ (predicted a b c d)++  -- The geometry the sign means, stated once against a circle anyone can read.+  let (a, b, c) = (Point 1 0, Point 0 1, Point (-1) 0) :: (Point, Point, Point)+  assertEqual "the centre is inside the circle" GT (measured a b c (Point 0 0))+  assertEqual "the antipode is on the circle" EQ (measured a b c (Point 0 (-1)))+  assertEqual "a distant point is outside" LT (measured a b c (Point 2 2))++-- | A payload labels an element, and an element is its geometry. Every rewrite+-- an insertion performs — an edge split, a face split, a Lawson flip — hands+-- some slot a different element to hold, and the label the displaced one+-- carried does not describe what took its place.+--+-- So: label every element of a triangulation by its own key, insert a point,+-- and demand that an element whose key survives still carries exactly the label+-- it was given while every element whose key is new carries the default and+-- nothing else. Both directions are checked; either alone is satisfiable by a+-- store that throws everything away.+--+-- The flip is the load-bearing case. Legalization is confluent, so which flips+-- fire and in what order is not observable in the topology that comes out. A+-- payload that rode through a flip would make it observable in the payload+-- plane, and a triangulation that is a normal form in one component and a+-- history in another is not a normal form.+testRewritePayloadIdentity :: IO ()+testRewritePayloadIdentity = do+  let defaults = ElementDefaults (0 :: Int) (0 :: Int) (0 :: Int)+      target = Point 0.001_37 (-0.002_11)+      corpus = randomPoints 0x1a2b3c4d 512+  built <- requireRight "rewrite identity base" (delaunay defaults (V.fromList corpus))+  let base = buildTriangulation built+      directedTable = labelTable (map (directedKeyOf base) (directedEdges base))+      undirectedTable = labelTable (map (undirectedKeyOf base) (undirectedEdges base))+      faceTable = labelTable (map (faceKeyOf base) (innerFaces base))++  -- Keys identify elements only if they are unique, so the premise is checked+  -- rather than assumed: a collapsed table would silently weaken everything+  -- below it into a test of nothing.+  assertEqual "directed keys are unique" (length (directedEdges base)) (Map.size directedTable)+  assertEqual "undirected keys are unique" (length (undirectedEdges base)) (Map.size undirectedTable)+  assertEqual "face keys are unique" (length (innerFaces base)) (Map.size faceTable)++  let withDirected =+        foldl' (\t e -> setDirectedEdgeData t e (directedTable Map.! directedKeyOf base e)) base (directedEdges base)+      withUndirected =+        foldl' (\t e -> setUndirectedEdgeData t e (undirectedTable Map.! undirectedKeyOf base e)) withDirected (undirectedEdges base)+      labelled =+        foldl' (\t f -> setFaceData t f (faceTable Map.! faceKeyOf base f)) withUndirected (innerFaces base)+  inserted <- requireRight "rewrite identity insert" (insert labelled target)+  let result = insertionTriangulation inserted+  assertValid "rewrite identity result" result+  assertEqual "the point was genuinely inserted" Inserted (insertionDisposition inserted)++  -- Both directions, on every plane. A surviving element keeps exactly its+  -- label; everything else holds the default and nothing else.+  assertPayloadSurvival "directed" directedTable+    [(directedKeyOf result e, directedEdgeData result e) | e <- directedEdges result]+  assertPayloadSurvival "undirected" undirectedTable+    [(undirectedKeyOf result e, undirectedEdgeData result e) | e <- undirectedEdges result]+  assertPayloadSurvival "face" faceTable+    [(faceKeyOf result f, faceData result f) | f <- innerFaces result]++  -- The flip signature. Every flip after an insertion joins the new vertex to+  -- the far corner of a cavity quad, so a new edge is not evidence of one — a+  -- split produces those too. A DESTROYED edge is: splitting a face destroys+  -- nothing and adds exactly three edges and two faces, which is asserted here+  -- so that the arithmetic holds, and under it every base key that is gone from+  -- the result was flipped away. Without this the paragraphs above are a claim+  -- about splits alone.+  assertEqual "the point landed strictly inside a face"+    (numUndirectedEdges base + 3, numFaces base + 2)+    (numUndirectedEdges result, numFaces result)+  let surviving = Set.fromList (map (undirectedKeyOf result) (undirectedEdges result))+      flippedAway = filter (`Set.notMember` surviving) (Map.keys undirectedTable)+  when (null flippedAway) (fail "the insertion caused no flip, so the flip case went unchecked")++  -- The same claim across one transaction that both retires and creates.+  -- Removal swap-compacts, which leaves a retired element's payload sitting in+  -- the slot it vacated; the inserts that follow are handed those slots back.+  -- Nothing else in the suite makes an allocation reissue a used slot.+  let doomed = take 60 corpus+      arrivals = randomPoints 0x5f3a19c2 60+  (_, edited, _) <-+    requireRight "rewrite identity session" $+      withSession labelled (length arrivals) $ do+        mapM_+          (\point -> removeAt point >>= maybe (refuse (RemovalVertexOutOfRange (VertexId 0) 0)) (const (pure ())))+          doomed+        mapM_ insertVertex arrivals+  assertValid "rewrite identity session" edited+  assertPayloadSurvival "session directed" directedTable+    [(directedKeyOf edited e, directedEdgeData edited e) | e <- directedEdges edited]+  assertPayloadSurvival "session undirected" undirectedTable+    [(undirectedKeyOf edited e, undirectedEdgeData edited e) | e <- undirectedEdges edited]+  assertPayloadSurvival "session face" faceTable+    [(faceKeyOf edited f, faceData edited f) | f <- innerFaces edited]++directedKeyOf+  :: Triangulation mode vertex directed undirected face+  -> DirectedEdgeId+  -> (Point, Point)+directedKeyOf triangulation edge =+  ( vertexPoint triangulation (origin triangulation edge)+  , vertexPoint triangulation (destination triangulation edge)+  )++undirectedKeyOf+  :: Triangulation mode vertex directed undirected face+  -> UndirectedEdgeId+  -> (Point, Point)+undirectedKeyOf triangulation edge =+  case undirectedEndpoints triangulation edge of+    (from, to) ->+      let (left, right) = (vertexPoint triangulation from, vertexPoint triangulation to)+       in if left <= right then (left, right) else (right, left)++faceKeyOf+  :: Triangulation mode vertex directed undirected face+  -> FaceId+  -> [Point]+faceKeyOf triangulation face = sort (map (vertexPoint triangulation) (faceVertices triangulation face))++labelTable :: Ord key => [key] -> Map.Map key Int+labelTable keys = Map.fromList (zip keys [1 ..])++-- | Every element carries the label its key was given, or the default if its+-- key is new. Both counts are asserted too: a store that kept everything and a+-- store that kept nothing each satisfy one half of this on its own.+assertPayloadSurvival :: (Ord key, Show key) => String -> Map.Map key Int -> [(key, Int)] -> IO ()+assertPayloadSurvival plane labels elements = do+  let kept = length (filter ((`Map.member` labels) . fst) elements)+  when (kept == 0) (fail (plane <> ": the insertion perturbed every element"))+  when (kept == length elements) (fail (plane <> ": the insertion perturbed no element"))+  forM_ elements $ \(key, payload) ->+    assertEqual (plane <> " label at " <> show key) (Map.findWithDefault 0 key labels) payload++testPointLocationAndHints :: IO ()+testPointLocationAndHints = do+  built <- requirePointBuild "location" (randomPoints 0x1234_5678 1200)+  let triangulation = buildTriangulation built+  queries <- traverse (requireQueryPoint "location query") (take 250 (randomPoints 0xdead_beef 250))+  let+      baseline = sum [locationWalkSteps stats | query <- queries, let (_, stats) = locatePointWithHint triangulation Nothing query]+  hierarchy <- requireRight "hierarchy build" (buildHierarchyHint 16 triangulation)+  let hinted = sum+        [ locationWalkSteps stats+        | query <- queries+        , let hint = hierarchyHint hierarchy query+              (_, stats) = locatePointWithHint triangulation hint query+        ]+  unless (hinted <= baseline) $+    fail ("hierarchy hint increased aggregate walking: " <> show (baseline, hinted))+  staleHintQuery <- requireQueryPoint "stale hint query" (Point 0.125 (-0.375))+  let staleVertexHint = VertexHint (VertexId (fromIntegral (numVertices triangulation)))+  assertEqual+    "stale vertex hint falls back to the canonical start face"+    (locatePointWithHint triangulation Nothing staleHintQuery)+    (locatePointWithHint triangulation (Just staleVertexHint) staleHintQuery)+  forM_ (vertices triangulation) $ \vertex -> do+    vertexQuery <- requireQueryPoint "vertex lookup" (vertexPoint triangulation vertex)+    assertEqual "vertex lookup" (OnVertex vertex) (locatePoint triangulation vertexQuery)+  let insertedPoint = Point 0.1234567 (-0.2345678)+  inserted <- requireRight "hierarchy incremental source" (insert triangulation insertedPoint)+  let updatedTriangulation = insertionTriangulation inserted+  updatedHierarchy <-+    requireRight+      "hierarchy incremental update"+      ( updateHierarchyAfterInsertion+          hierarchy+          insertedPoint+          (insertionVertex inserted)+          (insertionDisposition inserted)+      )+  rebuiltHierarchy <- requireRight "hierarchy reference rebuild" (buildHierarchyHint 16 updatedTriangulation)+  assertEqual "incremental hierarchy equals canonical rebuild" rebuiltHierarchy updatedHierarchy++-- The hierarchy replaces its level-to-base correspondence with the arithmetic+-- claim that level-local handle @j@ names base vertex @j * branch@. Query each+-- sampled vertex with its own position: the descent must return that very+-- vertex, at every branch factor and along the whole of level 0. A stride the+-- construction does not actually obey shows up here as a named mismatch.+testHierarchyNestingLaw :: IO ()+testHierarchyNestingLaw = do+  built <- requirePointBuild "hierarchy nesting" (randomPoints 0x0f1e_2d3c 900)+  let triangulation = buildTriangulation built+  forM_ [2, 3, 16] $ \branch -> do+    hierarchy <- requireRight ("hierarchy build at branch " <> show branch) (buildHierarchyHint branch triangulation)+    let sampled = [0, branch .. numVertices triangulation - 1]+    forM_ sampled $ \index -> do+      let vertex = VertexId (fromIntegral index)+      vertexQuery <- requireQueryPoint "sampled hierarchy vertex" (vertexPoint triangulation vertex)+      assertEqual+        ("branch " <> show branch <> " descent onto sampled vertex " <> show index)+        (Just (VertexHint vertex))+        (hierarchyHint hierarchy vertexQuery)++testSibsonInterpolation :: IO ()+testSibsonInterpolation = do+  built <- requirePointBuild "sibson" (gridPoints 9 9)+  let triangulation = buildTriangulation built+      queryPoint = Point 3.25 4.4+      linear vertex = let Point x y = vertexPoint triangulation vertex in 2 * x - 3 * y + 5+      expected = let Point x y = queryPoint in 2 * x - 3 * y + 5+  query <- requireQueryPoint "Sibson query" queryPoint+  workspace <- stToIO (newNaturalNeighborWorkspace triangulation)+  result <- stToIO (naturalNeighborWeights workspace Nothing query)+  let weights = naturalNeighborValues result+  unless (V.length weights >= 3) $ fail "Sibson query did not discover a natural-neighbor cavity"+  assertNear "Sibson partition" 1.0e-11 1 (V.sum (V.map snd weights))+  unless (V.all ((>= (-1.0e-12)) . snd) weights) $ fail "Sibson produced a negative weight"+  (folded, _, foldedStats) <- stToIO (foldNaturalNeighborWeights+    (\total vertex weight -> total + weight * linear vertex)+    0+    workspace+    Nothing+    query)+  assertNear "allocation-free Sibson fold" 2.0e-9 expected folded+  assertEqual "Sibson fold neighbor count" (V.length weights) (interpolationNaturalNeighbors foldedStats)+  (interpolated, _) <- stToIO (interpolateNaturalNeighbor linear workspace Nothing query)+  case interpolated of+    Nothing -> fail "Sibson interpolation rejected an interior query"+    Just value -> assertNear "Sibson affine precision" 2.0e-9 expected value+  let gradients = estimateGradients linear triangulation+  V.forM_ gradients $ \(gx, gy) -> do+    assertNear "planar gradient x" 1.0e-9 2 gx+    assertNear "planar gradient y" 1.0e-9 (-3) gy+  let gradient (VertexId raw) = gradients V.! fromIntegral raw+  (gradientValue, _) <- stToIO (interpolateNaturalNeighborGradient linear gradient 0.5 workspace Nothing query)+  case gradientValue of+    Nothing -> fail "gradient natural-neighbor interpolation rejected an interior query"+    Just value -> assertNear "gradient affine precision" 2.0e-9 expected value+  unless (workspaceBytes workspace > 0) $ fail "Sibson workspace byte accounting is empty"++testVoronoiDual :: IO ()+testVoronoiDual = do+  built <- requirePointBuild "voronoi" [Point 0 0, Point 2 0, Point 0 2, Point 2 2, Point 1 1]+  let triangulation = buildTriangulation built+  assertEqual "Voronoi face count" (numVertices triangulation) (length (voronoiFaces triangulation))+  assertEqual "directed dual edge count" (numDirectedEdges triangulation) (length (directedVoronoiEdges triangulation))+  assertEqual "undirected dual edge count" (numUndirectedEdges triangulation) (length (undirectedVoronoiEdges triangulation))+  forM_ (directedVoronoiEdges triangulation) $ \edge -> do+    assertEqual "dual double reversal" edge (reverseVoronoiEdge (reverseVoronoiEdge edge))+    assertEqual "dual next/previous" edge (voronoiPrevious triangulation (voronoiNext triangulation edge))+    assertEqual+      "dual face/site"+      (origin triangulation (asDelaunayDirectedEdge edge))+      (voronoiFaceSite (voronoiIncidentFace triangulation edge))+    case voronoiEdgeGeometry triangulation edge of+      Nothing -> fail "valid dual edge has no geometry"+      Just _ -> pure ()+  case directedVoronoiEdges triangulation of+    [] -> fail "Voronoi test produced no directed dual edge"+    first : _ -> do+      handle <- requireJust "dynamic Voronoi edge" (VoronoiDynamic.directedVoronoiEdgeHandle triangulation first)+      assertEqual "dynamic dual fix" first (VoronoiDynamic.fixDirectedVoronoiEdge handle)+      assertEqual "dynamic dual reversal" first (VoronoiDynamic.fixDirectedVoronoiEdge (VoronoiDynamic.voronoiEdgeReverseH (VoronoiDynamic.voronoiEdgeReverseH handle)))+      assertEqual "dynamic dual/primal conversion" (asDelaunayDirectedEdge first) (Dynamic.fixDirectedEdge (VoronoiDynamic.voronoiEdgeAsDelaunayH handle))+      let dualFace = VoronoiDynamic.voronoiEdgeFaceH handle+      assertEqual "dynamic dual face site" (origin triangulation (asDelaunayDirectedEdge first)) (Dynamic.fixVertex (VoronoiDynamic.voronoiFaceSiteH dualFace))+      let source = VoronoiDynamic.voronoiEdgeFromH handle+      case VoronoiDynamic.voronoiVertexAsDelaunayFaceH source of+        Just inner -> case VoronoiDynamic.voronoiVertexPositionH source of+          Nothing -> fail "inner dynamic Voronoi vertex has no position"+          Just voronoiPosition -> assertEqual "inner dynamic Voronoi position" (Dynamic.innerFaceCircumcenter inner) (Just voronoiPosition)+        Nothing -> unless (isJust (VoronoiDynamic.voronoiVertexAsOuterEdgeH source)) $+          fail "outer dynamic Voronoi vertex has no defining edge"++testRemoval :: IO ()+testRemoval = do+  built <- requirePointBuild "removal" [Point 0 0, Point 3 0, Point 3 3, Point 0 3, Point 1.5 1.5]+  let triangulation = buildTriangulation built+  assertEqual+    "out-of-range removal obstruction"+    (Left (RemovalVertexOutOfRange (VertexId 5) 5))+    (void (removeVertex triangulation (VertexId 5)))+  removedInterior <- requireRight "interior removal" (removeVertex triangulation (VertexId 4))+  assertEqual "interior removed point" (Point 1.5 1.5) (removalOutcomePoint (removalOutcome removedInterior))+  assertEqual "interior removal count" 4 (numVertices (removalTriangulation removedInterior))+  assertValid "interior removal" (removalTriangulation removedInterior)+  let beforeHullRemoval = removalTriangulation removedInterior+      previousLastVertex = VertexId (fromIntegral (numVertices beforeHullRemoval - 1))+      swappedPoint = vertexPoint beforeHullRemoval previousLastVertex+      swappedData = vertexData beforeHullRemoval previousLastVertex+  removedHull <- requireRight "hull removal" (removeVertex beforeHullRemoval (VertexId 0))+  assertEqual "hull removal count" 3 (numVertices (removalTriangulation removedHull))+  case removalOutcomeSwap (removalOutcome removedHull) of+    Nothing -> fail "hull removal omitted the swap-compacted vertex handle"+    Just (swappedIn, swappedInPoint) -> do+      assertEqual "hull swapped-in handle" (VertexId 0) swappedIn+      assertEqual "hull swapped-in point" swappedPoint (vertexPoint (removalTriangulation removedHull) swappedIn)+      assertEqual "hull swapped-in payload" swappedData (vertexData (removalTriangulation removedHull) swappedIn)+      -- The reported position must be the one the arena now holds, bit for+      -- bit: a caller seeding a search from it is seeding from the mesh.+      assertEqual "hull swapped-in reported position" swappedPoint swappedInPoint+  assertValid "hull removal" (removalTriangulation removedHull)++  let afterHullRemoval = removalTriangulation removedHull+      lastVertex = VertexId (fromIntegral (numVertices afterHullRemoval - 1))+  removedLast <- requireRight "last-vertex removal" (removeVertex afterHullRemoval lastVertex)+  assertEqual+    "removing the last vertex relocates nothing"+    Nothing+    (removalOutcomeSwap (removalOutcome removedLast))+  assertEqual "last-vertex removal count" 2 (numVertices (removalTriangulation removedLast))+  assertValid "last-vertex removal" (removalTriangulation removedLast)++  lineBuild <- requirePointBuild "line removal" [Point 0 0, Point 1 0, Point 2 0, Point 3 0]+  lineMiddle <- requireRight "line middle removal" (removeVertex (buildTriangulation lineBuild) (VertexId 1))+  assertEqual "line middle count" 3 (numVertices (removalTriangulation lineMiddle))+  assertValid "line middle removal" (removalTriangulation lineMiddle)++  degreeThreeBuild <-+    requirePointBuild+      "degree-three removal"+      [Point 0 0, Point 4 0, Point 0 4, Point 1 1]+  let degreeThreeMapping = buildInputVertices degreeThreeBuild+  case if 3 < sizeofPrimArray degreeThreeMapping+        then Just (VertexId (indexPrimArray degreeThreeMapping 3))+        else Nothing of+    Nothing -> fail "degree-three removal input mapping omitted the interior vertex"+    Just centerVertex -> do+      degreeThree <-+        requireRight+          "degree-three interior removal"+          (removeVertex (buildTriangulation degreeThreeBuild) centerVertex)+      assertEqual "degree-three removal count" 3 (numVertices (removalTriangulation degreeThree))+      assertValid "degree-three interior removal" (removalTriangulation degreeThree)++  -- A removal hands its vertex's whole ring to edge/face cleanup, so a+  -- high-degree star is the only shape that exercises the ordered-set path+  -- there; an ordinary mesh keeps degrees near six and never leaves the+  -- insertion sort. Radii are jittered so no four rim points are cocircular.+  let rimCount = 48+      rimPoint index =+        let angle = 2 * pi * fromIntegral index / fromIntegral rimCount+            radius = 1 + 0.001 * fromIntegral (index `mod` 7)+         in Point (radius * cos angle) (radius * sin angle)+  starBuild <-+    requirePointBuild+      "high-degree removal"+      (Point 0 0 : map rimPoint [0 .. rimCount - 1])+  let starTriangulation = buildTriangulation starBuild+      starCentre = VertexId (indexPrimArray (buildInputVertices starBuild) 0)+      centreDegree =+        length+          [ ()+          | edge <- undirectedEdges starTriangulation+          , let (from, to) = undirectedEndpoints starTriangulation edge+          , from == starCentre || to == starCentre+          ]+  assertEqual "high-degree centre ring" rimCount centreDegree+  starRemoved <-+    requireRight "high-degree interior removal" (removeVertex starTriangulation starCentre)+  assertEqual "high-degree removal count" rimCount (numVertices (removalTriangulation starRemoved))+  assertEqual+    "high-degree removed point"+    (Point 0 0)+    (removalOutcomePoint (removalOutcome starRemoved))+  assertValid "high-degree interior removal" (removalTriangulation starRemoved)++  -- A transaction that refuses publishes nothing: the refusal is the whole+  -- answer, so no half-remeshed arena can reach a caller as a triangulation.+  let sessionRefusal = RemovalVertexOutOfRange (VertexId 99) 5+  assertEqual+    "a refused session publishes nothing"+    (Left sessionRefusal)+    (void (withSession triangulation 1 (refuse sessionRefusal :: Session s (Point) () () () ())))++  -- Refusal short-circuits: an edit after it never runs, so the mesh the+  -- transaction abandoned is the mesh it was handed.+  assertEqual+    "a refusal abandons the edits behind it"+    (Left sessionRefusal)+    ( void+        ( withSession+            triangulation+            1+            ( ( do+                  _ <- removeAt (Point 0 0)+                  _ <- refuse sessionRefusal+                  removeAt (Point 1 1)+              ) ::+                Session s (Point) () () () (Maybe (RemovalOutcome (Point)))+            )+        )+    )++  -- The two point-keyed entries must publish one story. A handle-keyed removal+  -- locates nothing, while the coordinate-keyed route resolves the same site+  -- through the exact derived identity section rather than a topological walk.+  -- Both therefore charge no location steps and retire the same vertex.+  handleRemoval <- requireRight "handle removal stats" (removeVertex triangulation (VertexId 4))+  assertEqual+    "a handle-keyed removal locates nothing"+    0+    (statLocationWalkSteps (removalStats handleRemoval))+  locatedRemoval <-+    requireRight "point removal stats" (locateAndRemove triangulation (Point 1.5 1.5))+  pointRemoval <- requireJust "point removal located a vertex" locatedRemoval+  assertEqual+    "a point-keyed removal performs no topological location walk"+    0+    (statLocationWalkSteps (removalStats pointRemoval))+  assertEqual+    "point-keyed and handle-keyed removal publish the same mesh"+    (canonicalEdges (removalTriangulation handleRemoval))+    (canonicalEdges (removalTriangulation pointRemoval))++testConstrainedDelaunay :: IO ()+testConstrainedDelaunay = do+  base <- requirePointBuild "CDT base" [Point 0 0, Point 4 0, Point 4 4, Point 0 4, Point 1 1, Point 3 3, Point 1 3, Point 3 1]+  let cdt0 = fromDelaunay (buildTriangulation base)+  diagonalBatch <-+    requireRight+      "constraint recovery"+      (recoverConstraints cdt0 (V.singleton (VertexId 0, VertexId 2)))+  (diagonalPath, diagonalAdded) <-+    requireAcceptedConstraint "constraint recovery" diagonalBatch+  let cdt1 = constraintBatchTriangulation diagonalBatch+  when (V.null diagonalPath) $ fail "constraint recovery returned an empty path"+  assertEqual "constraint count" diagonalAdded (numConstraints cdt1)+  assertCdtValid "constraint recovery" cdt1+  conflictBatch <-+    requireRight+      "atomic conflict"+      (recoverConstraints cdt1 (V.singleton (VertexId 1, VertexId 3)))+  case V.toList (constraintBatchOutcomes conflictBatch) of+    [ConstraintRejected _] -> pure ()+    outcomes ->+      fail+        ( "crossing constraint was not rejected atomically: "+            <> show outcomes+        )+  assertEqual+    "crossing rejection preserves topology"+    cdt1+    (constraintBatchTriangulation conflictBatch)+  let constraintProgram =+        V.fromList+          [ (VertexId 0, VertexId 2)+          , (VertexId 1, VertexId 3)+          , (VertexId 4, VertexId 6)+          ]+  wholeProgram <-+    requireRight+      "whole constraint program"+      (recoverConstraints cdt0 constraintProgram)+  (singletonTriangulation, singletonOutcomes) <-+    requireRight+      "singleton constraint program"+      (V.foldM' replayConstraintRequest (cdt0, []) constraintProgram)+  assertEqual+    "batch outcomes equal singleton descent"+    (V.toList (constraintBatchOutcomes wholeProgram))+    (reverse singletonOutcomes)+  assertEqual+    "batch topology equals singleton descent"+    singletonTriangulation+    (constraintBatchTriangulation wholeProgram)+  assertBatchStats "whole constraint program" wholeProgram+  forM_ [0 .. 7 :: Int] $ \batchIndex -> do+    randomizedBuild <-+      requirePointBuild+        ("random constraint batch " <> show batchIndex)+        (randomPoints (0x6a09_e667_f3bc_c909 + fromIntegral batchIndex) 40)+    let randomizedBase = fromDelaunay (buildTriangulation randomizedBuild)+        mapping = buildInputVertices randomizedBuild+        handles = V.generate (sizeofPrimArray mapping) (VertexId . indexPrimArray mapping)+        requests = V.take 18 (V.zip handles (V.reverse handles))+    randomizedBatch <-+      requireRight+        ("random whole constraint batch " <> show batchIndex)+        (recoverConstraints randomizedBase requests)+    (randomizedSingleton, randomizedOutcomes) <-+      requireRight+        ("random singleton constraint batch " <> show batchIndex)+        (V.foldM' replayConstraintRequest (randomizedBase, []) requests)+    assertEqual+      ("random batch outcomes equal singleton descent " <> show batchIndex)+      (V.toList (constraintBatchOutcomes randomizedBatch))+      (reverse randomizedOutcomes)+    assertEqual+      ("random batch topology equals singleton descent " <> show batchIndex)+      randomizedSingleton+      (constraintBatchTriangulation randomizedBatch)+    assertBatchStats+      ("random constraint batch " <> show batchIndex)+      randomizedBatch+    assertCdtValid+      ("random constraint batch " <> show batchIndex)+      (constraintBatchTriangulation randomizedBatch)+  -- Batch admission returns the first typed obstruction. Callers that need a+  -- complete diagnosis ask the explicit corridor query and alone pay for it.+  diagnosisBatch <-+    requireRight+      "conflict diagnosis"+      (recoverConstraints cdt1 (V.singleton (VertexId 6, VertexId 7)))+  case V.toList (constraintBatchOutcomes diagnosisBatch) of+    [ConstraintRejected blocking] -> do+      let diagnosed =+            fmap+              asUndirected+              (getConflictingEdgesBetweenVertices cdt1 (VertexId 6) (VertexId 7))+      case diagnosed of+        [] -> fail "explicit conflict diagnosis named no edge"+        firstBlocking : _ ->+          assertEqual "batch rejection is the first corridor obstruction" firstBlocking blocking+      assertEqual+        "explicit conflict diagnosis is deduplicated"+        (length diagnosed)+        (length (Set.fromList diagnosed))+      forM_ diagnosed $ \edge ->+        unless (isConstraintEdge cdt1 edge) $+          fail ("explicit conflict diagnosis named a non-constraint edge: " <> show edge)+    outcomes ->+      fail+        ( "a constraint crossing the diagonal was not rejected: "+            <> show outcomes+        )++  split <- requireRight "constraint split" (addConstraintAndSplit id cdt1 (VertexId 1) (VertexId 3))+  let splitCdt = constraintTriangulation split+  unless (numVertices splitCdt > numVertices cdt1) $ fail "constraint split did not insert an intersection vertex"+  assertCdtValid "constraint split" splitCdt++  -- The batch splitter must agree with singleton descent, including across a+  -- suspension: every vertical below is constrained only inside the batch+  -- itself, so no census against the base can reserve for its crossings and+  -- the chunk's vertex reservation exhausts mid-batch. The driver publishes,+  -- re-reserves against the published mesh, and resumes; the final mesh must+  -- not know any of that happened.+  let bandColumns = [0 .. 7 :: Int]+      bandVertices =+        V.fromList+          ( Point 0 5+              : Point 90 5+              : concat+                  [ [Point x 10, Point x 0]+                  | column <- bandColumns+                  , let x = 10 * fromIntegral column + 5+                  ]+          )+  bandBuild <-+    requireRight+      "split band base"+      (constrainedDelaunayMaximal unitElementDefaults bandVertices V.empty)+  let bandMapping = cdtBuildInputVertices bandBuild+      bandHandle input = VertexId (indexPrimArray bandMapping input)+      bandBase = cdtBuildTriangulation bandBuild+      bandRequests =+        V.fromList+          ( (bandHandle 0, bandHandle 1)+              : [ (bandHandle (2 * column + 2), bandHandle (2 * column + 3))+                | column <- bandColumns+                ]+          )+      replaySplit+        :: ConstrainedDelaunayTriangulation (Point)+        -> (VertexId, VertexId)+        -> Either (CdtError) (ConstrainedDelaunayTriangulation (Point))+      replaySplit triangulation request =+        constraintTriangulation+          <$> uncurry (addConstraintAndSplit id triangulation) request+  bandBatch <-+    requireRight+      "split batch"+      (addConstraintsAndSplit id bandBase bandRequests)+  bandDescent <-+    requireRight+      "split singleton descent"+      (V.foldM' replaySplit bandBase bandRequests)+  assertEqual+    "split batch topology equals singleton descent"+    bandDescent+    (splitBatchTriangulation bandBatch)+  assertEqual+    "split batch added one vertex per crossing"+    (numVertices bandBase + length bandColumns)+    (numVertices (splitBatchTriangulation bandBatch))+  assertCdtValid "split batch" (splitBatchTriangulation bandBatch)++  -- The same law with the reservation exhausting inside one corridor rather+  -- than between corridors: the closing horizontal crosses two constraints+  -- the census can see and fifteen it cannot, so the corridor suspends with+  -- its cursor mid-walk and the resumed transaction continues from the last+  -- split vertex, not from the corridor's start.+  let laceColumns = [0 .. 16 :: Int]+      laceVertices =+        V.fromList+          ( Point 0 5+              : Point 90 5+              : concat+                  [ [Point x 10, Point x 0]+                  | column <- laceColumns+                  , let x = 5 * fromIntegral column + 5+                  ]+          )+      laceBuiltIn = V.fromList [(2, 3), (34, 35)]+  laceBuild <-+    requireRight+      "split lace base"+      (constrainedDelaunayMaximal unitElementDefaults laceVertices laceBuiltIn)+  let laceMapping = cdtBuildInputVertices laceBuild+      laceHandle input = VertexId (indexPrimArray laceMapping input)+      laceBase = cdtBuildTriangulation laceBuild+      laceRequests =+        V.fromList+          ( [ (laceHandle (2 * column + 2), laceHandle (2 * column + 3))+            | column <- [1 .. 15]+            ]+              <> [(laceHandle 0, laceHandle 1)]+          )+  laceBatch <-+    requireRight+      "split lace batch"+      (addConstraintsAndSplit id laceBase laceRequests)+  laceDescent <-+    requireRight+      "split lace singleton descent"+      (V.foldM' replaySplit laceBase laceRequests)+  assertEqual+    "split lace batch topology equals singleton descent"+    laceDescent+    (splitBatchTriangulation laceBatch)+  assertEqual+    "split lace batch added one vertex per crossing"+    (numVertices laceBase + length laceColumns)+    (numVertices (splitBatchTriangulation laceBatch))+  assertCdtValid "split lace batch" (splitBatchTriangulation laceBatch)++  let verticesInput :: V.Vector (Point)+      verticesInput = V.fromList [Point 0 0, Point 4 0, Point 4 4, Point 0 4, Point 0 0]+      constraintsInput = V.fromList [(0, 2), (1, 3), (4, 1)]+  bulk <- requireRight "stable CDT bulk load" (constrainedDelaunayMaximal unitElementDefaults verticesInput constraintsInput)+  let bulkMapping = cdtBuildInputVertices bulk+  unless (sizeofPrimArray bulkMapping > 4) $ fail "cdtBuildInputVertices out of bounds"+  assertEqual "stable duplicate reroute" (VertexId (indexPrimArray bulkMapping 0)) (VertexId (indexPrimArray bulkMapping 4))+  assertEqual "conflict reporting" 1 (V.length (cdtRejectedConstraints bulk))+  assertCdtValid "stable CDT bulk load" (cdtBuildTriangulation bulk)++testAnnotatedConstrainedUnion :: IO ()+testAnnotatedConstrainedUnion = do+  let leftPoints :: V.Vector (Point)+      leftPoints = V.fromList [Point 0 0, Point 2 0, Point 2 2, Point 0 2]+      rightPoints :: V.Vector (Point)+      rightPoints = V.fromList [Point 2 0, Point 4 0, Point 4 2, Point 2 2]+      thirdPoints :: V.Vector (Point)+      thirdPoints = V.fromList [Point 4 0, Point 6 0, Point 6 2, Point 4 2]+  leftBuild <-+    requireRight "annotated constrained union left" $+      constrainedDelaunay+        unitElementDefaults+        leftPoints+        (V.singleton (0, 2))+  rightBuild <-+    requireRight "annotated constrained union right" $+      constrainedDelaunay+        unitElementDefaults+        rightPoints+        (V.singleton (0, 2))+  thirdBuild <-+    requireRight "annotated constrained union third" $+      constrainedDelaunay+        unitElementDefaults+        thirdPoints+        (V.singleton (0, 2))+  let left =+        mapVertices+          (const (Set.singleton "left"))+          (buildTriangulation leftBuild)+      right =+        mapVertices+          (const (Set.singleton "right"))+          (buildTriangulation rightBuild)+      third =+        mapVertices+          (const (Set.singleton "third"))+          (buildTriangulation thirdBuild)+  joined <-+    requireRight+      "annotated constrained union"+      (unionConstrainedWith Set.union left right)+  let expectedAnnotations =+        Map.fromList+          [ (Point 0 0, Set.singleton "left")+          , (Point 0 2, Set.singleton "left")+          , (Point 2 0, Set.fromList ["left", "right"])+          , (Point 2 2, Set.fromList ["left", "right"])+          , (Point 4 0, Set.singleton "right")+          , (Point 4 2, Set.singleton "right")+          ]+      actualAnnotations =+        Map.fromList+          [ (vertexPoint joined vertex, vertexData joined vertex)+          | vertex <- vertices joined+          ]+      expectedConstraints =+        Set.union+          (Set.fromList (V.toList (constraintSegments left)))+          (Set.fromList (V.toList (constraintSegments right)))+  assertEqual+    "annotated constrained union preserves and combines site payloads"+    expectedAnnotations+    actualAnnotations+  assertEqual+    "annotated constrained union preserves both constraint sections"+    expectedConstraints+    (Set.fromList (V.toList (constraintSegments joined)))+  assertCdtValid "annotated constrained union" joined+  commuted <-+    requireRight+      "annotated constrained union commuted"+      (unionConstrainedWith Set.union right left)+  assertEqual+    "annotated constrained union is commutative under a commutative payload combiner"+    joined+    commuted+  leftAssociated <-+    requireRight+      "annotated constrained union left-associated"+      (unionConstrainedWith Set.union joined third)+  rightPair <-+    requireRight+      "annotated constrained union right pair"+      (unionConstrainedWith Set.union right third)+  rightAssociated <-+    requireRight+      "annotated constrained union right-associated"+      (unionConstrainedWith Set.union left rightPair)+  assertEqual+    "annotated constrained union is associative wherever both descents are admitted"+    leftAssociated+    rightAssociated+  unitJoined <-+    requireRight+      "unit constrained union specialization"+      ( unionConstrained+          (mapVertices (const ()) left)+          (mapVertices (const ()) right)+      )+  assertEqual+    "unit constrained union specializes annotated constrained union"+    unitJoined+    (mapVertices (const ()) joined)++-- | Sequential extension retains the base authority as the transaction root.+-- The semantic result agrees with canonical union on sites and constraint+-- sections, but its receipt proves that only the incoming constraint section+-- was interpreted.+testAsymmetricConstrainedExtension :: IO ()+testAsymmetricConstrainedExtension = do+  let basePoints :: V.Vector (Point)+      basePoints = V.fromList [Point 0 0, Point 2 0, Point 2 2, Point 0 2]+      extensionPoints :: V.Vector (Point)+      extensionPoints = V.fromList [Point 2 0, Point 4 0, Point 4 2, Point 2 2]+  baseBuild <-+    requireRight+      "asymmetric extension base"+      (constrainedDelaunay unitElementDefaults basePoints (V.singleton (0, 2)))+  extensionBuild <-+    requireRight+      "asymmetric extension incoming"+      (constrainedDelaunay unitElementDefaults extensionPoints (V.singleton (0, 2)))+  let base = mapVertices (const (Set.singleton "base")) (buildTriangulation baseBuild)+      extension = mapVertices (const (Set.singleton "extension")) (buildTriangulation extensionBuild)+      expectedAnnotations =+        Map.fromList+          [ (Point 0 0, Set.singleton "base")+          , (Point 0 2, Set.singleton "base")+          , (Point 2 0, Set.fromList ["base", "extension"])+          , (Point 2 2, Set.fromList ["base", "extension"])+          , (Point 4 0, Set.singleton "extension")+          , (Point 4 2, Set.singleton "extension")+          ]+      expectedConstraints =+        Set.union+          (Set.fromList (V.toList (constraintSegments base)))+          (Set.fromList (V.toList (constraintSegments extension)))+      baseAnnotations =+        Map.fromList+          [ (vertexPoint base vertex, vertexData base vertex)+          | vertex <- vertices base+          ]+      extensionAnnotations =+        Map.fromList+          [ (vertexPoint extension vertex, vertexData extension vertex)+          | vertex <- vertices extension+          ]+  baseAnnotationsBefore <- evaluate (force baseAnnotations)+  baseConstraintsBefore <- evaluate (force (constraintSegments base))+  extensionAnnotationsBefore <- evaluate (force extensionAnnotations)+  extensionConstraintsBefore <- evaluate (force (constraintSegments extension))+  extendedResult <-+    requireRight+      "asymmetric constrained extension"+      (extendConstrainedWith Set.union base extension)+  let extended = constrainedExtensionTriangulation extendedResult+      receipt = constrainedExtensionConstraintStats extendedResult+      buildReceipt = constrainedExtensionBuildStats extendedResult+      actualAnnotations =+        Map.fromList+          [ (vertexPoint extended vertex, vertexData extended vertex)+          | vertex <- vertices extended+          ]+  assertEqual+    "asymmetric extension preserves base and combines coincident site payloads"+    expectedAnnotations+    actualAnnotations+  assertEqual+    "asymmetric extension preserves resident and incoming constraint sections"+    expectedConstraints+    (Set.fromList (V.toList (constraintSegments extended)))+  assertEqual+    "asymmetric extension does not mutate the frozen base predecessor sites"+    baseAnnotationsBefore+    ( Map.fromList+        [ (vertexPoint base vertex, vertexData base vertex)+        | vertex <- vertices base+        ]+    )+  assertEqual+    "asymmetric extension does not mutate the frozen base predecessor constraints"+    baseConstraintsBefore+    (constraintSegments base)+  assertEqual+    "asymmetric extension does not mutate the frozen incoming predecessor sites"+    extensionAnnotationsBefore+    ( Map.fromList+        [ (vertexPoint extension vertex, vertexData extension vertex)+        | vertex <- vertices extension+        ]+    )+  assertEqual+    "asymmetric extension does not mutate the frozen incoming predecessor constraints"+    extensionConstraintsBefore+    (constraintSegments extension)+  assertEqual+    "asymmetric extension recovers only incoming constraints"+    (V.length (constraintSegments extension))+    (constraintBatchRequests receipt)+  assertEqual+    "asymmetric extension returns one outcome for each incoming constraint"+    (V.length (constraintSegments extension))+    (V.length (constrainedExtensionConstraintOutcomes extendedResult))+  assertEqual+    "asymmetric extension admits every incoming constraint"+    (V.length (constraintSegments extension))+    (constraintBatchAccepted receipt)+  assertEqual+    "asymmetric extension reports no incoming constraint rejection"+    0+    (constraintBatchRejected receipt)+  assertEqual+    "asymmetric extension charges every incoming site once"+    (V.length extensionPoints)+    (statInputPoints buildReceipt)+  assertEqual+    "asymmetric extension distinguishes occupied incoming sites"+    2+    (statExistingPoints buildReceipt)+  assertEqual+    "asymmetric extension distinguishes newly materialized incoming sites"+    2+    (statUniquePoints buildReceipt)+  assertCdtValid "asymmetric constrained extension" extended++  crossingBuild <-+    requireRight+      "asymmetric extension crossing incoming section"+      (constrainedDelaunay unitElementDefaults basePoints (V.singleton (1, 3)))+  case+      extendConstrainedWith+        Set.union+        base+        (mapVertices (const (Set.singleton "crossing")) (buildTriangulation crossingBuild)) of+    Left (ConstraintUnionConstructionFailed (ConstraintIntersection _)) -> pure ()+    other -> fail ("asymmetric extension did not return the corridor intersection witness: " <> show other)++testLargeAsymmetricConstrainedExtension :: IO ()+testLargeAsymmetricConstrainedExtension = do+  let width = 40 :: Int+      height = 28 :: Int+      basePoints :: V.Vector (Point)+      basePoints =+        V.fromList+          ( [ Point 0 0+            , Point (fromIntegral (width + 1)) 0+            , Point (fromIntegral (width + 1)) (fromIntegral (height + 1))+            , Point 0 (fromIntegral (height + 1))+            ]+              <> [ Point+                     (fromIntegral (column + 1) + fromIntegral ((column * 17 + row * 31) `mod` 13) * 1.0e-3)+                     (fromIntegral (row + 1) + fromIntegral ((column * 23 + row * 19) `mod` 17) * 1.0e-3)+                 | row <- [0 .. height - 1]+                 , column <- [0 .. width - 1]+                 ]+          )+      baseConstraints = V.fromList [(0, 1), (1, 2), (2, 3), (3, 0), (0, 2)]+      extensionPoints :: V.Vector (Point)+      extensionPoints = V.fromList [Point 48 8, Point 53.2 8.4, Point 50.4 15.8]+      extensionConstraints = V.fromList [(0, 1), (1, 2), (2, 0)]+      conflictPoints :: V.Vector (Point)+      conflictPoints = V.fromList [Point 8 22, Point 30 5, Point 26 7]+  baseBuild <-+    requireRight+      "large asymmetric extension base"+      (constrainedDelaunay unitElementDefaults basePoints baseConstraints)+  extensionBuild <-+    requireRight+      "large asymmetric extension incoming"+      (constrainedDelaunay unitElementDefaults extensionPoints extensionConstraints)+  conflictBuild <-+    requireRight+      "large asymmetric extension conflicting incoming"+      (constrainedDelaunay unitElementDefaults conflictPoints (V.singleton (0, 1)))+  let base = mapVertices (const (Set.singleton "base")) (buildTriangulation baseBuild)+      extension = mapVertices (const (Set.singleton "extension")) (buildTriangulation extensionBuild)+      conflicting = mapVertices (const (Set.singleton "conflict")) (buildTriangulation conflictBuild)+      predecessor+        :: Triangulation 'Constrained (Set.Set String) () () ()+        -> ( Triangulation 'Constrained (Set.Set String) () () ()+           , Map.Map VertexId (Point, Set.Set String)+           , Set.Set (CanonicalSegment)+           )+      predecessor triangulation =+        ( triangulation+        , Map.fromList+            [ (vertex, (vertexPoint triangulation vertex, vertexData triangulation vertex))+            | vertex <- vertices triangulation+            ]+        , Set.fromList (V.toList (constraintSegments triangulation))+        )+      assertPredecessor+        :: String+        -> ( Triangulation 'Constrained (Set.Set String) () () ()+           , Map.Map VertexId (Point, Set.Set String)+           , Set.Set (CanonicalSegment)+           )+        -> Triangulation 'Constrained (Set.Set String) () () ()+        -> IO ()+      assertPredecessor label snapshot triangulation =+        assertEqual label snapshot (predecessor triangulation)+  baseBefore <- evaluate (force (predecessor base))+  extensionBefore <- evaluate (force (predecessor extension))+  conflictingBefore <- evaluate (force (predecessor conflicting))+  let (_, baseVertexSnapshotBefore, baseConstraintSnapshotBefore) = baseBefore+      (_, _, extensionConstraintSnapshotBefore) = extensionBefore+  extensionResult <-+    requireRight+      "large asymmetric constrained extension"+      (extendConstrainedWith Set.union base extension)+  let extended = constrainedExtensionTriangulation extensionResult+      extendedConstraints = Set.fromList (V.toList (constraintSegments extended))+      extendedVertexSnapshot =+        Map.fromList+          [ (vertex, (vertexPoint extended vertex, vertexData extended vertex))+          | vertex <- vertices extended+          ]+  assertEqual+    "large asymmetric extension retains every base vertex handle, coordinate, and payload"+    baseVertexSnapshotBefore+    (Map.restrictKeys extendedVertexSnapshot (Map.keysSet baseVertexSnapshotBefore))+  assertEqual+    "large asymmetric extension retains its complete base constraint source section"+    baseConstraintSnapshotBefore+    (Set.intersection baseConstraintSnapshotBefore extendedConstraints)+  assertEqual+    "large asymmetric extension retains its complete incoming constraint source section"+    extensionConstraintSnapshotBefore+    (Set.intersection extensionConstraintSnapshotBefore extendedConstraints)+  assertEqual+    "large asymmetric extension preserves exactly both source constraint sections"+    (Set.union baseConstraintSnapshotBefore extensionConstraintSnapshotBefore)+    extendedConstraints+  assertEqual+    "large asymmetric extension leaves the frozen base predecessor physically unchanged"+    baseBefore+    (predecessor base)+  assertPredecessor+    "large asymmetric extension leaves the frozen incoming predecessor physically unchanged"+    extensionBefore+    extension+  assertEqual+    "large asymmetric extension charges only the incoming sites"+    (V.length extensionPoints)+    (statInputPoints (constrainedExtensionBuildStats extensionResult))+  assertEqual+    "large asymmetric extension replays only the incoming constraints"+    (V.length extensionConstraints)+    (constraintBatchRequests (constrainedExtensionConstraintStats extensionResult))+  assertCdtValid "large asymmetric constrained extension" extended+  case extendConstrainedWith Set.union base conflicting of+    Left (ConstraintUnionConstructionFailed (ConstraintIntersection _)) -> pure ()+    outcome ->+      fail+        ( "large asymmetric extension did not refuse the crossing incoming corridor: "+            <> show outcome+        )+  assertEqual+    "large asymmetric extension refusal leaves the frozen base predecessor physically unchanged"+    baseBefore+    (predecessor base)+  assertPredecessor+    "large asymmetric extension refusal leaves the conflicting predecessor physically unchanged"+    conflictingBefore+    conflicting++-- | A separated constrained seam is a restriction-preserving operation, not+-- the canonical site-set union wearing a cheaper costume. Both closed source+-- sections survive face-for-face; only the corridor contributes new faces.+testSeparatedConstrainedSeam :: IO ()+testSeparatedConstrainedSeam = do+  let leftPoints :: V.Vector (Point)+      leftPoints =+        V.fromList+          [ Point (-4) (-1)+          , Point (-2) (-1)+          , Point (-2) 1+          , Point (-4) 1+          ]+      rightPoints :: V.Vector (Point)+      rightPoints =+        V.fromList+          [ Point 2 (-1)+          , Point 4 (-1)+          , Point 4 1+          , Point 2 1+          ]+      closedContour = V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)]+  leftBuild <-+    requireRight+      "separated constrained seam left"+      (constrainedDelaunay unitElementDefaults leftPoints closedContour)+  rightBuild <-+    requireRight+      "separated constrained seam right"+      (constrainedDelaunay unitElementDefaults rightPoints closedContour)+  let left =+        mapVertices+          (const (Set.singleton "left"))+          (buildTriangulation leftBuild)+      right =+        mapVertices+          (const (Set.singleton "right"))+          (buildTriangulation rightBuild)+      leftFaceKeys = Set.fromList (fmap (faceKeyOf left) (innerFaces left))+      rightFaceKeys = Set.fromList (fmap (faceKeyOf right) (innerFaces right))+      expectedConstraints =+        Set.union+          (Set.fromList (V.toList (constraintSegments left)))+          (Set.fromList (V.toList (constraintSegments right)))+  seam <-+    requireRight+      "source-preserving separated constrained seam"+      (joinSeparatedConstrainedWith Set.union left right)+  let joined = constrainedSeamResultTriangulation seam+      joinedFaceKeys = Set.fromList (fmap (faceKeyOf joined) (innerFaces joined))+      actualAnnotations =+        Map.fromList+          [ (vertexPoint joined vertex, vertexData joined vertex)+          | vertex <- vertices joined+          ]+      expectedAnnotations =+        Map.union+          ( Map.fromList+              [ (vertexPoint left vertex, vertexData left vertex)+              | vertex <- vertices left+              ]+          )+          ( Map.fromList+              [ (vertexPoint right vertex, vertexData right vertex)+              | vertex <- vertices right+              ]+          )+  assertCdtValid "source-preserving separated constrained seam" joined+  assertEqual+    "separated seam preserves all source annotations"+    expectedAnnotations+    actualAnnotations+  assertEqual+    "separated seam preserves the exact constraint section"+    expectedConstraints+    (Set.fromList (V.toList (constraintSegments joined)))+  unless (leftFaceKeys `Set.isSubsetOf` joinedFaceKeys) $+    fail "separated seam removed or retriangulated a left source face"+  unless (rightFaceKeys `Set.isSubsetOf` joinedFaceKeys) $+    fail "separated seam removed or retriangulated a right source face"+  assertEqual+    "separated seam has one left face witness per source face"+    (numInnerFaces left)+    (V.length (constrainedSeamLeftFaceEvidence seam))+  assertEqual+    "separated seam has one right face witness per source face"+    (numInnerFaces right)+    (V.length (constrainedSeamRightFaceEvidence seam))+  forM_ (V.toList (constrainedSeamLeftFaceEvidence seam)) $ \evidence ->+    assertEqual+      "left face witness names the exact target triangle"+      (faceKeyOf left (constrainedSeamSourceFace evidence))+      (faceKeyOf joined (constrainedSeamTargetFace evidence))+  forM_ (V.toList (constrainedSeamRightFaceEvidence seam)) $ \evidence ->+    assertEqual+      "right face witness names the exact target triangle"+      (faceKeyOf right (constrainedSeamSourceFace evidence))+      (faceKeyOf joined (constrainedSeamTargetFace evidence))+  when (V.null (constrainedSeamNewFaces seam)) $+    fail "separated seam did not identify any new corridor face"+  assertEqual+    "copied source constraints require no corridor recovery"+    0+    (constraintBatchRequests (constrainedSeamConstraintStats seam))+  unless+    ( all+        ((== Nothing) . constrainedSeamConstraintRecovery)+        ( V.toList (constrainedSeamLeftConstraintEvidence seam)+            <> V.toList (constrainedSeamRightConstraintEvidence seam)+        )+    ) $+    fail "separated seam recovered a constraint already represented by its copied source"++  reversed <-+    requireRight+      "source-preserving reversed separated constrained seam"+      (joinSeparatedConstrainedWith Set.union right left)+  assertEqual+    "reversing separated seam operands preserves the published constrained value"+    joined+    (constrainedSeamResultTriangulation reversed)++  case joinSeparatedConstrainedWith Set.union left left of+    Left ConstraintUnionNotSeparated -> pure ()+    other -> fail ("non-separated constrained seam was not refused: " <> show other)++testConstrainedRefinement :: IO ()+testConstrainedRefinement = do+  cdtBuild <- requireRight "bounded domain" $ constrainedDelaunay+    unitElementDefaults+    (V.fromList [Point 0 0, Point 8 0, Point 8 8, Point 0 8, Point 4 2, Point 4 6])+    (V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)])+  let cdt = buildTriangulation cdtBuild+      parameters = defaultRefinementParameters+        { refineMaxAdditionalVertices = Just 80+        , refineMaxArea = Just 3+        , refineMaxRadiusEdgeRatio = Just 1.4+        , refineExcludeOuterFaces = True+        , refineKeepConstraintEdges = False+        }+  refined <- requireRight "constrained refinement" (refine id parameters cdt)+  let result = refinedTriangulation refined+  canonicalResult <- requireRight "canonical constrained refinement" (canonicalize result)+  unless (refinementAddedVertices refined > 0) $ fail "constrained refinement inserted no Steiner points"+  assertCdtValid "constrained refinement" result+  unless (numConstraints result >= numConstraints cdt) $+    fail "constraint splitting lost the constrained boundary"+  assertEqual+    "canonical publication preserves constraint segments"+    (constraintSegments result)+    (constraintSegments canonicalResult)++  -- Refinement maintains the outer-region classification incrementally, from+  -- the touched patch alone. That is a claim about what an insertion cannot+  -- reach, so it is gated against an independent flood over the finished mesh+  -- rather than trusted. The domain here is deliberately narrower than its+  -- convex hull, so the excluded set is non-empty and the two can disagree.+  notchBuild <- requireRight "notched domain" $ constrainedDelaunay+    unitElementDefaults+    (V.fromList [Point 0 0, Point 8 0, Point 8 8, Point 0 8, Point 13 4, Point 4 4])+    (V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)])+  let notch = buildTriangulation notchBuild+      notchParameters = defaultRefinementParameters+        { refineMaxAdditionalVertices = Just 120+        , refineMaxArea = Just 1.5+        , refineExcludeOuterFaces = True+        , refineKeepConstraintEdges = False+        }+  notchRefined <- requireRight "notched refinement" (refine id notchParameters notch)+  let notchResult = refinedTriangulation notchRefined+      maintained = sort (V.toList (refinementExcludedFaces notchRefined))+      independent = sort (outerRegionFaces notchResult)+  unless (refinementAddedVertices notchRefined > 0) $ fail "notched refinement inserted no Steiner points"+  when (null independent) $ fail "notched domain produced no outer region: the gate is vacuous"+  assertEqual "incremental exclusion agrees with an independent flood" independent maintained+  assertCdtValid "notched refinement" notchResult++  annulusBuild <- requireRight "annular domain" $ constrainedDelaunay+    unitElementDefaults+    ( V.fromList+        [ Point 0 0+        , Point 12 0+        , Point 12 12+        , Point 0 12+        , Point 4 4+        , Point 8 4+        , Point 8 8+        , Point 4 8+        ]+    )+    ( V.fromList+        [ (0, 1)+        , (1, 2)+        , (2, 3)+        , (3, 0)+        , (4, 5)+        , (5, 6)+        , (6, 7)+        , (7, 4)+        ]+    )+  let annulus = buildTriangulation annulusBuild+      annulusParameters :: Int -> Maybe Double -> RefinementParameters+      annulusParameters budget maximumArea =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just budget+          , refineMaxArea = maximumArea+          , refineExcludeOuterFaces = True+          , refineKeepConstraintEdges = False+          }+  annulusUnchanged <-+    requireRight+      "budget-zero annular refinement"+      (refine id (annulusParameters 0 Nothing) annulus)+  let initialAnnulusOutside = sort (outerRegionFaces annulus)+      budgetZeroOutside =+        sort (V.toList (refinementExcludedFaces annulusUnchanged))+  assertEqual "annulus has one two-crossing hole" 2 (length initialAnnulusOutside)+  assertEqual+    "budget-zero refinement uses the authoritative annulus classification"+    initialAnnulusOutside+    budgetZeroOutside++  annulusRefined <-+    requireRight+      "positive-budget annular refinement"+      (refine id (annulusParameters 40 (Just 4)) annulus)+  let refinedAnnulus = refinedTriangulation annulusRefined+      maintainedAnnulus =+        sort (V.toList (refinementExcludedFaces annulusRefined))+      independentAnnulus = sort (outerRegionFaces refinedAnnulus)+  unless (refinementAddedVertices annulusRefined > 0) $+    fail "annular refinement inserted no Steiner points"+  assertEqual+    "incremental annulus exclusion agrees with authoritative barrier depth"+    independentAnnulus+    maintainedAnnulus+  assertCdtValid "annular constrained refinement" refinedAnnulus++  -- A tiny constraint can share a mesh with coordinates of vastly different+  -- magnitude. Encroachment is discovered by a local cavity walk, so there is+  -- no broad phase for the range to overflow; the pin is that the scaled+  -- circumcenter and diametral predicates still produce exactly one vertex.+  wideGridBuild <- requireRight "wide-grid constrained domain" $ constrainedDelaunay+    unitElementDefaults+    ( V.fromList+        [ Point 0 0+        , Point 2.0e-43 0+        , Point 1.0e60 0+        , Point 0 1.0e60+        ] :: V.Vector (Point)+    )+    (V.singleton (0, 1))+  wideGridRefined <-+    requireRight+      "wide-grid constrained refinement"+      ( refine+          id+          defaultRefinementParameters+            { refineMaxAdditionalVertices = Just 1+            , refineMaxArea = Just 1.0e119+            , refineKeepConstraintEdges = False+            }+          (buildTriangulation wideGridBuild)+      )+  assertEqual "wide-grid refinement count" 1 (refinementAddedVertices wideGridRefined)+  assertCdtValid "wide-grid constrained refinement" (refinedTriangulation wideGridRefined)++-- | A local domain is a closed section, not a hopeful initial queue. Its+-- interface is exact, its protected faces survive point-for-point, and the+-- receipt contains no visit to the protected side.+testCheckedLocalRefinement :: IO ()+testCheckedLocalRefinement = do+  built <-+    requireRight+      "checked local refinement source"+      ( constrainedDelaunay+          unitElementDefaults+          ( V.fromList+              [ Point 0 0+              , Point 4.1 0+              , Point 8 0.2+              , Point 0.1 4+              , Point 4 4.2+              , Point 8.1 4+              ]+          )+          (V.singleton (2, 5))+      )+  let source = buildTriangulation built+      permitted =+        Set.fromList+          [ face+          | face <- innerFaces source+          , faceCentroidX source face < 4.05+          ]+      interface =+        Set.fromList+          [ edge+          | edge <- undirectedEdges source+          , let (forward, backward) = directedPair edge+                forwardFace = incidentFace source forward+                backwardFace = incidentFace source backward+          , forwardFace /= outerFace+          , backwardFace /= outerFace+          , Set.member forwardFace permitted /= Set.member backwardFace permitted+          ]+      protected = filter (`Set.notMember` permitted) (innerFaces source)+      protectedSignatures = fmap (\face -> (face, sort (fmap (vertexPoint source) (faceVertices source face)))) protected+      calmParameters =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just 3+          , refineMaxRadiusEdgeRatio = Nothing+          , refineKeepConstraintEdges = True+          }+      crossingParameters = calmParameters{refineMaxArea = Just 1}+  unless (not (Set.null permitted) && not (null protected) && not (Set.null interface)) $+    fail "checked local refinement fixture did not form a nontrivial cover"+  case Set.minView interface of+    Nothing -> fail "checked local refinement fixture has no interface"+    Just (_, incomplete) ->+      case refineWithinDomain id calmParameters permitted incomplete source of+        Left (RefinementDomainInterfaceMissing _) -> pure ()+        Left obstruction -> fail ("checked local refinement returned the wrong incomplete-interface obstruction: " <> show obstruction)+        Right _ -> fail "checked local refinement accepted an incomplete interface"+  refined <-+    requireRight+      "checked local refinement"+      (refineWithinDomain id calmParameters permitted interface source)+  let localResult = refinementDomainResult refined+      target = refinedTriangulation localResult+      targetProtectedSignatures = fmap (\face -> (face, sort (fmap (vertexPoint target) (faceVertices target face)))) protected+      receipt = refinementDomainReceipt refined+  assertEqual "checked local protected face restriction" protectedSignatures targetProtectedSignatures+  assertEqual "checked local protected visit receipt" V.empty (refinementVisitedProtectedFaces receipt)+  assertEqual "checked local boundary crossing receipt" 0 (refinementAttemptedBoundaryCrossings receipt)+  assertEqual+    "checked local protected constraint restriction"+    (constraintSegments source)+    (constraintSegments target)+  assertValid "checked local refinement" target+  case refineWithinDomain id crossingParameters permitted interface source of+    Left (RefinementDomainWouldCrossInterface _ _) -> pure ()+    Left obstruction -> fail ("checked local refinement returned the wrong crossing obstruction: " <> show obstruction)+    Right _ -> fail "checked local refinement silently crossed its immutable interface"+  case refineWithinDomain id calmParameters{refinePreserveConvexHull = False} permitted interface source of+    Left RefinementDomainRequiresConvexHullPreservation -> pure ()+    outcome -> fail ("checked local refinement accepted hull mutation: " <> either show (const "success") outcome)+  case refineWithinDomain id calmParameters{refineKeepConstraintEdges = False} permitted interface source of+    Left RefinementDomainRequiresConstraintPreservation -> pure ()+    outcome -> fail ("checked local refinement accepted constraint mutation: " <> either show (const "success") outcome)+  case refineWithinDomain id calmParameters{refineExcludeOuterFaces = True} permitted interface source of+    Left RefinementDomainForbidsOuterFaceExclusion -> pure ()+    outcome -> fail ("checked local refinement accepted outer-face exclusion: " <> either show (const "success") outcome)+  wholeRefined <-+    requireRight+      "checked whole-section refinement"+      ( refineWithinDomain+          id+          crossingParameters+          (Set.fromList (innerFaces source))+          Set.empty+          source+      )+  let wholeResult = refinementDomainResult wholeRefined+      wholeReceipt = refinementDomainReceipt wholeRefined+  unless (refinementAddedVertices wholeResult > 0) $+    fail "checked whole-section refinement did not improve its admitted section"+  unless (not (V.null (refinementCreatedFaces wholeReceipt))) $+    fail "checked whole-section refinement omitted semantically rewritten face slots"+  unless+    ( V.any+        (\(FaceId raw) -> toInteger raw < toInteger (numFaces source))+        (refinementCreatedFaces wholeReceipt)+    ) $+    fail "checked whole-section refinement omitted recycled face slots"+  assertValid "checked whole-section refinement" (refinedTriangulation wholeResult)+ where+  faceCentroidX+    :: Triangulation mode vertex directed undirected face+    -> FaceId+    -> Double+  faceCentroidX triangulation face =+    case fmap (vertexPoint triangulation) (faceVertices triangulation face) of+      [] -> 0+      points ->+        sum [x | Point x _ <- points] / fromIntegral (length points)++testRepeatedBoundaryAdjacentRefinement :: IO ()+testRepeatedBoundaryAdjacentRefinement = (do+  built <-+    requireRight+      "repeated boundary-adjacent constrained source"+      ( constrainedDelaunay+          unitElementDefaults+          ( V.fromList+              [ Point 0 0+              , Point 4 0+              , Point 8 0+              , Point 12 0+              , Point 0 4+              , Point 4 4+              , Point 8 4+              , Point 12 4+              ]+          )+          (V.singleton (2, 6))+      )+  let source = buildTriangulation built+      (sourcePermitted, sourceInterface) = leftSection source+      firstParameters =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just 20+          , refineMaxArea = Just 1+          , refineMaxRadiusEdgeRatio = Nothing+          , refineKeepConstraintEdges = True+          }+  firstRefinement <-+    requireRight+      "first boundary-adjacent refinement"+      ( refineWithinDomain+          id+          firstParameters+          sourcePermitted+          sourceInterface+          source+      )+  let firstResult = refinementDomainResult firstRefinement+      firstTarget = refinedTriangulation firstResult+      firstReceipt = refinementDomainReceipt firstRefinement+      (secondPermitted, secondInterface) = leftSection firstTarget+      secondParameters = firstParameters{refineMaxAdditionalVertices = Just 1}+  unless (refinementAddedVertices firstResult > 0) $+    fail "first boundary-adjacent refinement did not refine its admitted section"+  unless (refinementInterfaceBoundaryReads firstReceipt > 0) $+    fail "boundary-adjacent refinement did not report its immutable interface read"+  assertEqual+    "boundary-adjacent crossing attempts"+    0+    (refinementAttemptedBoundaryCrossings firstReceipt)+  assertEqual+    "first boundary-adjacent constraint restriction"+    (constraintSegments source)+    (constraintSegments firstTarget)+  secondRefinement <-+    requireRight+      "repeated boundary-adjacent refinement"+      ( refineWithinDomain+          id+          secondParameters+          secondPermitted+          secondInterface+          firstTarget+      )+  let secondResult = refinementDomainResult secondRefinement+      secondTarget = refinedTriangulation secondResult+      secondReceipt = refinementDomainReceipt secondRefinement+  unless (refinementAddedVertices secondResult > 0) $+    fail "repeated boundary-adjacent refinement did not retain its dynamic join-face support"+  assertEqual+    "repeated boundary-adjacent protected visits"+    V.empty+    (refinementVisitedProtectedFaces secondReceipt)+  assertEqual+    "repeated boundary-adjacent constraint restriction"+    (constraintSegments firstTarget)+    (constraintSegments secondTarget)+  assertValid "repeated boundary-adjacent refinement" secondTarget)+ where+  leftSection+    :: Triangulation mode vertex directed undirected face+    -> (Set.Set FaceId, Set.Set UndirectedEdgeId)+  leftSection triangulation =+    let permitted =+          Set.fromList+            [ face+            | face <- innerFaces triangulation+            , faceCentroidX triangulation face < 8+            ]+        interface =+          Set.fromList+            [ edge+            | edge <- undirectedEdges triangulation+            , let (forward, backward) = directedPair edge+                  forwardFace = incidentFace triangulation forward+                  backwardFace = incidentFace triangulation backward+            , forwardFace /= outerFace+            , backwardFace /= outerFace+            , Set.member forwardFace permitted /= Set.member backwardFace permitted+            ]+     in (permitted, interface)+  faceCentroidX+    :: Triangulation mode vertex directed undirected face+    -> FaceId+    -> Double+  faceCentroidX triangulation face =+    case fmap (vertexPoint triangulation) (faceVertices triangulation face) of+      [] -> 0+      points ->+        sum [x | Point x _ <- points] / fromIntegral (length points)++testTraversal :: IO ()+testTraversal = do+  built <- requirePointBuild "traversal" [Point (-3) 0, Point (-1) (-2), Point (-1) 2, Point 1 (-2), Point 1 2, Point 3 0]+  forwardStart <- requireQueryPoint "forward traversal start" (Point (-4) 0)+  forwardEnd <- requireQueryPoint "forward traversal end" (Point 4 0)+  let triangulation = buildTriangulation built+      forward = lineIntersections triangulation forwardStart forwardEnd+      backward = lineIntersections triangulation forwardEnd forwardStart+  when (null forward) $ fail "ordered line traversal crossed nothing"+  assertEqual+    "reversing the segment reverses the crossings"+    (map crossingIdentity forward)+    (reverse (map crossingIdentity backward))+  circleEdges <- Set.fromList <$> requireRight "circle edge query" (edgesInCircle triangulation (Point 0 0) 4)+  let bruteCircle = Set.fromList+        [ edge+        | edge <- undirectedEdges triangulation+        , let (a, b) = undirectedEndpoints triangulation edge+        , segmentDistanceSquared (vertexPoint triangulation a) (vertexPoint triangulation b) (Point 0 0) <= 4+        ]+  assertEqual "circle edge flood" bruteCircle circleEdges+  assertEqual+    "negative circle metric refusal"+    (Left (NegativeRadiusSquared (-1)))+    (circleMetric (Point 0 0 :: Point) (-1))+  assertEqual+    "negative circle edge-query refusal"+    (Left (NegativeRadiusSquared (-1)))+    (edgesInCircle triangulation (Point 0 0) (-1))+  assertEqual+    "negative circle vertex-query refusal"+    (Left (NegativeRadiusSquared (-1)))+    (verticesInCircle triangulation (Point 0 0) (-1))+  assertEqual+    "NaN circle metric refusal"+    (Left (NonFiniteRadiusSquared ValueNaN))+    (circleMetric (Point 0 0 :: Point) (0 / 0))+  assertEqual+    "NaN circle center-x refusal"+    (Left (InvalidCircleCenter (InvalidPointX CoordinateNaN)))+    (circleMetric (Point (0 / 0) 0 :: Point) 1)+  assertEqual+    "positive-infinite circle center-y refusal"+    (Left (InvalidCircleCenter (InvalidPointY CoordinateInfinite)))+    (edgesInCircle triangulation (Point 0 (1 / 0)) 1)+  assertEqual+    "negative-infinite circle center-x refusal"+    (Left (InvalidCircleCenter (InvalidPointX CoordinateInfinite)))+    (verticesInCircle triangulation (Point ((-1) / 0) 0) 1)+  assertEqual+    "infinite circle edge-query refusal"+    (Left (NonFiniteRadiusSquared ValuePositiveInfinity))+    (edgesInCircle triangulation (Point 0 0) (1 / 0))+  assertEqual+    "negative-infinite circle vertex-query refusal"+    (Left (NonFiniteRadiusSquared ValueNegativeInfinity))+    (verticesInCircle triangulation (Point 0 0) ((-1) / 0))+  rectangleVertices <-+    Set.fromList+      <$> requireRight+        "rectangle query"+        (verticesInRectangle triangulation (Point (-1.1) (-2.1)) (Point 1.1 2.1))+  let bruteVertices = Set.fromList+        [ vertex+        | vertex <- vertices triangulation+        , let Point x y = vertexPoint triangulation vertex+        , x >= (-1.1), x <= 1.1, y >= (-2.1), y <= 2.1+        ]+  assertEqual "rectangle vertex flood" bruteVertices rectangleVertices++testRandomizedConstruction :: IO ()+testRandomizedConstruction = do+  forM_ [0 .. 31] $ \index -> do+    let points = randomPoints (0x9e37_79b9 + fromIntegral index) (40 + index * 7)+    built <- requirePointBuild ("random build " <> show index) points+    let triangulation = buildTriangulation built+    assertValid ("random build " <> show index) triangulation+    assertEqual "random input mapping" (length points) (sizeofPrimArray (buildInputVertices built))++testErrors :: IO ()+testErrors = do+  assertEqual+    "NaN query x refusal"+    (Left (InvalidPointX CoordinateNaN))+    (mkQueryPoint (Point (0 / 0) 0))+  assertEqual+    "infinite query y refusal"+    (Left (InvalidPointY CoordinateInfinite))+    (mkQueryPoint (Point 0 (1 / 0)))+  assertEqual+    "negative-infinite query x refusal"+    (Left (InvalidPointX CoordinateInfinite))+    (mkQueryPoint (Point ((-1) / 0) 0))+  case delaunay unitElementDefaults (V.singleton (Point (0 / 0) 0 :: Point)) of+    Left (InvalidCoordinate (Just 0) _ CoordinateNaN) -> pure ()+    Left other -> fail ("NaN insertion result: " <> show other)+    Right built ->+      fail+        ( "NaN insertion result: built a triangulation of "+            <> show (numVertices (buildTriangulation built))+            <> " vertices"+        )+  expectBuildFailure+    "NaN minimum angle"+    (RefinementMinimumAngleNotFinite ValueNaN)+    (withMinimumAngle (0 / 0 :: Double) defaultRefinementParameters)+  expectBuildFailure+    "infinite minimum angle"+    (RefinementMinimumAngleNotFinite ValuePositiveInfinity)+    (withMinimumAngle (1 / 0 :: Double) defaultRefinementParameters)+  expectBuildFailure+    "out-of-range minimum angle"+    (RefinementMinimumAngleOutOfRange 61)+    (withMinimumAngle (61 :: Double) defaultRefinementParameters)+  expectBuildFailure+    "minimum angle whose derived ratio overflows"+    (RefinementMinimumAngleDerivedRatioNotFinite ValuePositiveInfinity)+    (withMinimumAngle (encodeFloat 1 (-1074) :: Double) defaultRefinementParameters)+  square <- requirePointBuild "area validation square" [Point 0 0, Point 1 0, Point 1 1, Point 0 1]+  let refineWith parameters =+        refine id parameters (buildTriangulation square)+      refineWithArea area =+        refineWith defaultRefinementParameters{refineMaxArea = Just area}+  expectBuildFailure+    "negative refinement vertex budget"+    (RefinementMaximumAdditionalVerticesNegative (-1))+    (refineWith defaultRefinementParameters{refineMaxAdditionalVertices = Just (-1)})+  expectBuildFailure+    "infinite minimum area"+    (RefinementMinimumAreaNotFinite ValuePositiveInfinity)+    (refineWith defaultRefinementParameters{refineMinArea = Just (1 / 0)})+  expectBuildFailure+    "negative minimum area"+    (RefinementMinimumAreaNegative (-1))+    (refineWith defaultRefinementParameters{refineMinArea = Just (-1)})+  expectBuildFailure+    "NaN maximum area"+    (RefinementMaximumAreaNotFinite ValueNaN)+    (refineWithArea (0 / 0))+  expectBuildFailure+    "infinite maximum area"+    (RefinementMaximumAreaNotFinite ValuePositiveInfinity)+    (refineWithArea (1 / 0))+  expectBuildFailure+    "zero maximum area"+    (RefinementMaximumAreaNotPositive 0)+    (refineWithArea 0)+  expectBuildFailure+    "negative maximum area"+    (RefinementMaximumAreaNotPositive (-1))+    (refineWithArea (-1))+  expectBuildFailure+    "infinite maximum radius/edge ratio"+    (RefinementMaximumRadiusEdgeRatioNotFinite ValuePositiveInfinity)+    (refineWith defaultRefinementParameters{refineMaxRadiusEdgeRatio = Just (1 / 0)})+  expectBuildFailure+    "non-positive maximum radius/edge ratio"+    (RefinementMaximumRadiusEdgeRatioNotPositive 0)+    (refineWith defaultRefinementParameters{refineMaxRadiusEdgeRatio = Just 0})+  expectBuildFailure+    "minimum area above maximum area"+    (RefinementMinimumAreaExceedsMaximum 2 1)+    ( refineWith+        defaultRefinementParameters+          { refineMinArea = Just 2+          , refineMaxArea = Just 1+          }+    )+  case refineWithArea 0.25 of+    Right _ -> pure ()+    Left failure -> fail ("positive maximum area rejected: " <> show failure)++expectBuildFailure :: String -> BuildError -> Either BuildError value -> IO ()+expectBuildFailure label expected outcome =+  case outcome of+    Left actual -> assertEqual label expected actual+    Right _ -> fail (label <> ": expected " <> show expected <> ", got success")+++canonicalEdges+  :: Triangulation mode vertex directed undirected face+  -> Set.Set (Point, Point)+canonicalEdges triangulation =+  Set.fromList+    [ ordered (vertexPoint triangulation (origin triangulation edge)) (vertexPoint triangulation (destination triangulation edge))+    | undirected <- undirectedEdges triangulation+    , let edge = normalizedDirected undirected+    ]+ where+  ordered :: Ord value => value -> value -> (value, value)+  ordered left right = if left <= right then (left, right) else (right, left)++requireJust :: String -> Maybe value -> IO value+requireJust _ (Just value) = pure value+requireJust label Nothing = fail (label <> ": expected Just")++requireAcceptedConstraint+  :: String+  -> ConstraintBatchResult vertex directed undirected face+  -> IO (V.Vector DirectedEdgeId, Int)+requireAcceptedConstraint label batch =+  case V.toList (constraintBatchOutcomes batch) of+    [ConstraintAccepted path added] -> pure (path, added)+    outcomes ->+      fail+        ( label+            <> ": expected one accepted constraint, got "+            <> show outcomes+        )++assertBatchStats+  :: String+  -> ConstraintBatchResult vertex directed undirected face+  -> IO ()+assertBatchStats label batch = do+  let stats = constraintBatchStats batch+      (accepted, rejected) =+        V.foldl'+          (\(!acceptedCount, !rejectedCount) outcome ->+            case outcome of+              ConstraintAccepted _ _ -> (acceptedCount + 1, rejectedCount)+              ConstraintRejected _ -> (acceptedCount, rejectedCount + 1)+          )+          (0, 0)+          (constraintBatchOutcomes batch)+  assertEqual+    (label <> " request count")+    (V.length (constraintBatchOutcomes batch))+    (constraintBatchRequests stats)+  assertEqual+    (label <> " accepted count")+    accepted+    (constraintBatchAccepted stats)+  assertEqual+    (label <> " rejected count")+    rejected+    (constraintBatchRejected stats)++replayConstraintRequest+  :: (ConstrainedDelaunayTriangulation (Point), [ConstraintOutcome])+  -> (VertexId, VertexId)+  -> Either+      (CdtError)+      (ConstrainedDelaunayTriangulation (Point), [ConstraintOutcome])+replayConstraintRequest (current, outcomes) request = do+  singleton <- recoverConstraints current (V.singleton request)+  case V.toList (constraintBatchOutcomes singleton) of+    [outcome] ->+      Right+        ( constraintBatchTriangulation singleton+        , outcome : outcomes+        )+    cardinality ->+      Left+        ( ConstraintBatchCardinalityMismatch+            1+            (length cardinality)+        )++requirePointBuild :: String -> [Point] -> IO (BuildResult 'Unconstrained (Point) () () ())+requirePointBuild label points = requireRight label (delaunay unitElementDefaults (V.fromList points))++assertCdtValid :: String -> Triangulation 'Constrained vertex () () () -> IO ()+assertCdtValid label triangulation =+  case validateTriangulation triangulation of+    [] -> pure ()+    violations -> fail (label <> " CDT violations: " <> show violations)++assertNear :: String -> Double -> Double -> Double -> IO ()+assertNear label tolerance expected actual =+  unless (abs (expected - actual) <= tolerance * max 1 (max (abs expected) (abs actual))) $+    fail (label <> ": expected " <> show expected <> ", got " <> show actual)++gridPoints :: Int -> Int -> [Point]+gridPoints width height =+  [ Point (fromIntegral x + jitter x y) (fromIntegral y + jitter y x)+  | y <- [0 .. height - 1]+  , x <- [0 .. width - 1]+  ]+ where+  jitter :: Int -> Int -> Double+  jitter a b = fromIntegral ((a * 17 + b * 31) `mod` 11) * 1.0e-5++randomPoints :: Word64 -> Int -> [Point]+randomPoints seed count = take count (go seed Set.empty)+ where+  go :: Word64 -> Set.Set (Point) -> [Point]+  go state seen =+    let state1 = lcg state+        state2 = lcg state1+        x = unit state1 * 2 - 1+        y = unit state2 * 2 - 1+        point = Point x y+     in if Set.member point seen+          then go state2 seen+          else point : go state2 (Set.insert point seen)++  unit :: Word64 -> Double+  unit value = fromIntegral (value `mod` 9_007_199_254_740_881) / 9_007_199_254_740_881++  lcg :: Word64 -> Word64+  lcg value = value * 6_364_136_223_846_793_005 + 1_442_695_040_888_963_407
+ test/parallel/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.ParallelSpec as ParallelSpec++main :: IO ()+main = ParallelSpec.tests
+ test/parallel/Moonlight/Triangulation/ParallelSpec.hs view
@@ -0,0 +1,72 @@+-- | The one module in the package that spawns threads. Its whole contract is+-- that scheduling is invisible: the same tournament, the same value, at every+-- worker count. That is what is asserted here, because a concurrent join whose+-- result depended on the worker count would be wrong in a way no amount of+-- validity checking on a single run could see.+module Moonlight.Triangulation.ParallelSpec+  ( tests+  ) where++import qualified Data.List.NonEmpty as NE+import Moonlight.Triangulation (unions)+import Moonlight.Triangulation.AlgebraFixtures (Mesh, assertMesh, operands)+import Moonlight.Triangulation.Parallel (unionsConcurrently)+import Support (requireRight)++tests :: IO ()+tests = do+  testConcurrentJoinAgreesWithSequential+  testConcurrentJoinIsWorkerCountInvariant+  putStrLn "parallel: ok"++-- Counts on both sides of the operand count, so the tournament is starved at+-- one end and saturated at the other, and 1 exercises the sequential-collapse+-- branch that a purely concurrent test would never reach.+workerCounts :: [Int]+workerCounts = [1, 2, 3, 5, 16]++concurrentJoin :: Int -> NE.NonEmpty Mesh -> IO Mesh+concurrentJoin workers shards = do+  outcome <- unionsConcurrently workers shards+  requireRight ("concurrent unions at " <> show workers <> " workers") outcome++-- The sequential tournament is the oracle. It is a different interpreter over+-- the same plan, not a second copy of this one, so agreement is evidence.+testConcurrentJoinAgreesWithSequential :: IO ()+testConcurrentJoinAgreesWithSequential = do+  shards <- fmap (map snd) operands+  nonEmptyShards <- case NE.nonEmpty shards of+    Nothing -> fail "concurrent join agreement: no operands"+    Just present -> pure present+  sequential <- requireRight "sequential unions" (unions shards)+  mapM_+    ( \workers -> do+        concurrent <- concurrentJoin workers nonEmptyShards+        assertMesh+          ("concurrent tournament at " <> show workers <> " workers")+          sequential+          concurrent+    )+    workerCounts++-- Stated separately from agreement: even if both interpreters were wrong in+-- the same way, a result that moved with the worker count would still be a+-- defect, and this is the assertion that would catch it.+testConcurrentJoinIsWorkerCountInvariant :: IO ()+testConcurrentJoinIsWorkerCountInvariant = do+  shards <- fmap (map snd) operands+  nonEmptyShards <- case NE.nonEmpty shards of+    Nothing -> fail "worker-count invariance: no operands"+    Just present -> pure present+  results <- traverse (`concurrentJoin` nonEmptyShards) workerCounts+  case results of+    [] -> fail "worker-count invariance: no worker counts"+    (reference : rest) ->+      mapM_+        ( \(workers, result) ->+            assertMesh+              ("worker count " <> show workers <> " agrees with the first")+              reference+              result+        )+        (zip (drop 1 workerCounts) rest)
+ test/serialization/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.SerializationSpec as SerializationSpec++main :: IO ()+main = SerializationSpec.tests
+ test/serialization/Moonlight/Triangulation/SerializationSpec.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | The serialization slice: the versioned binary envelope and its refusals.+module Moonlight.Triangulation.SerializationSpec (tests) where++import Control.DeepSeq (NFData)+import Control.Monad (forM_, unless)+import Data.Binary (Binary)+import qualified Data.ByteString.Lazy as BL+import qualified Data.Vector as V+import GHC.Generics (Generic)+import Moonlight.Triangulation+import Moonlight.Triangulation.Serialization+import Support (assertEqual, assertValid, requireRight)++tests :: IO ()+tests = do+  testRoundTrip+  testIndependentPayloadGeometryRoundTrip+  testPointPayloadRoundTrip+  testRejectsCorruption+  putStrLn "all serialization tests passed"++data SerialVertex = SerialVertex+  { serialPosition :: !(Point)+  , serialLabel :: !Int+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData, Binary)++instance HasPosition SerialVertex where+  position = serialPosition++type SerialTriangulation = Triangulation 'Unconstrained SerialVertex Int Bool String++source :: IO SerialTriangulation+source = do+  let defaults = ElementDefaults (3 :: Int) True ("face" :: String)+      payloads =+        V.fromList+          [ SerialVertex (Point 0 0) 10+          , SerialVertex (Point 2 0) 20+          , SerialVertex (Point 0 2) 30+          , SerialVertex (Point 0.5 0.5) 40+          ]+  buildTriangulation <$> requireRight "serialization source" (delaunay defaults payloads)++testRoundTrip :: IO ()+testRoundTrip = do+  original <- source+  let bytes = encodeTriangulation original+  unless (BL.length bytes > 0) $ fail "serialization produced an empty payload"+  roundTrip <- requireRight "serialization round trip" (decodeTriangulation bytes :: Either SerializationError SerialTriangulation)+  assertEqual "serialization equality" original roundTrip+  assertValid "serialization round trip" roundTrip++-- Vertex payload positions are annotations after ingestion. Serialization must+-- therefore preserve the fixed geometry and the independently edited payload,+-- rather than letting the latter reauthor the former on decode.+testIndependentPayloadGeometryRoundTrip :: IO ()+testIndependentPayloadGeometryRoundTrip = do+  geometry <- source+  vertex <- case vertices geometry of+    (first : _) -> pure first+    [] -> fail "independent payload fixture has no vertices"+  let independentPayload = SerialVertex (Point 91 73) 1010+      original = setVertexData geometry vertex independentPayload+      positionless = mapVertices serialLabel original+  assertEqual "independent payload leaves geometry fixed"+    (vertexPoint geometry vertex) (vertexPoint original vertex)+  assertEqual "independent payload position is stored"+    (Point 91 73) (serialPosition (vertexData original vertex))+  roundTrip <-+    requireRight+      "independent payload serialization"+      (decodeTriangulation (encodeTriangulation original) :: Either SerializationError SerialTriangulation)+  assertEqual "independent geometry, payload, and topology round trip" original roundTrip+  assertValid "independent payload serialization" roundTrip+  positionlessRoundTrip <-+    requireRight+      "positionless payload serialization"+      (decodeTriangulation (encodeTriangulation positionless) :: Either SerializationError (Triangulation 'Unconstrained Int Int Bool String))+  assertEqual "positionless payload round trip" positionless positionlessRoundTrip+  assertValid "positionless payload serialization" positionlessRoundTrip++testPointPayloadRoundTrip :: IO ()+testPointPayloadRoundTrip = do+  let points = V.fromList [Point 0 0, Point 2 0, Point 0 2, Point 0.5 0.5] :: V.Vector (Point)+  built <- requireRight "point payload source" (delaunay unitElementDefaults points)+  let geometry = buildTriangulation built+  vertex <- case vertices geometry of+    (first : _) -> pure first+    [] -> fail "point payload fixture has no vertices"+  let original = setVertexData geometry vertex (Point 13 17)+  assertEqual "point payload leaves geometry fixed"+    (vertexPoint geometry vertex) (vertexPoint original vertex)+  assertEqual "point payload is stored"+    (Point 13 17) (vertexData original vertex)+  roundTrip <-+    requireRight+      "point payload serialization"+      (decodeTriangulation (encodeTriangulation original) :: Either SerializationError (Triangulation 'Unconstrained (Point) () () ()))+  assertEqual "point payload serialization equality" original roundTrip+  assertValid "point payload serialization round trip" roundTrip++-- The header is the part of the stream that is structurally constrained: magic,+-- version, constraint mode and coordinate encoding each have exactly one admissible+-- byte pattern, so every mutation of them must be refused. Beyond the header+-- the stream carries payload values, and a byte flipped inside an element+-- payload names a different but entirely legal value — the guarantee there is+-- not refusal but soundness: a decoder that rebuilds its indexes rather than+-- trusting them may never surface a triangulation that violates its invariants,+-- whatever it is fed.+testRejectsCorruption :: IO ()+testRejectsCorruption = do+  original <- source+  let bytes = encodeTriangulation original+      size = BL.length bytes+      headerSize = 8 + 2 + 1 + 1+      decode candidate = decodeTriangulation candidate :: Either SerializationError SerialTriangulation+      flipAt offset =+        BL.concat [BL.take offset bytes, BL.singleton (BL.index bytes offset + 1), BL.drop (offset + 1) bytes]+      rejects :: String -> BL.ByteString -> IO ()+      rejects label candidate =+        case decode candidate of+          Left _ -> pure ()+          Right _ -> fail ("decoder accepted " <> label)+  assertEqual+    "typed trailing-byte refusal"+    (Left (TrailingBytes 1))+    (decode (bytes <> BL.singleton 0))+  case decode (BL.cons 0 (BL.drop 1 bytes)) of+    Left (InvalidFormatMagic _) -> pure ()+    other -> fail ("magic corruption produced " <> show other)+  rejects "an empty payload" BL.empty+  forM_ [1 .. size] $ \dropped ->+    rejects ("a payload truncated by " <> show dropped) (BL.take (size - dropped) bytes)+  forM_ [0 .. headerSize - 1] $ \offset ->+    rejects ("a header byte flipped at offset " <> show offset) (flipAt offset)+  forM_ [headerSize .. size - 1] $ \offset ->+    case decode (flipAt offset) of+      Left _ -> pure ()+      Right decoded ->+        assertValid ("a byte flipped at offset " <> show offset <> " decoded to") decoded
+ test/support/Support.hs view
@@ -0,0 +1,37 @@+-- | Assertions shared by every test slice. Nothing here may depend on an+-- optional package flag, so that the minimal core configuration compiles the+-- same helpers the full configuration does.+module Support+  ( requireRight+  , requireQueryPoint+  , assertEqual+  , assertValid+  ) where++import Control.Monad (unless)+import Moonlight.Triangulation+  ( Point+  , QueryPoint+  , Triangulation+  , mkQueryPoint+  , validateTriangulation+  )++requireRight :: Show error => String -> Either error value -> IO value+requireRight label value = case value of+  Left failure -> fail (label <> ": " <> show failure)+  Right result -> pure result++requireQueryPoint :: String -> Point -> IO (QueryPoint)+requireQueryPoint label = requireRight label . mkQueryPoint++assertEqual :: (Eq value, Show value) => String -> value -> value -> IO ()+assertEqual label expected actual =+  unless (expected == actual) $+    fail (label <> ": expected " <> show expected <> ", got " <> show actual)++assertValid :: String -> Triangulation mode vertex directed undirected face -> IO ()+assertValid label triangulation =+  case validateTriangulation triangulation of+    [] -> pure ()+    violations -> fail (label <> " invariant violations: " <> show violations)
+ weeder.toml view
@@ -0,0 +1,47 @@+roots = [+  '^Main\.main$',+  '^Paths_.*'+]++# Every exposed non-Internal module is public API and therefore a root. The+# exposed Internal modules exist only to connect the package's sublibrary tower;+# their unreachable declarations remain subject to the gate.+root-modules = [+  '^Moonlight\.Triangulation\.Scalar$',+  '^Moonlight\.Triangulation\.LineSideInfo$',+  '^Moonlight\.Triangulation\.Types$',+  '^Moonlight\.Triangulation\.Math$',+  '^Moonlight\.Triangulation\.Interop$',+  '^Moonlight\.Triangulation\.Dcel$',+  '^Moonlight\.Triangulation\.Payload$',+  '^Moonlight\.Triangulation\.JoinSemilattice$',+  '^Moonlight\.Triangulation\.Handles$',+  '^Moonlight\.Triangulation\.Handles\.HandleDefs$',+  '^Moonlight\.Triangulation\.Handles\.Dynamic$',+  '^Moonlight\.Triangulation\.Handles\.Iterators$',+  '^Moonlight\.Triangulation\.Handles\.Iterators\.CircularIterator$',+  '^Moonlight\.Triangulation\.Handles\.Iterators\.DynamicIterators$',+  '^Moonlight\.Triangulation\.Handles\.Iterators\.FixedIterators$',+  '^Moonlight\.Triangulation\.Handles\.Iterators\.HullIterator$',+  '^Moonlight\.Triangulation\.PointLocation$',+  '^Moonlight\.Triangulation\.Validation$',+  '^Moonlight\.Triangulation\.FloodFillIterator$',+  '^Moonlight\.Triangulation\.IntersectionIterator$',+  '^Moonlight\.Triangulation\.BulkLoad$',+  '^Moonlight\.Triangulation\.Removal$',+  '^Moonlight\.Triangulation\.Session$',+  '^Moonlight\.Triangulation\.Cdt$',+  '^Moonlight\.Triangulation\.Refinement$',+  '^Moonlight\.Triangulation\.SetAlgebra$',+  '^Moonlight\.Triangulation\.Parallel$',+  '^Moonlight\.Triangulation\.Serialization$',+  '^Moonlight\.Triangulation\.Voronoi$',+  '^Moonlight\.Triangulation\.Voronoi\.Handles$',+  '^Moonlight\.Triangulation\.Interpolation$',+  '^Moonlight\.Triangulation\.HintGenerator$',+  '^Moonlight\.Triangulation$'+]++root-instances = []+type-class-roots = true+unused-types = true