packages feed

moonlight-triangulation 1.0.1.0 → 1.2.0.0

raw patch · 69 files changed

+13879/−1078 lines, 69 filesdep ~moonlight-triangulation

Dependency ranges changed: moonlight-triangulation

Files

CHANGELOG.md view
@@ -6,6 +6,42 @@ The serialization format carries its own version tag, independent of the package version; any change to it is recorded here explicitly. +## 1.2.0.0++* Add exact rational planar regions and labelled common refinement with one+  provenance-bearing overlay carrier, closed 0-/1-/2-cell Boolean selection,+  and grouped polygon publication through the existing DCEL boundary owner.+* Add exact Euler characteristic and rational area plus symbolic radical length+  expressions with certified outward-rounded binary64 bounds.+* Add linear convex-polygon Minkowski convolution, general polygonal addition,+  and regularized polygonal erosion, opening, closing, offset, and inset through+  the existing CDT and overlay owners.+* Curate the exact region algebra through the main Haskell facade. The C ABI and+  language bindings remain intentionally unchanged.+* Change the binary wire format to version 6 so round trips preserve the vertex+  payload plane's optional fill, including the allocation-free unit payload+  used by geometry-only bulk construction. Version 5 is intentionally+  unsupported rather than decoded into a different resident representation.+* Map the dense-storage circle-sweep obstruction exhaustively at the C boundary+  as obstruction code 55.++## 1.1.0.0++* Add labelled bounded-face components and authoritative component boundaries+  with counter-clockwise outer loops, clockwise holes, exact collinear-vertex+  simplification, and typed pinch obstructions.+* Add exact Delaunay 2-simplex alpha filtration through+  `alphaShapeContainsFace` and the shared admitted `RadiusSquared` type.+* Replace `joinSeparatedConstrainedWith` with+  `joinSeparatedConstrained`; strict separation cannot combine coincident+  annotations, so the dead combiner and old name are gone.+* Change the binary wire format to version 5. Structural section counts now+  occupy one prefix and `decodeTriangulation` requires an explicit+  `DecodingBudget` plus `TrustedPayloadDecoders`, validating counts,+  relationships, packed-index bounds, a fixed-body lower bound, and total+  section elements before allocation while making external decoder trust+  explicit. Version 4 is intentionally unsupported.+ ## 1.0.1.0  * Add the geometry-only `delaunayGeometry` entrance and re-export
README.md view
@@ -10,10 +10,11 @@ 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.+Delaunay triangulation, constrained Delaunay (CDT), exact rational planar+regions and labelled overlay, intrinsic valuations, polygonal Minkowski+morphology, the Voronoi dual, natural-neighbour interpolation, Ruppert+refinement, walk point location, convex hull, exact Shewchuk predicates,+incremental insertion and removal, and versioned binary serialization.  ## Operations @@ -29,6 +30,12 @@ | `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. |+| `overlayLayers` | exact common refinement | One provenance-bearing arrangement whose bounded cells carry both source labels. |+| `overlayClosedUnion` / `overlayClosedIntersection` / `overlayRegularizedDifference` | planar Boolean selection | A closed exact cell set retaining point- and edge-only results; difference is regularized from selected faces. |+| `overlaySelectedRegion` | polygon publication | Selected bounded faces with internal arrangement edges dissolved through the existing boundary walker. |+| `cellValuations` / `regionValuations` | intrinsic measurement | Exact Euler characteristic and rational area plus symbolic radical length with certified bounds. |+| `minkowskiSum` | polygonal convolution | Exact convex or general polygonal Minkowski addition, with work recorded in a receipt. |+| `erodeBy` / `openWith` / `closeWith` | regularized morphology | Full-dimensional polygonal erosion and its opening/closing compositions for an origin-anchored convex kernel. |  ### Choose the operation @@ -45,13 +52,22 @@ | 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. |+| Join two strictly x-separated constrained meshes | `joinSeparatedConstrained` | Separation means annotations are copied, never combined; 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. |+| Partition bounded faces by any caller-owned label | `faceComponents mesh labelFace` | Do not rebuild adjacency outside the DCEL or collapse disconnected regions sharing a label. |+| Recover one component's polygonal boundary | `componentBoundary mesh component` | Do not emit one polygon per triangle; outer and hole loops have canonical winding and exact collinear simplification. |+| Combine two labelled polygon layers | `overlayLayers left right` | Do not run separate clipping engines for union, intersection, and difference; select cells from the one common refinement. |+| Preserve a point- or edge-only Boolean result | `overlayClosedUnion`, `overlayClosedIntersection`, or `overlayRegularizedDifference` | Do not publish immediately as `PlanarRegion`; that carrier is deliberately full-dimensional. |+| Publish a selected polygonal region | `overlaySelectedRegion predicate overlay` | Do not collect arrangement cells independently; selection must precede boundary descent so internal seams disappear. |+| Measure a closed exact selection or region | `cellValuations` or `regionValuations` | Do not coerce irrational perimeter to an allegedly exact `Double`; inspect its radical expression and certified interval. |+| Expand a polygon by another polygon | `minkowskiSum` or `polygonOffset` | Do not add resident mesh vertices pairwise and rebuild; morphology acts on the represented continuum. |+| Erode, open, or close a polygonal region | `erodeBy`, `openWith`, or `closeWith` | Do not infer a hidden universe or invent lower-dimensional polygons; the result is regularized to representable 2D area. |+| Keep Delaunay faces below an alpha threshold | `alphaShapeContainsFace threshold mesh` | This is the filled-face filtration, not palette logic and not a claim to expose every simplex of a full alpha-complex carrier. | | Require construction-independent numbering | `canonicalize` at the observation boundary | Do not canonicalize every intermediate value; it is intentionally global work. |  ## Foreign bindings@@ -87,15 +103,33 @@ | `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` takes 0.169 s. Near-full `intersection` takes 0.116 s and 0.100 s-across the cold and pre-forced contexts. A five-thousand-site-`symmetricDifference` result takes 0.121 s and allocates 244 MB. Exact-`siteRelation` takes 0.083 s and 0.115 s across those contexts. Singleton-insertion takes 5.326 ms. These are raw publication measurements;-`canonicalize` is measured separately when construction-independent numbering-is required.+### Benchmark highlights +Fresh source build on 2026-08-12. The comparison binaries passed exact+canonical-output agreement before seven interleaved fresh-process timing+rounds; brackets are the observed range. Lower is better.++| Operation | Workload | Moonlight | Spade 2.15.1 | Result |+| --- | ---: | ---: | ---: | ---: |+| Removal | remove 125k / 500k sites | 522.067 ms [514.481–539.392] | 16.576 s [15.304–17.308] | **31.75× faster** |+| Removal | remove 25k / 100k sites | 72.164 ms [67.604–78.116] | 360.899 ms [264.639–406.783] | **5.00× faster** median |+| Natural-neighbour interpolation | 2k queries / 400k sites | 192.792 ms [178.064–201.805] | 233.688 ms [214.695–250.986] | **1.21× faster** |+| Incremental insertion | 500k sites | 33.403 s [32.592–36.813] | 30.506 s [28.809–31.688] | within **1.09×** |++Spade exposes no public triangulation set algebra corresponding to these+operations. Their independently witnessed Moonlight publication costs are:++| Operation | Workload | Moonlight |+| --- | ---: | ---: |+| `siteRelation` | 1m sites vs 995k retained | **96.759 ms** |+| `intersection` | retain 995k / 1m sites | **109.513 ms** |+| `symmetricDifference` | publish the 5k-site exclusive result | **119.298 ms** |+| `difference` | remove 5k / 1m sites | **129.820 ms** |+| `union` | add 5k / 5m sites | **130.295 ms** |++These are raw publication measurements. `canonicalize` remains a separate,+explicit observation when construction-independent numbering is required.+ ```haskell union :: JoinSemilattice annotation       => Triangulation 'Unconstrained annotation () () ()@@ -149,13 +183,27 @@ * 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.+  `Moonlight.Triangulation.Serialization` to reach it. Its canonical decoder+  requires both a `DecodingBudget` and explicit `TrustedPayloadDecoders`; wire+  format 6 validates one structural count prefix before decoding defaults,+  payloads, or allocating a section, and preserves the vertex payload plane's+  optional fill. The budget covers the input envelope and every module-owned+  container. `trustedBinaryPayloadDecoders` records the separate caller+  decision that the selected executable `Binary` decoders have an acceptable+  internal resource policy. Version 5 is intentionally unsupported.+* Resident triangulation coordinates are binary64. Exact planar-region APIs use+  normalized rational `ExactPoint`s; an admitted `OverlayResult` seals those+  authoritative coordinates beside one certified binary64 DCEL projection.+  `vertexPoints` and `innerFaceVertexTriples` still project the resident DCEL+  directly; callers do not reconstruct a sibling mesh DTO. * One half-edge mesh underneath. `Cdt` is a mode index on it, not a second   structure. +The Haskell facade carries the exact region, overlay, valuation, and morphology+algebra. `ExactCellSet` preserves closed point, edge, and face selections;+`PlanarRegion` is its full-dimensional polygonal publication. The C ABI and+Python, TypeScript, and Rust bindings carry the immutable binary64 mesh surface.+ ## Use  A triangulation is a value of its site set: construction returns `Either` with@@ -264,20 +312,24 @@  ### 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.+When no boundary is known, classify the Delaunay faces and let the DCEL descend+them. `faceComponents` evaluates the caller's label once per bounded face and+keeps disconnected regions distinct even when their labels compare equal.+`componentBoundary` then returns one counter-clockwise outer loop and clockwise+hole loops, dropping a boundary vertex only when the library's exact+orientation predicate proves it collinear and the point lies on the closed+neighbour segment. A point pinch is a typed `BoundaryPinch`, never an invented+polygon. +For alpha-shape work the supplied label is simply+`alphaShapeContainsFace threshold mesh`. `mkRadiusSquared` admits the+finite non-negative threshold and exact dyadic comparison makes membership+closed at equality. This is the face, or 2-simplex, filtration; it does not manufacture a second mesh or+pretend to own palette, colour-space, or rendering policy.+ ```haskell module Main where -import Data.List (sort, span) import GHC.Exts (fromList) import Moonlight.Triangulation @@ -296,41 +348,118 @@       (fail . show)       pure       (delaunayGeometry (fromList [Point x y | (x, y) <- pts]))-  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)+  threshold <- either (fail . show) pure (mkRadiusSquared 0.4)+  let components = faceComponents mesh (alphaShapeContainsFace threshold mesh)+      kept = [(label, component) | (label, component) <- components, label]+  boundaries <-+    traverse+      (either (fail . show) pure . componentBoundary mesh . snd)+      kept+  print+    [ ( length (boundaryLoopVertices (regionBoundaryOuterLoop boundary))+      , length (regionBoundaryHoleLoops boundary)+      )+    | boundary <- boundaries+    ] ``` -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 numeric threshold remains application policy; the circumradius calculation,+face adjacency, loop extraction, winding, holes, and exact simplification do+not. 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. +### Exact overlay, valuations, and morphology++Author polygonal regions with rational coordinates, refine labelled layers+once, and select every Boolean from that common arrangement. Closed selection+retains zero- and one-dimensional intersections; polygon publication dissolves+all arrangement edges internal to the selected faces.++Valuations read either carrier. Euler characteristic and area remain exact,+while Euclidean length is a normalized radical expression with certified+binary64 bounds. Minkowski addition, offset, erosion, opening, and closing then+compose over the same admitted `PlanarRegion`.++```haskell+module Main where++import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Map.Strict as Map+import Moonlight.Triangulation++admit :: Show obstruction => Either obstruction value -> IO value+admit = either (fail . show) pure++rectangleLoop :: Integer -> Integer -> Integer -> Integer -> IO ExactLoop+rectangleLoop minimumX minimumY maximumX maximumY =+  admit+    ( exactLoop+        ( exactPoint (fromInteger minimumX) (fromInteger minimumY)+            :| [ exactPoint (fromInteger maximumX) (fromInteger minimumY)+               , exactPoint (fromInteger maximumX) (fromInteger maximumY)+               , exactPoint (fromInteger minimumX) (fromInteger maximumY)+               ]+        )+    )++rectangleRegion :: Integer -> Integer -> Integer -> Integer -> IO PlanarRegion+rectangleRegion minimumX minimumY maximumX maximumY = do+  outer <- rectangleLoop minimumX minimumY maximumX maximumY+  component <- admit (polygonComponent outer [])+  admit (planarRegion [component])++insideLayer :: PlanarRegion -> IO (PlanarLayer Bool)+insideLayer region = admit (planarLayer False (Map.singleton True region))++cellSummary :: ExactCellSet -> IO (Int, Integer, Integer, CertifiedInterval)+cellSummary cells = do+  values <- admit (cellValuations cells)+  perimeter <- admit (cellSetPerimeter cells)+  let area = exactAreaValue (valuationArea values)+  pure+    ( eulerCharacteristicValue (valuationEuler values)+    , exactRationalNumerator area+    , exactRationalDenominator area+    , exactLengthBounds perimeter+    )++regionArea :: PlanarRegion -> IO (Integer, Integer)+regionArea region = do+  values <- admit (regionValuations region)+  let area = exactAreaValue (valuationArea values)+  pure (exactRationalNumerator area, exactRationalDenominator area)++main :: IO ()+main = do+  left <- rectangleRegion 0 0 4 4+  right <- rectangleRegion 2 1 6 3+  leftLayer <- insideLayer left+  rightLayer <- insideLayer right+  overlay <- admit (overlayLayers leftLayer rightLayer)++  unionCells <- admit (overlayClosedUnion id id overlay)+  intersectionCells <- admit (overlayClosedIntersection id id overlay)+  differenceCells <- admit (overlayRegularizedDifference id id overlay)+  traverse cellSummary [unionCells, intersectionCells, differenceCells]+    >>= print++  kernelLoop <- rectangleLoop (-1) (-1) 1 1+  kernel <- admit (convexPolygon (exactLoopPoints kernelLoop)) >>= admit . structuringElement+  (sumRegion, _) <- admit (minkowskiSum left right)+  (offsetRegion, _) <- admit (polygonOffset kernel left)+  (insetRegion, _) <- admit (polygonInset kernel left)+  (openedRegion, _) <- admit (openWith kernel left)+  (closedRegion, _) <- admit (closeWith kernel left)+  traverse regionArea [sumRegion, offsetRegion, insetRegion, openedRegion, closedRegion]+    >>= print+```++The Boolean summaries are union `(χ = 1, area = 20, perimeter = 20)`,+intersection `(1, 4, 8)`, and regularized difference `(1, 12, 20)`. The+morphology areas are `(48, 36, 4, 16, 16)`: Minkowski sum, one-unit square+offset, inset, opening, and closing respectively.+ ## The growing city  A triangulation is a value so that a large one can be extended without being@@ -373,10 +502,10 @@ ## 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.+decoded and aligned to a common exponent, with bounded predicates evaluated in+machine words and larger cases over `Integer`. Floating approximations are+trusted only inside proved error bounds and fall through to exact evaluation+otherwise.  ## Public sublibraries @@ -387,8 +516,8 @@ | 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`. |+| `dcel` | The finite half-edge mesh and its whole read surface: `Types`, `Math`, exact geometry, closed `CellSet`, `Region`, `Valuation`, `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, `Overlay`, `Minkowski`, 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`. |@@ -400,7 +529,13 @@ * `.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.+* `.IntersectionIterator`, `.FloodFillIterator` — ordered line traversal,+  barrier fill, labelled face components, boundary loops, and alpha-face+  filtration.+* `.Exact`, `.CellSet`, `.Region`, `.Valuation` — exact rational geometry,+  closed cell selections, admitted polygonal regions, and intrinsic measures.+* `.Overlay`, `.Minkowski` — labelled common refinement, planar Booleans,+  polygonal convolution, offset, erosion, opening, and closing. * `.Voronoi`, `.Interpolation` — dual cells and natural-neighbour interpolation. * `.Refinement` — Ruppert-style angle and area refinement. * `.Validation` — structural and Delaunay-property audits.
bench/aggregate/Main.hs view
@@ -8,6 +8,7 @@ import qualified Moonlight.Triangulation.DcelBench as DcelBench import qualified Moonlight.Triangulation.DualBench as DualBench import qualified Moonlight.Triangulation.JoinBench as JoinBench+import qualified Moonlight.Triangulation.RegionBench as RegionBench  main :: IO () main = do@@ -15,3 +16,4 @@   DcelBench.benchmarks   DualBench.benchmarks   JoinBench.benchmarks+  RegionBench.benchmarks
bench/dcel/Moonlight/Triangulation/DcelBench.hs view
@@ -1,13 +1,18 @@ {-# 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 BenchSupport+  ( latticeFaceBand+  , latticePoints+  , randomPoints+  , requireRight+  , timedValue+  ) import Control.DeepSeq (force) import Control.Exception (evaluate) import qualified Data.Vector as V@@ -16,7 +21,9 @@ import Moonlight.Triangulation.IntersectionIterator (lineIntersections)  benchmarks :: IO ()-benchmarks = benchmarkQueries 20_000 10_000+benchmarks = do+  benchmarkQueries 20_000 10_000+  benchmarkRegionWorkload 440 272 22  benchmarkQueries :: Int -> Int -> IO () benchmarkQueries pointCount queryCount = do@@ -41,3 +48,91 @@     -> Int   lineCount triangulation queries stride !accumulator index from =     accumulator + length (lineIntersections triangulation from (queries V.! (index + stride)))++-- | The workload that motivated region extraction: 239,360 bounded faces.+-- Construction is shared fixture cost and is forced before either timed lane.+benchmarkRegionWorkload :: Int -> Int -> Int -> IO ()+benchmarkRegionWorkload widthInCells heightInCells expectedBandCount = do+  built <-+    requireRight+      (delaunay unitElementDefaults (latticePoints widthInCells heightInCells))+  triangulation <- evaluate (force (buildTriangulation built))+  benchmarkRegionBoundaries triangulation expectedBandCount+  benchmarkAlphaFaceMembership triangulation++benchmarkRegionBoundaries :: DelaunayTriangulation Point -> Int -> IO ()+benchmarkRegionBoundaries triangulation expectedBandCount = do+  analysed <-+    timedValue+      "face-components-and-boundaries"+      (evaluate (force (regionAnalysis triangulation)))+  (components, boundaries) <- requireRight analysed+  let faceCount = sum (fmap (length . faceComponentFaces . snd) components)+      outerLoopCount = length boundaries+      holeLoopCount =+        sum (fmap (length . regionBoundaryHoleLoops) boundaries)+      boundaryVertexCount =+        sum+          ( fmap+              (length . boundaryLoopVertices . regionBoundaryOuterLoop)+              boundaries+          )+  if+    ( faceCount+    , length components+    , outerLoopCount+    , holeLoopCount+    , boundaryVertexCount+    )+      == (239_360, expectedBandCount, expectedBandCount, 0, 88)+    then+      putStrLn+        "face-components-and-boundaries-receipt: faces=239360 components=22 outer-loops=22 hole-loops=0 boundary-vertices=88"+    else+      fail+        ( "region benchmark receipt mismatch: "+            <> show+              ( faceCount+              , length components+              , outerLoopCount+              , holeLoopCount+              , boundaryVertexCount+              )+        )+ where+  regionAnalysis+    :: DelaunayTriangulation Point+    -> Either+        BoundaryObstruction+        ([(Int, FaceComponent)], [RegionBoundary])+  regionAnalysis mesh = do+    let components = faceComponents mesh (latticeFaceBand mesh)+    boundaries <-+      traverse+        (componentBoundary mesh . snd)+        components+    pure (components, boundaries)++benchmarkAlphaFaceMembership :: DelaunayTriangulation Point -> IO ()+benchmarkAlphaFaceMembership triangulation = do+  threshold <- requireRight (mkRadiusSquared 0.5)+  let containsFace = alphaShapeContainsFace threshold triangulation+  admittedCount <-+    timedValue+      "alpha-face-membership"+      ( evaluate+          ( force+              ( foldl'+                  (\count face ->+                     if containsFace face+                       then count + 1+                       else count+                  )+                  (0 :: Int)+                  (innerFaces triangulation)+              )+          )+      )+  if admittedCount == 239_360+    then putStrLn "alpha-face-membership-receipt: admitted=239360"+    else fail ("alpha face membership receipt mismatch: " <> show admittedCount)
+ bench/region/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.RegionBench as RegionBench++main :: IO ()+main = RegionBench.benchmarks
+ bench/region/Moonlight/Triangulation/RegionBench.hs view
@@ -0,0 +1,444 @@+{-# LANGUAGE NumericUnderscores #-}++-- | Exact segment-event, overlay, and grouped-region publication receipts.+-- The source families are closed data; measurement is the only effect.+module Moonlight.Triangulation.RegionBench (benchmarks) where++import BenchSupport+  ( latticeFaceBand+  , latticePoints+  , requireRight+  , timedValue+  )+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Data.Foldable (traverse_)+import qualified Data.Map.Strict as Map+import Data.List.NonEmpty (NonEmpty (..))+import Moonlight.Triangulation+  ( buildTriangulation+  , delaunay+  , unitElementDefaults+  )+import Moonlight.Triangulation.CellSet+  ( exactCellSet+  , exactCellSetEdgeCount+  , exactCellSetFaceCount+  , exactCellSetVertexCount+  )+import Moonlight.Triangulation.Dcel (numInnerFaces)+import Moonlight.Triangulation.Exact (ExactPoint, exactPoint)+import Moonlight.Triangulation.Handles.HandleDefs (VertexId (..))+import Moonlight.Triangulation.Overlay+  ( OverlayReceipt (..)+  , overlayClosedIntersection+  , overlayLayers+  , overlayReceipt+  )+import Moonlight.Triangulation.Minkowski+  ( MinkowskiReceipt+  , convexMinkowskiSum+  , convexPolygon+  , erodeBy+  , minkowskiExactCoordinateBitGrowth+  , minkowskiExactCrossings+  , minkowskiGeneratedConvolutionEdges+  , minkowskiGeneratedPieces+  , minkowskiOutputCells+  , minkowskiOverlayPasses+  , minkowskiSum+  , structuringElement+  )+import Moonlight.Triangulation.Region+  ( PlanarLayer+  , PolygonComponent+  , RegionValidationError+  , exactLoop+  , exactLoopPoints+  , labelledPlanarLayer+  , planarLayer+  , planarLayerRegions+  , planarRegion+  , planarRegionComponents+  , polygonComponent+  , polygonHoleLoops+  , polygonOuterLoop+  )+import Moonlight.Triangulation.Valuation+  ( cellValuations+  , eulerCharacteristicValue+  , exactLengthTerms+  , regionValuations+  , valuationEuler+  , valuationIntrinsic1+  , exactLengthExpression+  )++data OverlayFamily+  = DisjointFamily+  | GridCrossingFamily+  | CollinearOverlapFamily+  deriving stock (Eq, Ord, Show)++benchmarks :: IO ()+benchmarks = do+  traverse_+    (\family -> traverse_ (benchmarkOverlayFamily family) [2, 4, 8])+    [DisjointFamily, GridCrossingFamily, CollinearOverlapFamily]+  benchmarkPublicationReceipt+  traverse_ benchmarkRegionAuthoring [64, 256, 1_024]+  traverse_ benchmarkRegionValuation [64, 256, 1_024]+  traverse_ benchmarkConvexMinkowski [8, 32, 128, 512]+  traverse_+    (\family -> traverse_ (benchmarkOverlaySelectorFamily family) [2, 4, 8])+    [DisjointFamily, GridCrossingFamily, CollinearOverlapFamily]+  benchmarkGeneralMorphology++benchmarkOverlayFamily :: OverlayFamily -> Int -> IO ()+benchmarkOverlayFamily family size = do+  layers <- requireRight (familyLayers family size)+  result <-+    timedValue+      (familyName family <> "-n" <> show size)+      (requireRight (uncurry overlayLayers layers))+  let receipt = overlayReceipt result+      inputAndOutput = overlayInputSegments receipt + overlayRelationEvents receipt+      logarithmicScale = max 1 (ceilingLog2 (overlayInputSegments receipt + 1))+      totalLimit = 128 * inputAndOutput * logarithmicScale+  putStrLn+    ( familyName family+        <> "-receipt: n="+        <> show size+        <> " source-segments="+        <> show (overlayInputSegments receipt)+        <> " relation-events-k="+        <> show (overlayRelationEvents receipt)+        <> " exact-relation-checks="+        <> show (overlayTotalRelationChecks receipt)+        <> " atomic-edges="+        <> show (overlayAtomicEdges receipt)+        <> " arrangement-cells="+        <> show (overlayArrangementCells receipt)+        <> " resident-faces="+        <> show (overlayResidentFaces receipt)+        <> " avl-height="+        <> show (overlaySweepMaximumHeight receipt)+    )+  if overlayTotalRelationChecks receipt <= totalLimit+    then pure ()+    else+      fail+        ( familyName family+            <> " retained superlinear total relation work: "+            <> show (overlayTotalRelationChecks receipt, totalLimit)+        )++benchmarkOverlaySelectorFamily :: OverlayFamily -> Int -> IO ()+benchmarkOverlaySelectorFamily family size = do+  layers <- requireRight (familyLayers family size)+  result <- requireRight (uncurry overlayLayers layers)+  selectedReceipt <-+    timedValue+      (familyName family <> "-selector-n" <> show size)+      (do+         selected <-+           requireRight+             (overlayClosedIntersection (== 1) (== 1) result)+         valuations <- requireRight (cellValuations selected)+         pure+           ( exactCellSetVertexCount selected+           , exactCellSetEdgeCount selected+           , exactCellSetFaceCount selected+           , eulerCharacteristicValue (valuationEuler valuations)+           , length+               ( exactLengthTerms+                   (exactLengthExpression (valuationIntrinsic1 valuations))+               )+           ))+  putStrLn+    ( familyName family+        <> "-selector-receipt: n="+        <> show size+        <> " cells="+        <> show selectedReceipt+    )++familyName :: OverlayFamily -> String+familyName DisjointFamily = "overlay-disjoint"+familyName GridCrossingFamily = "overlay-grid-crossing"+familyName CollinearOverlapFamily = "overlay-collinear-overlap"++benchmarkRegionAuthoring :: Int -> IO ()+benchmarkRegionAuthoring size = do+  componentCount <-+    timedValue+      ("planar-region-disjoint-authoring-n" <> show size)+      (requireRight $ do+         components <-+           traverse+             rectangleComponent+             [ (3 * index, 0, 3 * index + 1, 1)+             | index <- [0 .. size - 1]+             ]+         length . planarRegionComponents <$> planarRegion components)+  if componentCount == size+    then+      putStrLn+        ( "planar-region-disjoint-authoring-receipt: n="+            <> show size+            <> " components="+            <> show componentCount+        )+    else fail ("planar region authoring lost components: " <> show componentCount)++benchmarkRegionValuation :: Int -> IO ()+benchmarkRegionValuation size = do+  components <-+    requireRight+      ( traverse+          rectangleComponent+          [ (3 * index, 0, 3 * index + 1, 1)+          | index <- [0 .. size - 1]+          ]+      )+  region <- requireRight (planarRegion components)+  valuations <-+    timedValue+      ("planar-region-valuations-n" <> show size)+      (evaluate . force =<< requireRight (regionValuations region))+  let receipt =+        ( eulerCharacteristicValue (valuationEuler valuations)+        , length+            ( exactLengthTerms+                (exactLengthExpression (valuationIntrinsic1 valuations))+            )+        )+  if receipt == (size, 1)+    then+      putStrLn+        ( "planar-region-valuations-receipt: n="+            <> show size+            <> " euler="+            <> show size+            <> " radical-terms=1"+        )+    else fail ("planar region valuation receipt mismatch: " <> show receipt)++benchmarkConvexMinkowski :: Int -> IO ()+benchmarkConvexMinkowski halfSize = do+  left <- requireRight (convexPolygon (convexLens halfSize))+  right <- requireRight (convexPolygon (convexLens halfSize))+  result <-+    timedValue+      ("convex-minkowski-n" <> show (2 * halfSize))+      (evaluate (force (convexMinkowskiSum left right)))+  let outputVertices =+        sum+          [ length (exactLoopPoints (polygonOuterLoop component))+          | component <- planarRegionComponents result+          ]+      inputVertices = 4 * halfSize+  if outputVertices <= inputVertices+    then+      putStrLn+        ( "convex-minkowski-receipt: input-vertices="+            <> show inputVertices+            <> " output-vertices="+            <> show outputVertices+        )+    else fail ("convex Minkowski output exceeded n+m: " <> show (outputVertices, inputVertices))++benchmarkGeneralMorphology :: IO ()+benchmarkGeneralMorphology = do+  concaveLoop <-+    requireRight+      ( exactLoop+          ( integerPoint 0 0+              :| [ integerPoint 6 0+                 , integerPoint 6 2+                 , integerPoint 2 2+                 , integerPoint 2 6+                 , integerPoint 0 6+                 ]+          )+      )+  concaveComponent <- requireRight (polygonComponent concaveLoop [])+  concaveRegion <- requireRight (planarRegion [concaveComponent])+  kernelComponent <- requireRight (rectangleComponent (-1, -1, 1, 1))+  kernelRegion <- requireRight (planarRegion [kernelComponent])+  kernelPolygon <-+    requireRight+      (convexPolygon (exactLoopPoints (polygonOuterLoop kernelComponent)))+  element <- requireRight (structuringElement kernelPolygon)+  (sumComponents, sumReceipt) <-+    timedValue+      "general-minkowski-concave"+      (do+         (result, receipt) <- requireRight (minkowskiSum concaveRegion kernelRegion)+         pure (length (planarRegionComponents result), receipt))+  printMorphologyReceipt "general-minkowski-concave" sumComponents sumReceipt+  erosionSourceComponents <-+    requireRight+      ( traverse+          rectangleComponent+          [(0, 0, 6, 6), (9, 0, 15, 6)]+      )+  erosionSource <- requireRight (planarRegion erosionSourceComponents)+  (erosionComponents, erosionReceipt) <-+    timedValue+      "general-erosion-disconnected"+      (do+         (result, receipt) <- requireRight (erodeBy element erosionSource)+         pure (length (planarRegionComponents result), receipt))+  printMorphologyReceipt+    "general-erosion-disconnected"+    erosionComponents+    erosionReceipt+  if minkowskiOverlayPasses sumReceipt > 0+      && minkowskiGeneratedPieces sumReceipt > 0+      && minkowskiOverlayPasses erosionReceipt > 0+    then pure ()+    else fail "general morphology bypassed its declared decomposition/overlay work"++printMorphologyReceipt :: String -> Int -> MinkowskiReceipt -> IO ()+printMorphologyReceipt label outputComponents receipt =+  putStrLn+    ( label+        <> "-receipt: output-components="+        <> show outputComponents+        <> " generated-pieces="+        <> show (minkowskiGeneratedPieces receipt)+        <> " convolution-edges="+        <> show (minkowskiGeneratedConvolutionEdges receipt)+        <> " overlay-passes="+        <> show (minkowskiOverlayPasses receipt)+        <> " exact-crossings="+        <> show (minkowskiExactCrossings receipt)+        <> " output-cells="+        <> show (minkowskiOutputCells receipt)+        <> " coordinate-bit-growth="+        <> show (minkowskiExactCoordinateBitGrowth receipt)+    )++convexLens :: Int -> NonEmpty ExactPoint+convexLens halfSize =+  let maximumIndex = max 1 (halfSize - 1)+      height = 2 * maximumIndex * maximumIndex + 1+      lower =+        [ integerPoint index (index * index)+        | index <- [1 .. maximumIndex]+        ]+      upper =+        [ integerPoint index (height - index * index)+        | index <- reverse [0 .. maximumIndex]+        ]+   in integerPoint 0 0 :| (lower <> upper)++familyLayers+  :: OverlayFamily+  -> Int+  -> Either RegionValidationError (PlanarLayer Int, PlanarLayer Int)+familyLayers family size =+  case family of+    DisjointFamily ->+      (,)+        <$> layerFromRectangles+          [ (3 * index, 0, 3 * index + 1, 1)+          | index <- [0 .. size - 1]+          ]+        <*> planarLayer 0 Map.empty+    GridCrossingFamily ->+      (,)+        <$> layerFromRectangles+          [ (3 * index, 0, 3 * index + 1, 3 * size - 1)+          | index <- [0 .. size - 1]+          ]+        <*> layerFromRectangles+          [ (0, 3 * index, 3 * size - 1, 3 * index + 1)+          | index <- [0 .. size - 1]+          ]+    CollinearOverlapFamily ->+      (,)+        <$> layerFromRectangles+          [ (3 * index, 0, 3 * index + 2, 2)+          | index <- [0 .. size - 1]+          ]+        <*> layerFromRectangles+          [ (3 * index + 1, 0, 3 * index + 3, 1)+          | index <- [0 .. size - 1]+          ]++layerFromRectangles+  :: [(Int, Int, Int, Int)]+  -> Either RegionValidationError (PlanarLayer Int)+layerFromRectangles rectangles = do+  components <- traverse rectangleComponent rectangles+  region <- planarRegion components+  planarLayer 0 (Map.singleton 1 region)++rectangleComponent+  :: (Int, Int, Int, Int)+  -> Either RegionValidationError PolygonComponent+rectangleComponent (minimumX, minimumY, maximumX, maximumY) = do+  loop <-+    exactLoop+      ( integerPoint minimumX minimumY+          :| [ integerPoint maximumX minimumY+             , integerPoint maximumX maximumY+             , integerPoint minimumX maximumY+             ]+      )+  polygonComponent loop []++integerPoint :: Int -> Int -> ExactPoint+integerPoint x y =+  exactPoint+    (fromIntegral x)+    (fromIntegral y)++benchmarkPublicationReceipt :: IO ()+benchmarkPublicationReceipt = do+  built <-+    requireRight (delaunay unitElementDefaults (latticePoints 440 272))+  triangulation <- evaluate (force (buildTriangulation built))+  published <-+    timedValue+      "labelled-planar-layer-publication"+      (requireRight (labelledPlanarLayer (-1) triangulation (latticeFaceBand triangulation)))+  let components =+        concatMap planarRegionComponents (Map.elems (planarLayerRegions published))+      holeCount = sum (map (length . polygonHoleLoops) components)+      exactCoordinateCount =+        sum+          [ length (exactLoopPoints (polygonOuterLoop component))+              + sum (map (length . exactLoopPoints) (polygonHoleLoops component))+          | component <- components+          ]+      receipt =+        ( numInnerFaces triangulation+        , length components+        , length components+        , holeCount+        , exactCoordinateCount+        )+  if receipt == (239_360, 22, 22, 0, 88)+    then+      putStrLn+        "labelled-planar-layer-publication-receipt: faces=239360 components=22 outer-loops=22 holes=0 exact-coordinates=88"+    else fail ("labelled planar layer receipt mismatch: " <> show receipt)+  sparseReceipt <-+    timedValue+      "exact-cell-set-sparse-selection"+      (do+         selected <- requireRight (exactCellSet triangulation [VertexId 0] [] [])+         pure+           ( exactCellSetVertexCount selected+           , exactCellSetEdgeCount selected+           , exactCellSetFaceCount selected+           ))+  if sparseReceipt == (1, 0, 0)+    then putStrLn "exact-cell-set-sparse-selection-receipt: vertices=1 edges=0 faces=0"+    else fail ("sparse exact cell selection receipt mismatch: " <> show sparseReceipt)++ceilingLog2 :: Int -> Int+ceilingLog2 target = length (takeWhile (< target) (iterate (* 2) 1))
bench/support/BenchSupport.hs view
@@ -8,14 +8,28 @@   ( timedValue   , requireRight   , randomPoints+  , latticePoints+  , latticeFaceBand   ) where  import Control.DeepSeq (NFData, force) import Control.Exception (evaluate) import Data.Word (Word64)+import qualified Data.Vector as V import GHC.Clock (getMonotonicTimeNSec)-import GHC.Stats (RTSStats (allocated_bytes), getRTSStats, getRTSStatsEnabled)-import Moonlight.Triangulation (Point (Point))+import GHC.Stats+  ( RTSStats (allocated_bytes, max_live_bytes)+  , getRTSStats+  , getRTSStatsEnabled+  )+import Moonlight.Triangulation+  ( FaceId+  , Point (Point)+  , Triangulation+  , faceVertices+  , pointX+  , vertexPoint+  ) import System.CPUTime (getCPUTime)  -- | Both clocks, because they answer different questions and neither@@ -39,7 +53,9 @@   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))+      do+        putStrLn (label <> "-allocated-bytes: " <> show (allocated_bytes right - allocated_bytes left))+        putStrLn (label <> "-max-live-bytes: " <> show (max_live_bytes right))     _ -> pure ()   pure value @@ -58,3 +74,29 @@         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++-- | The canonical large planar-region fixture. Both the DCEL control and the+-- exact publication arm consume this one source rather than quietly drifting+-- into merely similar grids.+latticePoints :: Int -> Int -> V.Vector Point+latticePoints widthInCells heightInCells =+  V.generate+    ((widthInCells + 1) * (heightInCells + 1))+    ( \index ->+        let (row, column) = index `quotRem` (widthInCells + 1)+         in Point (fromIntegral column) (fromIntegral row)+    )++-- | Twenty-column connected face bands used by the frozen 239,360-face+-- publication receipt.+latticeFaceBand+  :: Triangulation mode Point directed undirected face+  -> FaceId+  -> Int+latticeFaceBand triangulation face =+  let xSum =+        foldl'+          (\accumulator vertex -> accumulator + pointX (vertexPoint triangulation vertex))+          0+          (faceVertices triangulation face)+   in floor (xSum / 3) `quot` 20
moonlight-triangulation.cabal view
@@ -1,9 +1,12 @@ cabal-version:       3.4 name:                moonlight-triangulation-version:             1.0.1.0-synopsis:            Delaunay triangulations as a lawful finite-set algebra.+version:             1.2.0.0+synopsis:            Delaunay meshes and exact planar-region algebra. description:         Delaunay and constrained Delaunay triangulation as a lawful-                     finite-set algebra: a mesh is a value of its site set, so+                     finite-set algebra, together with exact rational planar+                     regions, labelled common refinement, intrinsic valuations,+                     and polygonal Minkowski morphology. 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@@ -86,6 +89,7 @@     Moonlight.Triangulation.Scalar     Moonlight.Triangulation.LineSideInfo     Moonlight.Triangulation.Internal.Dyadic+    Moonlight.Triangulation.Internal.ExactRational     Moonlight.Triangulation.Internal.PageDirectory     Moonlight.Triangulation.Internal.Paged     Moonlight.Triangulation.Internal.BoxedPaged@@ -106,6 +110,10 @@   exposed-modules:     Moonlight.Triangulation.Types     Moonlight.Triangulation.Math+    Moonlight.Triangulation.Exact+    Moonlight.Triangulation.CellSet+    Moonlight.Triangulation.Region+    Moonlight.Triangulation.Valuation     Moonlight.Triangulation.Interop     Moonlight.Triangulation.Dcel     Moonlight.Triangulation.Payload@@ -123,6 +131,12 @@     Moonlight.Triangulation.FloodFillIterator     Moonlight.Triangulation.IntersectionIterator     Moonlight.Triangulation.Internal.FaceProbe+    Moonlight.Triangulation.Internal.CellSet+    Moonlight.Triangulation.Internal.BoundaryCycle+    Moonlight.Triangulation.Internal.ExactSegmentEvents+    Moonlight.Triangulation.Internal.Region.Publication+    Moonlight.Triangulation.Internal.Region.Types+    Moonlight.Triangulation.Internal.SegmentRelation     Moonlight.Triangulation.Internal.Types     Moonlight.Triangulation.Internal.Representation     Moonlight.Triangulation.Internal.PointIndex@@ -140,6 +154,8 @@     Moonlight.Triangulation.Internal.DcelOperations.Subdivide     Moonlight.Triangulation.Internal.DcelOperations.Twin     Moonlight.Triangulation.Internal.Canonical+  other-modules:+    Moonlight.Triangulation.Internal.Region.Bounds   build-depends:     base >= 4.20 && < 5     , containers >= 0.8 && < 0.9@@ -153,18 +169,24 @@ library build   import: shared-properties   visibility: public-  hs-source-dirs: src-build+  hs-source-dirs:+    src-build+    src-embedding   exposed-modules:     Moonlight.Triangulation.BulkLoad     Moonlight.Triangulation.Removal     Moonlight.Triangulation.Session     Moonlight.Triangulation.Cdt+    Moonlight.Triangulation.Minkowski+    Moonlight.Triangulation.Overlay     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.Overlay.Arrangement+    Moonlight.Triangulation.Internal.Overlay.Resident     Moonlight.Triangulation.Internal.Join     Moonlight.Triangulation.Internal.Join.Seam   other-modules:@@ -188,6 +210,10 @@     Moonlight.Triangulation.Internal.Join.Plan     Moonlight.Triangulation.Internal.Join.Rebuild     Moonlight.Triangulation.Internal.Join.SiteSet+    Moonlight.Triangulation.Internal.Overlay.Embedding+    Moonlight.Triangulation.Internal.Overlay.Types+    Moonlight.Triangulation.Internal.Minkowski.Convex+    Moonlight.Triangulation.Internal.Minkowski.Types   build-depends:     base >= 4.20 && < 5     , containers >= 0.8 && < 0.9@@ -301,7 +327,7 @@     moonlight_triangulation.h   build-depends:     base >= 4.20 && < 5-    , moonlight-triangulation:ffi >= 1.0 && < 1.1+    , moonlight-triangulation:ffi >= 1.2 && < 1.3   ghc-options: -threaded   if os(windows)     options: standalone@@ -332,9 +358,17 @@   other-modules: Support  common triangulation-native-test-slice+  -- The focused milestone spec reaches into the dedicated @src-embedding@+  -- root for exactly this one hidden certifier. Keeping that source root+  -- singular prevents package modules from becoming duplicate test home modules.+  hs-source-dirs: src-embedding   other-modules:     Moonlight.Triangulation.NativeSpec     Moonlight.Triangulation.FilteredPredicateOptimizationSpec+    Moonlight.Triangulation.ExactEmbeddingSpec+    Moonlight.Triangulation.OverlaySpec+    Moonlight.Triangulation.RegionSpec+    Moonlight.Triangulation.Internal.Overlay.Embedding   -- 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@@ -355,6 +389,7 @@   build-depends:     binary >= 0.8 && < 0.9     , bytestring >= 0.12 && < 0.13+    , moonlight-triangulation:dcel     , moonlight-triangulation:serialize  -- The operand meshes both algebra slices are stated over.  It sits at the@@ -369,6 +404,28 @@   other-modules: Moonlight.Triangulation.AlgebraSpec   build-depends: containers >= 0.8 && < 0.9 +-- Exact planar Boolean laws, stated exclusively through the public facade.+common triangulation-region-algebra-law-slice+  other-modules: Moonlight.Triangulation.RegionAlgebraSpec+  build-depends: containers >= 0.8 && < 0.9++-- Exact intrinsic-volume laws over the resident cell carrier and published+-- region view.+common triangulation-valuation-law-slice+  other-modules: Moonlight.Triangulation.ValuationSpec+  build-depends:+    containers >= 0.8 && < 0.9+    , moonlight-triangulation:core+    , moonlight-triangulation:dcel+    , moonlight-triangulation:build++common triangulation-minkowski-law-slice+  other-modules: Moonlight.Triangulation.MinkowskiSpec+  build-depends:+    moonlight-triangulation:core+    , moonlight-triangulation:dcel+    , moonlight-triangulation:build+ -- 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.@@ -421,6 +478,9 @@     triangulation-test-support-slice,     triangulation-algebra-fixture-slice,     triangulation-algebra-law-slice,+    triangulation-region-algebra-law-slice,+    triangulation-valuation-law-slice,+    triangulation-minkowski-law-slice,     triangulation-algebra-schedule-slice   type: exitcode-stdio-1.0   main-is: Main.hs@@ -463,6 +523,9 @@     triangulation-serialization-test-slice,     triangulation-algebra-fixture-slice,     triangulation-algebra-law-slice,+    triangulation-region-algebra-law-slice,+    triangulation-valuation-law-slice,+    triangulation-minkowski-law-slice,     triangulation-algebra-schedule-slice,     triangulation-parallel-test-slice   type: exitcode-stdio-1.0@@ -519,6 +582,14 @@     moonlight-triangulation:dcel     , moonlight-triangulation:build +common triangulation-region-benchmark-slice+  other-modules: Moonlight.Triangulation.RegionBench+  build-depends:+    containers >= 0.8 && < 0.9+    , moonlight-triangulation:core+    , moonlight-triangulation:dcel+    , moonlight-triangulation:build+ benchmark moonlight-triangulation-build-bench   import:     triangulation-benchmark-properties,@@ -575,6 +646,17 @@     bench/join     bench/support +benchmark moonlight-triangulation-region-bench+  import:+    triangulation-benchmark-properties,+    triangulation-benchmark-support-slice,+    triangulation-region-benchmark-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    bench/region+    bench/support+ benchmark moonlight-triangulation-bench   import:     triangulation-benchmark-properties,@@ -582,7 +664,8 @@     triangulation-build-benchmark-slice,     triangulation-dcel-benchmark-slice,     triangulation-dual-benchmark-slice,-    triangulation-join-benchmark-slice+    triangulation-join-benchmark-slice,+    triangulation-region-benchmark-slice   type: exitcode-stdio-1.0   main-is: Main.hs   hs-source-dirs:@@ -591,4 +674,5 @@     bench/dcel     bench/dual     bench/join+    bench/region     bench/support
src-build/Moonlight/Triangulation/BulkLoad.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -O3 -fllvm -optlo-O3 -optlc-O3 #-}  -- | 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.@@ -24,6 +25,7 @@ import Data.Primitive.PrimArray   ( MutablePrimArray   , newPrimArray+  , readPrimArray   , unsafeFreezePrimArray   , writePrimArray   )@@ -46,7 +48,7 @@   , newOperationState   , setCounter   )-import Moonlight.Triangulation.Internal.CircleSweep (circleSweepInsert)+import Moonlight.Triangulation.Internal.CircleSweep (circleSweepInsert, radiallyOrderArena) import Moonlight.Triangulation.Internal.PointIndex   ( MutablePointIndex   , emptyPointIndex@@ -100,6 +102,13 @@   = KeepFirstPayload   | CombineDuplicatePayload !(vertex -> vertex -> vertex) +-- | The local identity verdict for one input position. A fresh verdict carries+-- the canonical coordinates already admitted to the mutable DCEL, so ingress+-- never rereads its own writes merely to accumulate the sweep centre.+data PositionClaim+  = ResidentPosition !Int+  | FreshPosition !Int !Double !Double+ -- | 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.@@ -109,8 +118,7 @@   => ElementDefaults directed undirected face   -> V.Vector vertex   -> Either BuildError (BuildResult 'Unconstrained vertex directed undirected face)-delaunay defaults input = do-  validateVertices input+delaunay defaults input =   buildDelaunayFromSource     defaults     (V.length input)@@ -125,16 +133,124 @@ delaunayGeometry   :: V.Vector Point   -> Either BuildError (DelaunayTriangulation ())-delaunayGeometry coordinates = do-  V.iforM_ coordinates (\index point -> validatePoint (Just index) point)-  buildTriangulation-    <$> buildDelaunayFromSource+delaunayGeometry coordinates+  | inputCount == 0 = Right (empty unitElementDefaults)+  | otherwise = do+    V.iforM_ coordinates (\index point -> () <$ validatePoint (Just index) point)+    ensureCapacity inputCount+    let !canonicalArena =+          U.generate inputCount $ \index ->+            case coordinates V.! index of+              Point rawX rawY ->+                ( 0+                , canonicalCoordinate rawX+                , canonicalCoordinate rawY+                , fromIntegral index+                )+        (!inputSumX, !inputSumY) =+          U.foldl'+            (\(!sumX, !sumY) (_, x, y, _) -> (sumX + x, sumY + y))+            (0, 0)+            canonicalArena+    runST $ do+      inputArena <- U.unsafeThaw canonicalArena+      let !inputScale = recip (fromIntegral inputCount)+          !inputCenterX = inputSumX * inputScale+          !inputCenterY = inputSumY * inputScale+      assignGeometryRadialDistances inputArena inputCenterX inputCenterY+      orderedInputArena <- radiallyOrderArena inputArena+      defaultedMutable <-+        newMutableDcelWithVertexDefault+          ()           unitElementDefaults-          (V.length coordinates)-          (coordinates V.!)-          (const ())-          KeepFirstPayload+          (planarDcelCapacity inputCount)+      let !mutable = defaultedVertexDcel defaultedMutable+      operation <- newOperationState (halfEdgeCapacity mutable)+      unique <- appendSortedGeometry defaultedMutable inputArena+      orderedArena <-+        if unique == inputCount+          then pure orderedInputArena+          else do+            let !scale = recip (fromIntegral unique)+                !uniqueArena = MUV.unsafeSlice 0 unique inputArena+            (sumX, sumY) <- sumGeometryArena uniqueArena+            recenterGeometryArena+              (sumX * scale)+              (sumY * scale)+              uniqueArena+            radiallyOrderArena uniqueArena+      inserted <- circleSweepInsert mutable operation orderedArena+      case inserted of+        Left failure -> pure (Left failure)+        Right _ -> freezeTriangulation mutable+ where+  !inputCount = V.length coordinates +  assignGeometryRadialDistances+    :: forall s+     . MUV.MVector s (Double, Double, Double, Word32)+    -> Double+    -> Double+    -> ST s ()+  assignGeometryRadialDistances arena centerX centerY =+    MUV.imapM_+      (\index (_, x, y, input) -> do+        let !deltaX = centerX - x+            !deltaY = centerY - y+        MUV.unsafeWrite arena index (deltaX * deltaX + deltaY * deltaY, x, y, input)+      )+      arena++  appendSortedGeometry+    :: forall s+     . DefaultedVertexDcel s () () () ()+    -> MUV.MVector s (Double, Double, Double, Word32)+    -> ST s Int+  appendSortedGeometry defaultedMutable arena+    | inputCount == 0 = pure 0+    | otherwise = do+        (distance, x, y, _) <- MUV.unsafeRead arena 0+        first <- appendDefaultVertexCoordinates defaultedMutable x y+        MUV.unsafeWrite arena 0 (distance, x, y, fromIntegral first)+        (_, _, unique) <-+          MUV.foldM'+            (\(!previousX, !previousY, !uniqueCount) (nextDistance, nextX, nextY, _) ->+               if nextX == previousX && nextY == previousY+                 then pure (previousX, previousY, uniqueCount)+                 else do+                   vertex <- appendDefaultVertexCoordinates defaultedMutable nextX nextY+                   MUV.unsafeWrite arena uniqueCount (nextDistance, nextX, nextY, fromIntegral vertex)+                   pure (nextX, nextY, uniqueCount + 1)+            )+            (x, y, 1)+            (MUV.unsafeSlice 1 (inputCount - 1) arena)+        pure unique++  sumGeometryArena+    :: forall s+     . MUV.MVector s (Double, Double, Double, Word32)+    -> ST s (Double, Double)+  sumGeometryArena arena =+    MUV.foldM'+      (\(!sumX, !sumY) (_, x, y, _) -> pure (sumX + x, sumY + y))+      (0, 0)+      arena++  recenterGeometryArena+    :: forall s+     . Double+    -> Double+    -> MUV.MVector s (Double, Double, Double, Word32)+    -> ST s ()+  recenterGeometryArena centerX centerY arena =+    MUV.imapM_+      (\index (_, x, y, vertex) -> do+        let !deltaX = centerX - x+            !deltaY = centerY - y+        MUV.unsafeWrite arena index (deltaX * deltaX + deltaY * deltaY, x, y, vertex)+      )+      arena+ -- | 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.@@ -148,8 +264,7 @@ delaunayFromCoordinates defaults coordinates payloads duplicatePolicy   | coordinateCount /= payloadCount =       Left (CoordinatePayloadCountMismatch coordinateCount payloadCount)-  | otherwise = do-      V.iforM_ coordinates (\index point -> validatePoint (Just index) point)+  | otherwise =       buildDelaunayFromSource         defaults         coordinateCount@@ -171,28 +286,42 @@ 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+    inputArena <- MUV.new inputCount+    admitted <- initializeInputArena inputArena 0 0 0+    case admitted of       Left failure -> pure (Left failure)-      Right (sumX, sumY) -> do-        unique <- pointCount mutable+      Right (inputSumX, inputSumY) -> do+        let !inputScale = if inputCount == 0 then 0 else recip (fromIntegral inputCount)+            !inputCenterX = inputSumX * inputScale+            !inputCenterY = inputSumY * inputScale+        assignRadialDistances inputArena inputCenterX inputCenterY 0+        orderedInputArena <- radiallyOrderArena inputArena+        mutable <- newMutableDcel defaults (planarDcelCapacity inputCount)+        operation <- newOperationState (halfEdgeCapacity mutable)+        mapping <- newPrimArray inputCount+        unique <- classifySortedInputs mapping inputArena+        (sumX, sumY) <- appendClassifiedInputs mutable mapping 0 0 0+        setCounter operation CounterInputPoints inputCount+        setCounter operation CounterUniquePoints unique+        setCounter operation CounterDuplicatePoints (inputCount - unique)         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+              orderedArena <-+                if unique == inputCount+                  then pure orderedInputArena+                  else do+                    let !scale = recip (fromIntegral unique)+                        !uniqueArena = MUV.unsafeSlice 0 unique inputArena+                    rewriteCompactedArena+                      mapping+                      (sumX * scale)+                      (sumY * scale)+                      uniqueArena+                      0+                    radiallyOrderArena uniqueArena+              circleSweepInsert mutable operation orderedArena         case inserted of           Left failure -> pure (Left failure)           Right seedCount -> do@@ -212,44 +341,138 @@                         }                   )  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+  -- Validate, canonicalize, and materialize each source position in one local+  -- section. The former validation pass and centre fold both traversed the+  -- boxed source before arena generation traversed it a third time; this+  -- section returns their only global invariant, the coordinate sum.+  initializeInputArena     :: forall s-     . MutableDcel s vertex directed undirected face-    -> OperationState s-    -> MutablePointIndex s-    -> MutablePrimArray s Word32+     . MUV.MVector s (Double, Double, Double, Word32)     -> Int     -> Double     -> Double     -> ST s (Either BuildError (Double, Double))-  ingress mutable operation table mapping !index !sumX !sumY+  initializeInputArena arena !index !sumX !sumY     | index >= inputCount = pure (Right (sumX, sumY))+    | otherwise =+        case validatePoint (Just index) (pointAtInput index) of+          Left failure -> pure (Left failure)+          Right admitted ->+            case queryPointValue admitted of+              Point x y -> do+                MUV.unsafeWrite arena index (0, x, y, fromIntegral index)+                initializeInputArena arena (index + 1) (sumX + x) (sumY + y)++  -- The all-input centre seeds the first radial ordering. Duplicate+  -- equivalence classes become adjacent in that total order; after descent,+  -- the compacted section is recentered over unique sites and ordered once+  -- more only when required.+  assignRadialDistances+    :: forall s+     . MUV.MVector s (Double, Double, Double, Word32)+    -> Double+    -> Double+    -> Int+    -> ST s ()+  assignRadialDistances arena centerX centerY !index+    | index >= inputCount = pure ()     | otherwise = do-        addCounter operation CounterInputPoints 1+        (_, x, y, input) <- MUV.unsafeRead arena index+        let !deltaX = centerX - x+            !deltaY = centerY - y+        MUV.unsafeWrite arena index (deltaX * deltaX + deltaY * deltaY, x, y, input)+        assignRadialDistances arena centerX centerY (index + 1)++  -- Classify the sorted local sections by exact canonical position. The+  -- mapping first names each class by its earliest input slot. Compacting the+  -- unique radial representatives in place cannot overwrite an unread slot.+  classifySortedInputs+    :: forall s+     . MutablePrimArray s Word32+    -> MUV.MVector s (Double, Double, Double, Word32)+    -> ST s Int+  classifySortedInputs mapping arena+    | inputCount == 0 = pure 0+    | otherwise = do+        first@(_, firstX, firstY, firstInput) <- MUV.unsafeRead arena 0+        writePrimArray mapping (fromIntegral firstInput) firstInput+        classifyFrom first firstX firstY firstInput 1 1+   where+    classifyFrom !_ !previousX !previousY !classInput !readIndex !uniqueCount+      | readIndex >= inputCount = pure uniqueCount+      | otherwise = do+          record@(_, x, y, input) <- MUV.unsafeRead arena readIndex+          if x == previousX && y == previousY+            then do+              writePrimArray mapping (fromIntegral input) classInput+              classifyFrom record previousX previousY classInput (readIndex + 1) uniqueCount+            else do+              writePrimArray mapping (fromIntegral input) input+              if uniqueCount == readIndex+                then pure ()+                else MUV.unsafeWrite arena uniqueCount record+              classifyFrom record x y input (readIndex + 1) (uniqueCount + 1)++  -- Materialize in original order, preserving the established handle+  -- assignment and duplicate-payload law. The equivalence mapping for a+  -- duplicate always points backward to an already materialized class owner.+  appendClassifiedInputs+    :: forall s+     . MutableDcel s vertex directed undirected face+    -> MutablePrimArray s Word32+    -> Int+    -> Double+    -> Double+    -> ST s (Double, Double)+  appendClassifiedInputs mutable mapping !index !sumX !sumY+    | index >= inputCount = pure (sumX, sumY)+    | otherwise = do+        classInput <- readPrimArray mapping index         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+        if fromIntegral classInput == index+          then case pointAtInput index of+            Point x y -> do+              let !canonicalX = canonicalCoordinate x+                  !canonicalY = canonicalCoordinate y+              vertex <- appendVertexCoordinates mutable canonicalX canonicalY vertexData+              writePrimArray mapping index (fromIntegral vertex)+              appendClassifiedInputs+                mutable+                mapping+                (index + 1)+                (sumX + canonicalX)+                (sumY + canonicalY)+          else do+            resident <- fromIntegral <$> readPrimArray mapping (fromIntegral classInput)+            writePrimArray mapping index (fromIntegral resident)+            case duplicatePolicy of+              KeepFirstPayload -> pure ()+              CombineDuplicatePayload combine -> do+                residentData <- vertexDataAt mutable resident+                writeVertexData mutable resident (combine residentData vertexData)+            appendClassifiedInputs mutable mapping (index + 1) sumX sumY +  -- Once duplicates have shortened the vertex arena, translate each compacted+  -- representative from its input-class name to its authoritative vertex and+  -- restate its radial key around the exact unique-site centre.+  rewriteCompactedArena+    :: forall s+     . MutablePrimArray s Word32+    -> Double+    -> Double+    -> MUV.MVector s (Double, Double, Double, Word32)+    -> Int+    -> ST s ()+  rewriteCompactedArena mapping centerX centerY arena !index+    | index >= MUV.length arena = pure ()+    | otherwise = do+        (_, x, y, classInput) <- MUV.unsafeRead arena index+        vertex <- readPrimArray mapping (fromIntegral classInput)+        let !deltaX = centerX - x+            !deltaY = centerY - y+        MUV.unsafeWrite arena index (deltaX * deltaX + deltaY * deltaY, x, y, vertex)+        rewriteCompactedArena mapping centerX centerY arena (index + 1)+ -- | Insert or replace a vertex payload. A payload at an existing position is -- overwritten without changing topology. --@@ -422,6 +645,11 @@         case filled of           Left failure -> pure (Left failure)           Right (sumX, sumY, freshCount) -> do+            let !existingCount = V.length input - freshCount+            setCounter operation CounterInputPoints (V.length input)+            setCounter operation CounterUniquePoints freshCount+            setCounter operation CounterExistingPoints existingCount+            setCounter operation CounterDuplicatePoints existingCount             inserted <-               if freshCount == 0                 then pure (Right 0)@@ -434,7 +662,8 @@                       (sumY * scale)                       (MUV.unsafeRead freshBuffer)                       freshCount-                  circleSweepInsert mutable operation arena+                  orderedArena <- radiallyOrderArena arena+                  circleSweepInsert mutable operation orderedArena             case inserted of               Left failure -> pure (Left failure)               Right seedCount -> do@@ -469,34 +698,27 @@   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+          Right (FreshPosition vertex canonicalX canonicalY) -> 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+            MUV.unsafeWrite freshBuffer freshCount (fromIntegral vertex)+            fill+              mutable+              operation+              table+              mapping+              freshBuffer+              (index + 1)+              (sumX + canonicalX)+              (sumY + canonicalY)+              (freshCount + 1)+          Right (ResidentPosition vertex) -> do+            writePrimArray mapping index (fromIntegral vertex)+            writeVertexData mutable vertex vertexData+            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@@ -530,13 +752,14 @@   -> MutablePointIndex s   -> Point   -> vertex-  -> ST s (Either BuildError (Int, Bool))+  -> ST s (Either BuildError PositionClaim) claimPosition mutable table rawPoint vertexData =   case rawPoint of     Point x y -> do       let !canonicalX = canonicalCoordinate x           !canonicalY = canonicalCoordinate y-      candidate <- pointCount mutable+      slot <- nextVertexSlot mutable+      let !candidate = nextVertexSlotIndex slot       owner <-         resolveMutablePoint           table@@ -547,10 +770,10 @@           candidate       case owner of         Left failure -> pure (Left failure)-        Right (Just existing) -> pure (Right (existing, False))+        Right (Just existing) -> pure (Right (ResidentPosition existing))         Right Nothing -> do-          vertex <- appendVertexCoordinates mutable canonicalX canonicalY vertexData-          pure (Right (vertex, True))+          vertex <- appendVertexCoordinatesAtSlot mutable slot canonicalX canonicalY vertexData+          pure (Right (FreshPosition vertex canonicalX canonicalY)) -- | 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
src-build/Moonlight/Triangulation/Cdt.hs view
@@ -44,7 +44,7 @@   , constraintSegments   , unionConstrainedWith   , unionConstrained-  , joinSeparatedConstrainedWith+  , joinSeparatedConstrained   , extendConstrainedWith   , constraintStorageBytes   , existsConstraint@@ -111,7 +111,7 @@ import Moonlight.Triangulation.Internal.Cdt.Union   ( constraintSegments   , extendConstrainedWith-  , joinSeparatedConstrainedWith+  , joinSeparatedConstrained   , unionConstrained   , unionConstrainedWith   )
src-build/Moonlight/Triangulation/Internal/Cdt/Union.hs view
@@ -10,7 +10,7 @@   , constraintSegments   , unionConstrainedWith   , unionConstrained-  , joinSeparatedConstrainedWith+  , joinSeparatedConstrained   , extendConstrainedWith   , segmentRequest   , firstRejected@@ -150,18 +150,15 @@ -- 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 () () ()+-- Strict x-separation proves that the two site sets have no coincident point,+-- so annotations are copied from their source mesh and never combined.+joinSeparatedConstrained+  :: Triangulation 'Constrained annotation () () ()   -> Triangulation 'Constrained annotation () () ()   -> Either       (ConstrainedUnionError)       (ConstrainedSeamResult annotation)-joinSeparatedConstrainedWith _combine left right = do+joinSeparatedConstrained left right = do   seamPlan <- maybe (Left ConstraintUnionNotSeparated) Right (planSeam left right)   seamExecution <-     mapLeft
src-build/Moonlight/Triangulation/Internal/CircleSweep.hs view
@@ -2,41 +2,66 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -O3 -fllvm -optlo-O3 -optlc-O3 #-}  module Moonlight.Triangulation.Internal.CircleSweep-  ( circleSweepInsert+  ( RadiallyOrderedArena+  , radiallyOrderArena+  , 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+  ( ReservedSweepCells+  , SweepCellCursor+  , SweepInsertion (..)+  , closeOuterTurnReserved+  , commitReservedSweepConnections   , fixHullConvexity-  , insertOutsideHullBetween-  , LegalizationLaw (..)-  , noStarVertex-  , seedGenericEdges+  , initialSweepCellCursor+  , insertOutsideHullAtEdge+  , reserveSweepCells   )+import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena+  ( seedGenericPairInArena+  )+import Moonlight.Triangulation.Internal.DcelOperations.Normalize+  ( LegalizationDrain (..)+  , drainDenseUnconstrainedGenericLegalization+  ) import Moonlight.Triangulation.Internal.Mutable+  ( DenseMutableDcel+  , MutableDcel+  , denseMutableDcel+  , denseMutableOwner+  , denseFaceEdges+  , denseReadFaceEdge+  , denseReadNext+  , denseReadOrigin+  , denseReadPointX+  , denseReadPointY+  , denseReadPrevious+  , directedEdgeCount+  , faceCount+  , halfEdgeCapacity+  , pointCapacity+  ) import Moonlight.Triangulation.Internal.OperationState   ( Counter (..)+  , LegalizationArena   , OperationState   , addCounter+  , legalizationArena   , maxCounter   , readScratch+  , storeLegalizationArena   , writeScratch   ) import Moonlight.Triangulation.Internal.Probe (Probe (..))@@ -59,18 +84,46 @@   , 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 #-}+-- | The strict state of the derived angular section. The bucket vector is+-- mutated only to transport the section across one local hull rewrite; its+-- extent and active cardinality are threaded as values, so the sweep does not+-- bounce through singleton mutable cells for facts already known at descent.+data HullIndex s = HullIndex+  !(MUV.MVector s Word32)+  {-# UNPACK #-} !Int -writeActiveCount :: Hull s -> Int -> ST s ()-writeActiveCount hull = MUV.unsafeWrite (hullActiveCount hull) 0-{-# INLINE writeActiveCount #-}+data DeferredInsertion s+  = DeferredInsertionFailure !BuildError+  | DeferredInsertionSuccess+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !SweepCellCursor+      !(LegalizationArena s)+      {-# UNPACK #-} !(HullIndex s) +data ClosedHullSection s = ClosedHullSection+  {-# UNPACK #-} !Int+  {-# UNPACK #-} !Int+  {-# UNPACK #-} !Int+  !(LegalizationArena s)+  {-# UNPACK #-} !SweepCellCursor++-- | A packed sweep arena after its radial keys have descended to one total+-- order. The constructor is private: the circle sweep consumes the proof and+-- therefore never pays to establish the same ordering twice.+newtype RadiallyOrderedArena s = RadiallyOrderedArena+  (MUV.MVector s (Double, Double, Double, Word32))++radiallyOrderArena+  :: MUV.MVector s (Double, Double, Double, Word32)+  -> ST s (RadiallyOrderedArena s)+radiallyOrderArena arena = do+  Intro.sort arena+  pure (RadiallyOrderedArena arena)+{-# INLINE radiallyOrderArena #-}+ noOuterEdge :: Word32 noOuterEdge = maxBound @@ -83,12 +136,22 @@ circleSweepInsert   :: MutableDcel s vertex directed undirected face   -> OperationState s+  -> RadiallyOrderedArena s+  -> ST s (Either BuildError Int)+circleSweepInsert mutable operation (RadiallyOrderedArena arena) =+  case denseMutableDcel mutable of+    Nothing -> pure (Left CircleSweepRequiresDenseStorage)+    Just dense -> circleSweepInsertDense dense operation arena+{-# INLINE circleSweepInsert #-}++circleSweepInsertDense+  :: DenseMutableDcel s vertex directed undirected face+  -> OperationState s   -> MUV.MVector s (Double, Double, Double, Word32)   -> ST s (Either BuildError Int)-circleSweepInsert mutable operation arena+circleSweepInsertDense dense 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@@ -98,49 +161,59 @@           if faces <= 1 || seedCount >= ordered             then pure (Right seedCount)             else do-              (centerX, centerY) <- seedCentre mutable-              builtHull <- buildHull mutable operation centerX centerY-              case builtHull of+              (centerX, centerY) <- seedCentre dense+              reservedOutcome <- reserveSweepCells dense (ordered - seedCount)+              case reservedOutcome 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+                Right reserved -> do+                  builtHull <- buildHull dense operation centerX centerY+                  case builtHull 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+                    Right (!hull, !initialHullIndex) -> do+                      skipped <- MUV.new (ordered - seedCount)+                      initialLegalizationArena <- legalizationArena operation+                      let !initialCursor = initialSweepCellCursor reserved+                      inserted <- insertRemaining reserved initialCursor initialLegalizationArena hull initialHullIndex ordered seedCount skipped 0 0 0 0+                      case inserted 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)+                        Right (!skippedCount, !fastCount, !flips, !maxDepth, !sweepCursor, !sweepArena) -> do+                          repaired <- fixHullConvexity reserved sweepCursor operation sweepArena+                          case repaired of+                            Left failure -> pure (Left failure)+                            Right (!_closures, !terminalFlips, !terminalMaxDepth, !finalArena, !finalCursor) -> do+                              commitReservedSweepConnections reserved finalCursor fastCount+                              storeLegalizationArena operation finalArena+                              -- 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+                              addCounter operation CounterEdgeFlips terminalFlips+                              maxCounter operation CounterLegalizationMaxStack terminalMaxDepth+                              insertedSkipped <- insertSkipped skipped skippedCount 0+                              pure (seedCount <$ insertedSkipped)  where+  !mutable = denseMutableOwner dense+   insertSeed !index     | index >= MUV.length arena = pure (Right index)     | otherwise = do@@ -154,30 +227,46 @@               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))+  insertRemaining !reserved !cursor !candidateArena !hull !hullIndex !ordered !index !skipped !skippedCount !fastCount !flips !maxDepth+    | index >= ordered = pure (Right (skippedCount, fastCount, flips, maxDepth, cursor, candidateArena))     | 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+        edge <- hullCandidate dense hull hullIndex queryAngle queryXWide queryYWide+        fromVertex <- denseReadOrigin dense edge+        toVertex <- denseReadOrigin dense (edge `xor` 1)+        fromX <- denseReadPointX dense fromVertex+        fromY <- denseReadPointY dense fromVertex+        toX <- denseReadPointX dense toVertex+        toY <- denseReadPointY dense toVertex+        if orient2dCoordinates fromX fromY toX toY queryXWide queryYWide == GT           then do-            deferred <- insertDeferred mutable operation hull edge vertex queryAngle+            deferred <-+              insertDeferred+                reserved+                cursor+                dense+                hull+                hullIndex+                candidateArena+                edge+                fromVertex+                toVertex+                vertex+                queryXWide+                queryYWide+                queryAngle             case deferred of-              Left failure -> pure (Left failure)-              Right (!_newClosures, !newFlips, !newMaxDepth) ->+              DeferredInsertionFailure failure -> pure (Left failure)+              DeferredInsertionSuccess !newFlips !newMaxDepth !nextCursor !nextArena !nextHullIndex ->                 insertRemaining+                  reserved+                  nextCursor+                  nextArena                   hull+                  nextHullIndex                   ordered                   (index + 1)                   skipped@@ -187,7 +276,7 @@                   (max maxDepth newMaxDepth)           else do             MUV.unsafeWrite skipped skippedCount raw-            insertRemaining hull ordered (index + 1) skipped (skippedCount + 1) fastCount flips maxDepth+            insertRemaining reserved cursor candidateArena hull hullIndex ordered (index + 1) skipped (skippedCount + 1) fastCount flips maxDepth    insertSkipped skipped !count = go    where@@ -203,19 +292,19 @@ -- | 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+  :: DenseMutableDcel 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+seedCentre dense = do+  (e0, e1, e2) <- denseFaceEdges dense 1+  o0 <- denseReadOrigin dense e0+  o1 <- denseReadOrigin dense e1+  o2 <- denseReadOrigin dense e2+  x0 <- denseReadPointX dense o0+  y0 <- denseReadPointY dense o0+  x1 <- denseReadPointX dense o1+  y1 <- denseReadPointY dense o1+  x2 <- denseReadPointX dense o2+  y2 <- denseReadPointY dense 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@@ -223,13 +312,14 @@ -- 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+  :: DenseMutableDcel 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+  -> ST s (Either BuildError (Hull s, HullIndex s))+buildHull dense operation centerX centerY = do+  let !mutable = denseMutableOwner dense+  countResult <- collectOuterEdges dense operation   case countResult of     Left failure -> pure (Left failure)     Right count@@ -237,33 +327,29 @@       | 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+            origin <- denseReadOrigin dense edge+            x <- denseReadPointX dense origin+            y <- denseReadPointY dense origin             MUV.unsafeWrite hullAngleByEdge edge (pseudoAngle centerX centerY x y)-            installBucketMaximum mutable hull edge-          pure (Right hull)+          hullIndex <- rebuildBuckets dense hull count (initialBucketCount count capacity)+          pure (Right (hull, hullIndex))  collectOuterEdges-  :: MutableDcel s vertex directed undirected face+  :: DenseMutableDcel s vertex directed undirected face   -> OperationState s   -> ST s (Either BuildError Int)-collectOuterEdges mutable operation = do-  start <- readFaceEdge mutable 0+collectOuterEdges dense operation = do+  let !mutable = denseMutableOwner dense+  start <- denseReadFaceEdge dense 0   if start < 0     then pure (Right 0)     else do@@ -283,12 +369,12 @@     | seen && edge == start = pure (Right count)     | otherwise = do         writeScratch operation count edge-        following <- readNext mutable edge+        following <- denseReadNext dense 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)))+  min capacity (nextPowerOfTwo (max 8 ((active + 1) `quot` 2)))  nextPowerOfTwo :: Int -> Int nextPowerOfTwo requested = go 1@@ -303,69 +389,66 @@ 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+rebuildBuckets :: DenseMutableDcel s vertex directed undirected face -> Hull s -> Int -> Int -> ST s (HullIndex s)+rebuildBuckets dense hull active 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+  start <- denseReadFaceEdge dense 0   let go !remaining !edge         | remaining <= 0 = pure ()         | otherwise = do-            installBucketMaximum mutable hull edge-            following <- readNext mutable edge+            following <- denseReadNext dense edge+            angle <- readAngle hull edge+            followingAngle <- readAngle hull following+            writeBucketSegment buckets angle followingAngle edge             go (remaining - 1) following   when (active > 0 && start >= 0) (go active start)+  pure (HullIndex buckets active) -maybeGrowBuckets :: MutableDcel s vertex directed undirected face -> Hull s -> ST s ()-maybeGrowBuckets mutable hull = do-  active <- readActiveCount hull-  buckets <- readSTRef (hullBuckets hull)+maybeGrowBuckets :: DenseMutableDcel s vertex directed undirected face -> Hull s -> HullIndex s -> ST s (HullIndex s)+maybeGrowBuckets dense hull hullIndex@(HullIndex buckets active) = do   let !current = MUV.length buckets-  when (active > 8 * current && current < hullBucketCapacity hull) $-    rebuildBuckets mutable hull (min (hullBucketCapacity hull) (2 * current))+  if active > 2 * current && current < hullBucketCapacity hull+    then rebuildBuckets dense hull active (min (hullBucketCapacity hull) (2 * current))+    else pure hullIndex  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+ceilingBucketFor :: Int -> Double -> Int+ceilingBucketFor count angle =+  ceiling (angle * fromIntegral count * 0.25) `rem` count+{-# INLINE ceilingBucketFor #-}++-- | Install the authoritative outer edge whose angular segment contains each+-- bucket boundary in the half-open clockwise arc from @fromAngle@ to+-- @toAngle@. Adjacency remains solely in the DCEL; this is the derived section+-- needed to land a lookup near that ring.+writeBucketSegment+  :: MUV.MVector s Word32+  -> Double+  -> Double   -> 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)+  -> ST s ()+writeBucketSegment buckets fromAngle toAngle edge = do+  let !count = MUV.length buckets+      !fromBucket = ceilingBucketFor count fromAngle+      !toBucket = ceilingBucketFor count toAngle+      !packed = fromIntegral edge+  case compare fromBucket toBucket of+    LT -> MUV.set (MUV.unsafeSlice fromBucket (toBucket - fromBucket) buckets) packed+    GT -> do+      MUV.set (MUV.unsafeSlice fromBucket (count - fromBucket) buckets) packed+      MUV.set (MUV.unsafeSlice 0 toBucket buckets) packed+    EQ -> pure ()+{-# INLINE writeBucketSegment #-}  -- | 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+  :: DenseMutableDcel s vertex directed undirected face   -> Hull s   -> Int   -> Double@@ -373,127 +456,141 @@   -> Double   -> Int   -> ST s Bool-edgeAtMost mutable hull edge queryAngle queryX queryY tie = do+edgeAtMost dense 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+      origin <- denseReadOrigin dense edge+      x <- denseReadPointX dense origin       case compare x queryX of         LT -> pure True         GT -> pure False         EQ -> do-          y <- readPointY mutable origin+          y <- denseReadPointY dense 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+-- | Reconcile the derived angular index once after the local topology section+-- has glued. Replacing one outer edge by two adds one active edge; every closed+-- turn removes one. The final two edges cover the entire rewritten angular+-- arc, so their segments descend to the bucket view in one gluing step.+finishHullRewrite+  :: DenseMutableDcel s vertex directed undirected face+  -> Hull s+  -> HullIndex s+  -> Int+  -> Int+  -> Int+  -> ST s (HullIndex s)+finishHullRewrite dense hull (HullIndex buckets active) leftEdge rightEdge activeDelta = do+  leftAngle <- readAngle hull leftEdge+  middleAngle <- readAngle hull rightEdge+  afterRight <- denseReadNext dense rightEdge+  rightAngle <- readAngle hull afterRight+  writeBucketSegment buckets leftAngle middleAngle leftEdge+  writeBucketSegment buckets middleAngle rightAngle rightEdge+  maybeGrowBuckets dense hull (HullIndex buckets (active + activeDelta))+{-# INLINE finishHullRewrite #-}  -- | 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+  :: DenseMutableDcel s vertex directed undirected face   -> Hull s+  -> HullIndex s   -> Double   -> Double   -> Double   -> ST s Int-hullCandidate mutable hull queryAngle queryX queryY = do-  buckets <- readSTRef (hullBuckets hull)+hullCandidate dense hull (HullIndex buckets active) queryAngle queryX queryY = do   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)+    then denseReadFaceEdge dense 0+    else adjustFromBoundary 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+  adjustFromBoundary !bucket !initial = do+    initialAtMost <- cyclicAtMost bucket initial+    if initialAtMost+      then advance active initial+      else retreat active initial    where-    go !remaining !edge+    cyclicAtMost boundaryBucket edge = do+      angle <- readAngle hull edge+      if boundaryBucket == 0 && angle > queryAngle+        then pure True+        else edgeAtMost dense hull edge queryAngle queryX queryY maxBound++    advance !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+          following <- denseReadNext dense edge+          edgeAngle <- readAngle hull edge+          followingAngle <- readAngle hull following+          -- Only the bucket-zero anchor may precede the query by crossing the+          -- angular seam. Once the walk leaves that anchor, ordinary key order+          -- is authoritative; treating every high-angle edge as below a+          -- bucket-zero query walks straight past the answer and around the+          -- entire ring.+          let crossesSeam = followingAngle < edgeAngle+              seamPermitted = bucket == 0 && edgeAngle > queryAngle+          followingAtMost <- edgeAtMost dense hull following queryAngle queryX queryY maxBound+          if (not crossesSeam || seamPermitted) && followingAtMost+            then advance (remaining - 1) following+            else pure edge +    retreat !remaining !edge+      | remaining <= 0 = pure initial+      | otherwise = do+          previous <- denseReadPrevious dense edge+          previousAtMost <- cyclicAtMost bucket previous+          if previousAtMost+            then advance remaining previous+            else retreat (remaining - 1) previous+ insertDeferred-  :: MutableDcel s vertex directed undirected face-  -> OperationState s+  :: ReservedSweepCells s vertex directed undirected face+  -> SweepCellCursor+  -> DenseMutableDcel s vertex directed undirected face   -> Hull s+  -> HullIndex s+  -> LegalizationArena s   -> Int   -> Int+  -> 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+  -> Double+  -> Double+  -> ST s (DeferredInsertion s)+insertDeferred reserved cursor dense hull hullIndex arena replacedEdge fromVertex toVertex vertex insertedX insertedY insertedAngle = do+  inserted <-+    insertOutsideHullAtEdge+      reserved+      cursor+      arena+      replacedEdge+      fromVertex+      toVertex+      vertex   case inserted of-    Left failure -> pure (Left failure)-    Right (firstEdge, lastEdge) -> insertDeferredBetween firstEdge lastEdge+    SweepInsertionFailure failure -> pure (DeferredInsertionFailure failure)+    SweepInsertion firstOuterEdge lastOuterEdge initialFlips initialMaxDepth arenaAfterInsertion cursorAfterInsertion ->+      insertDeferredBetween+        firstOuterEdge+        lastOuterEdge+        initialFlips+        initialMaxDepth+        arenaAfterInsertion+        cursorAfterInsertion  where-  insertDeferredBetween firstEdge lastEdge = do+  insertDeferredBetween firstEdge lastEdge initialFlips initialMaxDepth arenaAfterInsertion cursorAfterInsertion = 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@@ -501,108 +598,126 @@     -- 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))+    ClosedHullSection left closuresLeft topLeft arenaAfterLeft cursorAfterLeft <- closeLeft firstEdge 0 0 arenaAfterInsertion cursorAfterInsertion+    ClosedHullSection right closuresRight topAll arenaAfterRight cursorAfterRight <- closeRight lastEdge 0 topLeft arenaAfterLeft cursorAfterLeft+    let !closures = closuresLeft + closuresRight+    nextHullIndex <- finishHullRewrite dense hull hullIndex left right (1 - closures)+    (!flips, !maxDepth, !finalArena) <-+      if topAll == 0+        then pure (0, 0, arenaAfterRight)+        else do+          LegalizationDrain drainedFlips drainedMaxDepth () drainedArena <-+            drainDenseUnconstrainedGenericLegalization dense arenaAfterRight topAll+          pure (drainedFlips, drainedMaxDepth, drainedArena)+    pure+      ( DeferredInsertionSuccess+          (initialFlips + flips)+          (max initialMaxDepth maxDepth)+          cursorAfterRight+          finalArena+          nextHullIndex+      ) -  closeLeft !current !closures !top = do-    left <- readPrevious mutable current-    close <- shouldCloseTurn mutable hull insertedAngle left current+  closeLeft !current !closures !top !sectionArena !sectionCursor = do+    left <- denseReadPrevious dense current+    close <- shouldCloseLeftTurn dense hull insertedAngle insertedX insertedY left current     if not close-      then pure (Right (current, closures, top))+      then pure (ClosedHullSection current closures top sectionArena sectionCursor)       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+        (replacement, nextCursor) <- closeOuterTurnReserved reserved sectionCursor left+        -- 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.+        MUV.unsafeWrite (hullAngleByEdge hull) replacement leftAngle+        (nextArena, nextTop) <- seedGenericPairInArena sectionArena top left current+        closeLeft replacement (closures + 1) nextTop nextArena nextCursor -  closeRight !current !closures !top = do-    right <- readNext mutable current-    close <- shouldCloseTurn mutable hull insertedAngle current right+  closeRight !current !closures !top !sectionArena !sectionCursor = do+    right <- denseReadNext dense current+    close <- shouldCloseRightTurn dense hull insertedAngle insertedX insertedY current right     if not close-      then pure (Right (current, closures, top))+      then pure (ClosedHullSection current closures top sectionArena sectionCursor)       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+        (replacement, nextCursor) <- closeOuterTurnReserved reserved sectionCursor current+        MUV.unsafeWrite (hullAngleByEdge hull) replacement currentAngle+        (nextArena, nextTop) <- seedGenericPairInArena sectionArena top current right+        closeRight replacement (closures + 1) nextTop nextArena nextCursor {-# INLINE insertDeferred #-} -shouldCloseTurn-  :: MutableDcel s vertex directed undirected face+-- | Test the left-hand turn where the inserted point is the target of the+-- second edge. Adjacency is not rediscovered: 'closeLeft' obtained @first@+-- from @previous second@ in the same local section.+shouldCloseLeftTurn+  :: DenseMutableDcel s vertex directed undirected face   -> Hull s   -> Double+  -> Double+  -> Double   -> Int   -> Int   -> ST s Bool-shouldCloseTurn mutable hull insertedAngle first second = do-  following <- readNext mutable first-  if following /= second+shouldCloseLeftTurn dense hull insertedAngle insertedX insertedY first second = do+  fromVertex <- denseReadOrigin dense first+  middleVertex <- denseReadOrigin dense (first `xor` 1)+  fromX <- denseReadPointX dense fromVertex+  fromY <- denseReadPointY dense fromVertex+  middleX <- denseReadPointX dense middleVertex+  middleY <- denseReadPointY dense middleVertex+  if orient2dWide fromX fromY middleX middleY insertedX insertedY /= GT     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 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 insertedX insertedY+        )+{-# INLINE shouldCloseLeftTurn #-}++-- | The symmetric right-hand test, where the inserted point is the first+-- edge's source. 'closeRight' obtained @second@ from @next first@, so this+-- section likewise consumes that adjacency proof instead of reading it again.+shouldCloseRightTurn+  :: DenseMutableDcel s vertex directed undirected face+  -> Hull s+  -> Double+  -> Double+  -> Double+  -> Int+  -> Int+  -> ST s Bool+shouldCloseRightTurn dense hull insertedAngle insertedX insertedY first second = do+  middleVertex <- denseReadOrigin dense (first `xor` 1)+  targetVertex <- denseReadOrigin dense (second `xor` 1)+  middleX <- denseReadPointX dense middleVertex+  middleY <- denseReadPointY dense middleVertex+  targetX <- denseReadPointX dense targetVertex+  targetY <- denseReadPointY dense targetVertex+  if orient2dWide insertedX insertedY middleX middleY targetX targetY /= GT+    then pure False+    else do+      middleAngle <- readAngle hull second+      pure+        ( middleAngle == insertedAngle+            || acuteAtMiddle insertedX insertedY middleX middleY targetX targetY+        )+{-# INLINE shouldCloseRightTurn #-}  -- The deferred turn test deliberately runs the widened Binary64 predicate -- rather than the exact binary64 one; only the terminal Graham pass owns exact
src-build/Moonlight/Triangulation/Internal/Join/Seam.hs view
@@ -334,7 +334,7 @@       BuildError       (Triangulation outputMode vertex () () (), BuildStats) mergeSeparated constraintSections left right (SeamTangents lowerLeft lowerRight upperLeft upperRight) = runST $ do-  mutable <- newMutableDcel unitElementDefaults totalVertices+  mutable <- newMutableDcel unitElementDefaults (generalDcelCapacity totalVertices)   pointCapacityOutcome <- ensurePointCapacity mutable totalVertices   cellCapacityOutcome <-     ensureCellCapacity
+ src-build/Moonlight/Triangulation/Internal/Minkowski/Convex.hs view
@@ -0,0 +1,325 @@+-- | Pure exact convex-polygon algebra: admission, linear edge-angle+-- convolution, reflection, hull construction, and support-half-plane erosion.+module Moonlight.Triangulation.Internal.Minkowski.Convex+  ( convexPolygon+  , convexPolygonPoints+  , convexPolygonRegion+  , admittedConvexLoop+  , structuringElement+  , structuringElementPolygon+  , convexMinkowskiSum+  , convexMinkowskiPolygon+  , convexHullPolygon+  , reflectConvexPolygon+  , convexPolygonCentroid+  , erodeConvexBy+  , addExactPoints+  , subtractExactPoints+  ) where++import Control.Monad (foldM)+import Data.Bifunctor (first)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Set as Set+import Moonlight.Triangulation.Exact+  ( ExactPoint+  , ExactVector (..)+  , addExactVectors+  , compareExactVectorAngle+  , exactVectorFromPoints+  , exactSegment+  , exactSupportingLineIntersection+  , exactOrient2d+  , exactPoint+  , exactPointCoordinates+  , translateExactPoint+  )+import Moonlight.Triangulation.Internal.BoundaryCycle+  ( cyclePairs+  , cyclePairsNonEmpty+  , cyclicTriples+  , rotateCycleLeast+  , rotateCycleLeastBy+  )+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactRational+  , exactDivide+  )+import Moonlight.Triangulation.Internal.Minkowski.Types+  ( ConvexPolygon (..)+  , MinkowskiError (..)+  , StructuringElement (..)+  )+import Moonlight.Triangulation.Internal.Region.Types+  ( ExactLoop (..)+  , PlanarRegion (..)+  , PolygonComponent (..)+  , RegionPointLocation (..)+  )+import Moonlight.Triangulation.Region+  ( exactLoop+  , exactLoopPoints+  , regionPointLocation+  )++convexPolygon+  :: NonEmpty ExactPoint+  -> Either MinkowskiError ConvexPolygon+convexPolygon submitted = do+  loop <- first MinkowskiInvalidConvexLoop (exactLoop submitted)+  let points = exactLoopPoints loop+  case+    [ (index, turn)+    | (index, (previous, current, next)) <-+        zip [0 :: Int ..] (cyclicTriples (NonEmpty.toList points))+    , let turn = exactOrient2d previous current next+    , turn /= GT+    ] of+    (index, turn) : _ -> Left (MinkowskiNonConvexTurn index turn)+    [] -> Right (ConvexPolygon loop)++convexPolygonPoints :: ConvexPolygon -> NonEmpty ExactPoint+convexPolygonPoints (ConvexPolygon loop) = exactLoopPoints loop++convexPolygonRegion :: ConvexPolygon -> PlanarRegion+convexPolygonRegion (ConvexPolygon loop) =+  PlanarRegion [PolygonComponent loop []]++admittedConvexLoop :: ExactLoop -> Maybe ConvexPolygon+admittedConvexLoop loop+  | all ((== GT) . orderedTurn) (cyclicTriples (NonEmpty.toList (exactLoopPoints loop))) =+      Just (ConvexPolygon loop)+  | otherwise = Nothing+ where+  orderedTurn (previous, current, next) =+    exactOrient2d previous current next++structuringElement+  :: ConvexPolygon+  -> Either MinkowskiError StructuringElement+structuringElement polygon =+  let origin = exactPoint 0 0+      location = regionPointLocation (convexPolygonRegion polygon) origin+   in case location of+        RegionExterior -> Left (MinkowskiOriginOutside location)+        _ -> Right (StructuringElement polygon)++structuringElementPolygon :: StructuringElement -> ConvexPolygon+structuringElementPolygon (StructuringElement polygon) = polygon++convexMinkowskiSum+  :: ConvexPolygon+  -> ConvexPolygon+  -> PlanarRegion+convexMinkowskiSum left right =+  convexPolygonRegion (convexMinkowskiPolygon left right)++convexMinkowskiPolygon+  :: ConvexPolygon+  -> ConvexPolygon+  -> ConvexPolygon+convexMinkowskiPolygon left right =+  let leftPoints = rotateCycleLeastBy pointSweepKey (convexPolygonPoints left)+      rightPoints = rotateCycleLeastBy pointSweepKey (convexPolygonPoints right)+      start = addExactPoints (NonEmpty.head leftPoints) (NonEmpty.head rightPoints)+      directions =+        mergeDirections+          (edgeDirections leftPoints)+          (edgeDirections rightPoints)+      directionList = NonEmpty.toList directions+      scanned = scanl translateExactPoint start directionList+      resultPoints = start :| take (length directionList - 1) (drop 1 scanned)+   in ConvexPolygon (ExactLoop (rotateCycleLeast resultPoints))++convexHullPolygon+  :: NonEmpty ExactPoint+  -> Either MinkowskiError ConvexPolygon+convexHullPolygon submitted =+  let points = NonEmpty.toList submitted+   in case convexHullPoints points of+    Nothing -> Left (MinkowskiConvexHullDegenerate points)+    Just hullPoints -> Right (ConvexPolygon (ExactLoop (rotateCycleLeast hullPoints)))++reflectConvexPolygon :: ConvexPolygon -> ConvexPolygon+reflectConvexPolygon polygon =+  ConvexPolygon+    ( ExactLoop+        ( rotateCycleLeast+            (NonEmpty.reverse (fmap negateExactPoint (convexPolygonPoints polygon)))+        )+    )++convexPolygonCentroid+  :: ConvexPolygon+  -> Either MinkowskiError ExactPoint+convexPolygonCentroid polygon = do+  let points = convexPolygonPoints polygon+      count = fromIntegral (NonEmpty.length points)+      (sumX, sumY) =+        foldl'+          (\(accumulatedX, accumulatedY) point ->+             let (x, y) = exactPointCoordinates point+              in (accumulatedX + x, accumulatedY + y))+          (0, 0)+          points+  x <- first MinkowskiExactArithmetic (exactDivide sumX count)+  y <- first MinkowskiExactArithmetic (exactDivide sumY count)+  pure (exactPoint x y)++-- | Erode one convex polygon by another through the strongest translated+-- support half-plane for each source edge. Sutherland--Hodgman descent keeps+-- the construction exact; a lower-dimensional residual is represented by the+-- empty polygonal region at this two-dimensional publication boundary.+erodeConvexBy+  :: ConvexPolygon+  -> ConvexPolygon+  -> Either MinkowskiError (Maybe ConvexPolygon)+erodeConvexBy source kernel = do+  let sourcePoints = convexPolygonPoints source+      kernelPoints = convexPolygonPoints kernel+      firstKernel = NonEmpty.head kernelPoints+      initial =+        map+          (`subtractExactPoints` firstKernel)+          (NonEmpty.toList sourcePoints)+      halfPlanes =+        [ strongestHalfPlane kernelPoints from to+        | (from, to) <- cyclePairs sourcePoints+        ]+  clipped <- foldM clipPolygon initial halfPlanes+  pure (ConvexPolygon . ExactLoop . rotateCycleLeast <$> convexHullPoints clipped)++edgeDirections :: NonEmpty ExactPoint -> NonEmpty ExactVector+edgeDirections = fmap (uncurry exactVectorFromPoints) . cyclePairsNonEmpty++mergeDirections+  :: NonEmpty ExactVector+  -> NonEmpty ExactVector+  -> NonEmpty ExactVector+mergeDirections (left :| leftTail) (right :| rightTail) =+  case compareExactVectorAngle left right of+    LT -> left :| mergeRemaining leftTail (right : rightTail)+    GT -> right :| mergeRemaining (left : leftTail) rightTail+    EQ -> addExactVectors left right :| mergeRemaining leftTail rightTail++mergeRemaining :: [ExactVector] -> [ExactVector] -> [ExactVector]+mergeRemaining [] right = right+mergeRemaining left [] = left+mergeRemaining left@(leftHead : leftTail) right@(rightHead : rightTail) =+  case compareExactVectorAngle leftHead rightHead of+    LT -> leftHead : mergeRemaining leftTail right+    GT -> rightHead : mergeRemaining left rightTail+    EQ -> addExactVectors leftHead rightHead : mergeRemaining leftTail rightTail++pointSweepKey :: ExactPoint -> (ExactRational, ExactRational)+pointSweepKey point =+  let (x, y) = exactPointCoordinates point+   in (y, x)++convexHullPoints :: [ExactPoint] -> Maybe (NonEmpty ExactPoint)+convexHullPoints submitted =+  case Set.toAscList (Set.fromList submitted) of+    firstPoint : secondPoint : thirdPoint : remaining ->+      let ordered = firstPoint : secondPoint : thirdPoint : remaining+          lower = dropFinal (reverse (foldl' hullStep [] ordered))+          upper = dropFinal (reverse (foldl' hullStep [] (reverse ordered)))+       in case lower <> upper of+            firstHullPoint : secondHullPoint : thirdHullPoint : hullTail ->+              Just (firstHullPoint :| (secondHullPoint : thirdHullPoint : hullTail))+            _ -> Nothing+    _ -> Nothing++hullStep :: [ExactPoint] -> ExactPoint -> [ExactPoint]+hullStep (current : previous : remaining) candidate+  | exactOrient2d previous current candidate /= GT =+      hullStep (previous : remaining) candidate+hullStep hull candidate = candidate : hull++dropFinal :: [value] -> [value]+dropFinal values =+  case reverse values of+    _ : remaining -> reverse remaining+    [] -> []++strongestHalfPlane+  :: NonEmpty ExactPoint+  -> ExactPoint+  -> ExactPoint+  -> (ExactPoint, ExactPoint)+strongestHalfPlane kernelPoints from to =+  let direction = exactVectorFromPoints from to+      supportPoint =+        case kernelPoints of+          initial :| remaining ->+            foldl'+              (\selected candidate ->+                 if directionPointCross direction candidate+                      < directionPointCross direction selected+                   then candidate+                   else selected)+              initial+              remaining+   in ( subtractExactPoints from supportPoint+      , subtractExactPoints to supportPoint+      )++directionPointCross :: ExactVector -> ExactPoint -> ExactRational+directionPointCross (ExactVector directionX directionY) point =+  let (x, y) = exactPointCoordinates point+   in directionX * y - directionY * x++clipPolygon+  :: [ExactPoint]+  -> (ExactPoint, ExactPoint)+  -> Either MinkowskiError [ExactPoint]+clipPolygon [] _ = Right []+clipPolygon polygon halfPlane =+  concat <$> traverse (clipEdge halfPlane) (cyclePairsList polygon)++clipEdge+  :: (ExactPoint, ExactPoint)+  -> (ExactPoint, ExactPoint)+  -> Either MinkowskiError [ExactPoint]+clipEdge (boundaryFrom, boundaryTo) (from, to) =+  case (inside from, inside to) of+    (True, True) -> Right [to]+    (True, False) -> (: []) <$> supportingLineIntersection from to boundaryFrom boundaryTo+    (False, True) -> do+      crossing <- supportingLineIntersection from to boundaryFrom boundaryTo+      pure [crossing, to]+    (False, False) -> Right []+ where+  inside point = exactOrient2d boundaryFrom boundaryTo point /= LT++supportingLineIntersection+  :: ExactPoint+  -> ExactPoint+  -> ExactPoint+  -> ExactPoint+  -> Either MinkowskiError ExactPoint+supportingLineIntersection lineFrom lineTo boundaryFrom boundaryTo = do+  clippedSegment <- first MinkowskiInvalidSegment (exactSegment lineFrom lineTo)+  boundarySegment <- first MinkowskiInvalidSegment (exactSegment boundaryFrom boundaryTo)+  first MinkowskiLineIntersection+    (exactSupportingLineIntersection clippedSegment boundarySegment)++addExactPoints :: ExactPoint -> ExactPoint -> ExactPoint+addExactPoints left right =+  let (leftX, leftY) = exactPointCoordinates left+      (rightX, rightY) = exactPointCoordinates right+   in exactPoint (leftX + rightX) (leftY + rightY)++subtractExactPoints :: ExactPoint -> ExactPoint -> ExactPoint+subtractExactPoints left right =+  let (leftX, leftY) = exactPointCoordinates left+      (rightX, rightY) = exactPointCoordinates right+   in exactPoint (leftX - rightX) (leftY - rightY)++negateExactPoint :: ExactPoint -> ExactPoint+negateExactPoint point =+  let (x, y) = exactPointCoordinates point+   in exactPoint (negate x) (negate y)++cyclePairsList :: [value] -> [(value, value)]+cyclePairsList = maybe [] cyclePairs . NonEmpty.nonEmpty
+ src-build/Moonlight/Triangulation/Internal/Minkowski/Types.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Closed vocabulary and invariant carriers for exact polygonal morphology.+module Moonlight.Triangulation.Internal.Minkowski.Types+  ( ConvexPolygon (..)+  , StructuringElement (..)+  , MinkowskiOperation (..)+  , MinkowskiError (..)+  , MinkowskiReceipt (..)+  ) where++import Control.DeepSeq (NFData)+import GHC.Generics (Generic)+import Moonlight.Triangulation.Exact+  ( ExactGeometryError+  , ExactIntersectionError+  , ExactPoint+  )+import Moonlight.Triangulation.Handles.HandleDefs (FaceId)+import Moonlight.Triangulation.Internal.ExactRational (ExactArithmeticError)+import Moonlight.Triangulation.Internal.Overlay.Types+  ( OverlayCellId+  , OverlayCellWitness+  , OverlayError+  )+import Moonlight.Triangulation.Internal.Region.Types+  ( ExactLoop+  , RegionPublicationError+  , RegionPointLocation+  , RegionValidationError+  )++newtype ConvexPolygon = ConvexPolygon ExactLoop+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++newtype StructuringElement = StructuringElement ConvexPolygon+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data MinkowskiOperation+  = MinkowskiAddition+  | MinkowskiErosion+  | MinkowskiOpening+  | MinkowskiClosing+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data MinkowskiError+  = MinkowskiInvalidConvexLoop !RegionValidationError+  | MinkowskiInvalidSegment !ExactGeometryError+  | MinkowskiNonConvexTurn !Int !Ordering+  | MinkowskiOriginOutside !RegionPointLocation+  | MinkowskiExactArithmetic !ExactArithmeticError+  | MinkowskiLineIntersection !ExactIntersectionError+  | MinkowskiOverlayFailed !(OverlayError Bool Bool)+  | MinkowskiPublicationFailed !RegionPublicationError+  | MinkowskiOverlayCellWitness !OverlayCellWitness+  | MinkowskiFaceArity !FaceId !Int+  | MinkowskiCandidateCellMissing !OverlayCellId+  | MinkowskiInclusionAmbiguous !OverlayCellId !ExactPoint+  | MinkowskiConvexHullDegenerate ![ExactPoint]+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++data MinkowskiReceipt = MinkowskiReceipt+  { minkowskiOperation :: !MinkowskiOperation+  , minkowskiInputComponents :: !Int+  , minkowskiConvexPieces :: !Int+  , minkowskiGeneratedPieces :: !Int+  , minkowskiGeneratedConvolutionEdges :: !Int+  , minkowskiOverlayPasses :: !Int+  , minkowskiExactCrossings :: !Int+  , minkowskiOutputCells :: !Int+  , minkowskiExactCoordinateBitGrowth :: !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)
+ src-build/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs view
@@ -0,0 +1,806 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Exact source normalization and binary64 embedding certification. This+-- module ends at the arrangement/resident seam: no DCEL face state crosses it.+module Moonlight.Triangulation.Internal.Overlay.Arrangement+  ( ExactEdgeKey+  , AtomicEdge (..)+  , atomicEdgeFrom+  , atomicEdgeTo+  , OverlayVertexSeed (..)+  , ArrangementMetrics (..)+  , CertifiedArrangement (..)+  , certifyArrangement+  , canonicalEdgeKey+  , atomicKey+  , compareAround+  ) where++import Data.Bifunctor (first)+import Data.List (sortBy)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Vector as V+import GHC.Generics (Generic)+import Moonlight.Triangulation.Exact+  ( ExactGeometryError+  , ExactPoint+  , ExactSegment+  , SegmentRelation (SegmentsShareEndpoint)+  , compareExactVectorAngle+  , exactPointCoordinates+  , exactPointFromPoint+  , exactSegment+  , exactSegmentEndpoints+  , exactVectorFromPoints+  )+import Moonlight.Triangulation.Internal.BoundaryCycle+  ( consecutivePairs+  , orderedPair+  , unorderedPairs+  )+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactRational+  , exactDivide+  , exactRationalIsZero+  )+import Moonlight.Triangulation.Internal.ExactSegmentEvents+  ( ExactSegmentEvent (..)+  , ExactSegmentEventPlan+  , ExactSweepSegmentId (..)+  , exactSegmentEventPlan+  , exactSegmentEvents+  , exactSegmentPairChecks+  , exactSegmentRelationMap+  , exactSegmentSplitPoints+  , exactSegmentSweepMaximumHeight+  )+import Moonlight.Triangulation.Internal.Overlay.Embedding+  ( DraftIncidence (..)+  , DraftNeighborhood (..)+  , DraftReference (..)+  , DraftSegmentId (..)+  , DraftSourceId (..)+  , DraftVertexId (..)+  , ExactArrangementDraft (..)+  , LocalEmbeddingCertificate (..)+  , OverlayEmbeddingObstruction (..)+  , certifyLocalEmbedding+  )+import Moonlight.Triangulation.Internal.Overlay.Types+import Moonlight.Triangulation.Internal.Types (HasPosition (..), Point)+import Moonlight.Triangulation.Region+  ( ExactLoop+  , PlanarLayer+  , PolygonComponent+  , exactLoopPoints+  , planarLayerOutsideLabel+  , planarLayerRegions+  , planarRegionComponents+  , polygonHoleLoops+  , polygonOuterLoop+  )++type ExactEdgeKey = (ExactPoint, ExactPoint)++data SourceBoundary leftLabel rightLabel+  = LeftSourceBoundary+      !ExactSegment+      !leftLabel+      !(BoundaryVertexRef 'LeftOverlayOperand)+      !(BoundaryVertexRef 'LeftOverlayOperand)+      !(BoundaryEdgeRef 'LeftOverlayOperand)+  | RightSourceBoundary+      !ExactSegment+      !rightLabel+      !(BoundaryVertexRef 'RightOverlayOperand)+      !(BoundaryVertexRef 'RightOverlayOperand)+      !(BoundaryEdgeRef 'RightOverlayOperand)++type SourceBoundaryConstructor operand label leftLabel rightLabel =+  ExactSegment+  -> label+  -> BoundaryVertexRef operand+  -> BoundaryVertexRef operand+  -> BoundaryEdgeRef operand+  -> SourceBoundary leftLabel rightLabel++data AtomicContribution leftLabel rightLabel =+  AtomicContribution !(SourceBoundary leftLabel rightLabel) !Bool++data AtomicEdge leftLabel rightLabel = AtomicEdge+  { atomicEdgeSegment :: !ExactSegment+  , atomicEdgeOrigin :: !OverlayEdgeOrigin+  , atomicEdgeLeftTransition :: !(Maybe (leftLabel, leftLabel))+  , atomicEdgeRightTransition :: !(Maybe (rightLabel, rightLabel))+  }++data OriginAccumulation = OriginAccumulation+  { accumulatedLeftVertices :: !(Set (BoundaryVertexRef 'LeftOverlayOperand))+  , accumulatedRightVertices :: !(Set (BoundaryVertexRef 'RightOverlayOperand))+  , accumulatedLeftEdges :: !(Set (BoundaryEdgeRef 'LeftOverlayOperand))+  , accumulatedRightEdges :: !(Set (BoundaryEdgeRef 'RightOverlayOperand))+  }++data OverlayVertexSeed = OverlayVertexSeed+  { seedExactPoint :: !ExactPoint+  , seedEmbeddedPoint :: !Point+  , seedOrigin :: !OverlayVertexOrigin+  }+  deriving stock (Eq, Ord, Show, Generic)++instance HasPosition OverlayVertexSeed where+  position = seedEmbeddedPoint++data ArrangementMetrics = ArrangementMetrics+  { arrangementInputSegments :: !Int+  , arrangementRelationEvents :: !Int+  , arrangementExactCrossings :: !Int+  , arrangementOverlapIntervals :: !Int+  , arrangementEmbeddingCandidates :: !Int+  , arrangementTotalRelationChecks :: !Int+  , arrangementSweepMaximumHeight :: !Int+  }++data CertifiedArrangement leftLabel rightLabel = CertifiedArrangement+  { certifiedAtomicEdges :: !(V.Vector (AtomicEdge leftLabel rightLabel))+  , certifiedVertexSeeds :: !(V.Vector OverlayVertexSeed)+  , certifiedConstraints :: !(V.Vector (Int, Int))+  , certifiedMetrics :: !ArrangementMetrics+  }++certifyArrangement+  :: (Ord leftLabel, Ord rightLabel)+  => PlanarLayer leftLabel+  -> PlanarLayer rightLabel+  -> Either+      (OverlayError leftLabel rightLabel)+      (CertifiedArrangement leftLabel rightLabel)+certifyArrangement leftLayer rightLayer = do+  sources <- flattenLayers leftLayer rightLayer+  sourcePlan <-+    first OverlaySegmentEventsInvalid+      (exactSegmentEventPlan (V.map sourceExactSegment sources))+  atomicEdges <- normalizeAtomicEdges leftLayer rightLayer sources sourcePlan+  let atomicVector = V.fromList atomicEdges+      pointIds = exactPointIds atomicVector+      origins = vertexOrigins sources atomicVector+      atomicRelations = atomicEndpointRelations atomicVector+  draft <- exactArrangementDraft sources sourcePlan atomicVector pointIds atomicRelations+  localCertificate <- first OverlayEmbeddingRefused (certifyLocalEmbedding draft)+  projectedPoints <- projectedExactPoints localCertificate+  projectedSegments <- projectedAtomicSegments atomicVector pointIds projectedPoints+  projectedPlan <-+    first OverlaySegmentEventsInvalid+      (exactSegmentEventPlan projectedSegments)+  dischargeGlobalRelations atomicRelations projectedPlan+  seeds <- overlayVertexSeeds pointIds origins localCertificate+  constraints <- atomicConstraints pointIds atomicVector+  let events = exactSegmentEvents sourcePlan+  pure+    CertifiedArrangement+      { certifiedAtomicEdges = atomicVector+      , certifiedVertexSeeds = seeds+      , certifiedConstraints = constraints+      , certifiedMetrics =+          ArrangementMetrics+            { arrangementInputSegments = V.length sources+            , arrangementRelationEvents = length events+            , arrangementExactCrossings =+                length [() | ExactProperCrossing {} <- events]+            , arrangementOverlapIntervals =+                length [() | ExactCollinearOverlap {} <- events]+            , arrangementEmbeddingCandidates = Map.size pointIds+            , arrangementTotalRelationChecks =+                exactSegmentPairChecks sourcePlan+                  + exactSegmentPairChecks projectedPlan+            , arrangementSweepMaximumHeight =+                max+                  (exactSegmentSweepMaximumHeight sourcePlan)+                  (exactSegmentSweepMaximumHeight projectedPlan)+            }+      }+flattenLayers+  :: PlanarLayer leftLabel+  -> PlanarLayer rightLabel+  -> Either (OverlayError leftLabel rightLabel) (V.Vector (SourceBoundary leftLabel rightLabel))+flattenLayers leftLayer rightLayer = do+  leftSources <- flattenLayer LeftSourceBoundary leftLayer+  rightSources <- flattenLayer RightSourceBoundary rightLayer+  pure (V.fromList (leftSources <> rightSources))++flattenLayer+  :: SourceBoundaryConstructor operand label leftLabel rightLabel+  -> PlanarLayer label+  -> Either (OverlayError leftLabel rightLabel) [SourceBoundary leftLabel rightLabel]+flattenLayer makeBoundary layer =+  fmap concat+    ( traverse+        (\(componentIndex, (label, component)) ->+           flattenComponent makeBoundary componentIndex label component)+        (zip [0 ..] (labelledComponents layer))+    )+{-# INLINE flattenLayer #-}++labelledComponents :: PlanarLayer label -> [(label, PolygonComponent)]+labelledComponents layer =+  [ (label, component)+  | (label, region) <- Map.toAscList (planarLayerRegions layer)+  , component <- planarRegionComponents region+  ]++flattenComponent+  :: SourceBoundaryConstructor operand label leftLabel rightLabel+  -> Int+  -> label+  -> PolygonComponent+  -> Either (OverlayError leftLabel rightLabel) [SourceBoundary leftLabel rightLabel]+flattenComponent makeBoundary componentIndex label component = do+  outer <-+    flattenLoop+      makeBoundary+      componentIndex+      BoundaryOuterLoop+      label+      (polygonOuterLoop component)+  holes <-+    fmap concat+      ( traverse+          (\(holeIndex, loop) ->+             flattenLoop+               makeBoundary+               componentIndex+               (BoundaryHoleLoop holeIndex)+               label+               loop)+          (zip [0 ..] (polygonHoleLoops component))+      )+  pure (outer <> holes)+{-# INLINE flattenComponent #-}++flattenLoop+  :: SourceBoundaryConstructor operand label leftLabel rightLabel+  -> Int+  -> BoundaryLoopRef+  -> label+  -> ExactLoop+  -> Either (OverlayError leftLabel rightLabel) [SourceBoundary leftLabel rightLabel]+flattenLoop makeBoundary componentIndex loopRef label loop =+  traverse constructSource (indexedCycle (exactLoopPoints loop))+ where+  constructSource (edgeIndex, fromIndex, from, toIndex, to) = do+    segment <- first (sourceGeometryError from) (exactSegment from to)+    pure+      ( makeBoundary+          segment+          label+          (BoundaryVertexRef componentIndex loopRef fromIndex)+          (BoundaryVertexRef componentIndex loopRef toIndex)+          (BoundaryEdgeRef componentIndex loopRef edgeIndex)+      )+{-# INLINE flattenLoop #-}++sourceGeometryError+  :: ExactPoint+  -> ExactGeometryError+  -> OverlayError leftLabel rightLabel+sourceGeometryError point _ = OverlayArrangementInvalid (OverlayRotationDegenerate point)++indexedCycle :: NonEmpty value -> [(Int, Int, value, Int, value)]+indexedCycle (firstValue :| remaining) =+  let values = firstValue : remaining+      count = length values+   in [ (index, index, from, (index + 1) `mod` count, to)+      | (index, (from, to)) <- zip [0 ..] (zip values (remaining <> [firstValue]))+      ]++sourceExactSegment :: SourceBoundary leftLabel rightLabel -> ExactSegment+sourceExactSegment (LeftSourceBoundary segment _ _ _ _) = segment+sourceExactSegment (RightSourceBoundary segment _ _ _ _) = segment++normalizeAtomicEdges+  :: (Ord leftLabel, Ord rightLabel)+  => PlanarLayer leftLabel+  -> PlanarLayer rightLabel+  -> V.Vector (SourceBoundary leftLabel rightLabel)+  -> ExactSegmentEventPlan+  -> Either (OverlayError leftLabel rightLabel) [AtomicEdge leftLabel rightLabel]+normalizeAtomicEdges leftLayer rightLayer sources plan =+  fmap concat+    ( traverse+        (resolveAtomicContributions leftOutside rightOutside)+        (Map.toAscList grouped)+    )+ where+  leftOutside = planarLayerOutsideLabel leftLayer+  rightOutside = planarLayerOutsideLabel rightLayer+  grouped =+    V.ifoldl'+      (\groups sourceIndex source ->+         foldl'+           (insertAtomic source)+           groups+           (consecutivePairs (exactSegmentSplitPoints plan (ExactSweepSegmentId sourceIndex))))+      Map.empty+      sources+  insertAtomic+    :: SourceBoundary leftLabel' rightLabel'+    -> Map ExactEdgeKey [AtomicContribution leftLabel' rightLabel']+    -> (ExactPoint, ExactPoint)+    -> Map ExactEdgeKey [AtomicContribution leftLabel' rightLabel']+  insertAtomic source groups (from, to)+    | from == to = groups+    | otherwise =+        let key@(canonicalFrom, _) = canonicalEdgeKey from to+            contribution = AtomicContribution source (from == canonicalFrom)+         in Map.insertWith (<>) key [contribution] groups++resolveAtomicContributions+  :: (Ord leftLabel, Ord rightLabel)+  => leftLabel+  -> rightLabel+  -> (ExactEdgeKey, [AtomicContribution leftLabel rightLabel])+  -> Either (OverlayError leftLabel rightLabel) [AtomicEdge leftLabel rightLabel]+resolveAtomicContributions leftOutside rightOutside ((from, to), contributions) = do+  let+      ( leftLabelsOnLeft+        , leftLabelsOnRight+        , rightLabelsOnLeft+        , rightLabelsOnRight+        , leftSources+        , rightSources+        ) =+          foldl'+            collectContribution+            (Set.empty, Set.empty, Set.empty, Set.empty, Set.empty, Set.empty)+            contributions+      origin =+        OverlayEdgeOrigin+          (Set.toAscList leftSources)+          (Set.toAscList rightSources)+  leftTransition <-+    resolveTransition+      OverlayLeftSourceSideConflict+      origin+      leftOutside+      leftLabelsOnLeft+      leftLabelsOnRight+  rightTransition <-+    resolveTransition+      OverlayRightSourceSideConflict+      origin+      rightOutside+      rightLabelsOnLeft+      rightLabelsOnRight+  if transitionIsIdentity leftTransition && transitionIsIdentity rightTransition+    then Right []+    else do+      segment <- first (sourceGeometryError from) (exactSegment from to)+      Right+        [ AtomicEdge+            { atomicEdgeSegment = segment+            , atomicEdgeOrigin = origin+            , atomicEdgeLeftTransition = leftTransition+            , atomicEdgeRightTransition = rightTransition+            }+        ]+ where+  collectContribution+    :: (Ord leftLabel', Ord rightLabel')+    => ( Set leftLabel'+       , Set leftLabel'+       , Set rightLabel'+       , Set rightLabel'+       , Set (BoundaryEdgeRef 'LeftOverlayOperand)+       , Set (BoundaryEdgeRef 'RightOverlayOperand)+       )+    -> AtomicContribution leftLabel' rightLabel'+    -> ( Set leftLabel'+       , Set leftLabel'+       , Set rightLabel'+       , Set rightLabel'+       , Set (BoundaryEdgeRef 'LeftOverlayOperand)+       , Set (BoundaryEdgeRef 'RightOverlayOperand)+       )+  collectContribution+    ( !leftLeft+      , !leftRight+      , !rightLeft+      , !rightRight+      , !leftSources+      , !rightSources+      )+    contribution =+    case contribution of+      AtomicContribution (LeftSourceBoundary _ label _ _ reference) follows ->+        ( if follows then Set.insert label leftLeft else leftLeft+        , if follows then leftRight else Set.insert label leftRight+        , rightLeft+        , rightRight+        , Set.insert reference leftSources+        , rightSources+        )+      AtomicContribution (RightSourceBoundary _ label _ _ reference) follows ->+        ( leftLeft+        , leftRight+        , if follows then Set.insert label rightLeft else rightLeft+        , if follows then rightRight else Set.insert label rightRight+        , leftSources+        , Set.insert reference rightSources+        )++resolveTransition+  :: (OverlayEdgeOrigin -> NonEmpty label -> OverlayArrangementObstruction leftLabel rightLabel)+  -> OverlayEdgeOrigin+  -> label+  -> Set label+  -> Set label+  -> Either (OverlayError leftLabel rightLabel) (Maybe (label, label))+resolveTransition sideConflict origin outside labelsOnLeft labelsOnRight+  | Set.null labelsOnLeft && Set.null labelsOnRight = Right Nothing+  | otherwise =+      Just+        <$> ((,)+               <$> resolveSide sideConflict origin outside labelsOnLeft+               <*> resolveSide sideConflict origin outside labelsOnRight)+{-# INLINE resolveTransition #-}++transitionIsIdentity :: Eq label => Maybe (label, label) -> Bool+transitionIsIdentity Nothing = True+transitionIsIdentity (Just (leftLabel, rightLabel)) = leftLabel == rightLabel++resolveSide+  :: (OverlayEdgeOrigin -> NonEmpty label -> OverlayArrangementObstruction leftLabel rightLabel)+  -> OverlayEdgeOrigin+  -> label+  -> Set label+  -> Either (OverlayError leftLabel rightLabel) label+resolveSide sideConflict origin outside labels =+  case Set.toAscList labels of+    [] -> Right outside+    [label] -> Right label+    firstLabel : remaining ->+      Left+        ( OverlayArrangementInvalid+            (sideConflict origin (firstLabel :| remaining))+        )+{-# INLINE resolveSide #-}++exactPointIds+  :: V.Vector (AtomicEdge leftLabel rightLabel)+  -> Map ExactPoint DraftVertexId+exactPointIds edges =+  Map.fromAscList+    ( zip+        (Set.toAscList (V.foldl' collect Set.empty edges))+      (map DraftVertexId [0 ..])+    )+ where+  collect+    :: Set ExactPoint+    -> AtomicEdge leftLabel rightLabel+    -> Set ExactPoint+  collect points edge = Set.insert (atomicEdgeFrom edge) (Set.insert (atomicEdgeTo edge) points)++vertexOrigins+  :: V.Vector (SourceBoundary leftLabel rightLabel)+  -> V.Vector (AtomicEdge leftLabel rightLabel)+  -> Map ExactPoint OverlayVertexOrigin+vertexOrigins sources atomicEdges =+  Map.map finalizeOrigin+    ( V.foldl'+        addAtomicOrigin+        (V.foldl' addSourceEndpoints Map.empty sources)+        atomicEdges+    )++emptyOrigin :: OriginAccumulation+emptyOrigin = OriginAccumulation Set.empty Set.empty Set.empty Set.empty++mergeOrigin :: OriginAccumulation -> OriginAccumulation -> OriginAccumulation+mergeOrigin left right =+  OriginAccumulation+    { accumulatedLeftVertices = accumulatedLeftVertices left <> accumulatedLeftVertices right+    , accumulatedRightVertices = accumulatedRightVertices left <> accumulatedRightVertices right+    , accumulatedLeftEdges = accumulatedLeftEdges left <> accumulatedLeftEdges right+    , accumulatedRightEdges = accumulatedRightEdges left <> accumulatedRightEdges right+    }++addSourceEndpoints+  :: Map ExactPoint OriginAccumulation+  -> SourceBoundary leftLabel rightLabel+  -> Map ExactPoint OriginAccumulation+addSourceEndpoints origins source =+  case source of+    LeftSourceBoundary segment _ fromReference toReference _ ->+      let (from, to) = exactSegmentEndpoints segment+       in insertOrigin to (emptyOrigin{accumulatedLeftVertices = Set.singleton toReference})+            (insertOrigin from (emptyOrigin{accumulatedLeftVertices = Set.singleton fromReference}) origins)+    RightSourceBoundary segment _ fromReference toReference _ ->+      let (from, to) = exactSegmentEndpoints segment+       in insertOrigin to (emptyOrigin{accumulatedRightVertices = Set.singleton toReference})+            (insertOrigin from (emptyOrigin{accumulatedRightVertices = Set.singleton fromReference}) origins)++addAtomicOrigin+  :: Map ExactPoint OriginAccumulation+  -> AtomicEdge leftLabel rightLabel+  -> Map ExactPoint OriginAccumulation+addAtomicOrigin origins edge =+  let origin = atomicEdgeOrigin edge+      accumulation =+        emptyOrigin+          { accumulatedLeftEdges = Set.fromList (overlayEdgeLeftSources origin)+          , accumulatedRightEdges = Set.fromList (overlayEdgeRightSources origin)+          }+   in insertOrigin (atomicEdgeTo edge) accumulation+        (insertOrigin (atomicEdgeFrom edge) accumulation origins)++insertOrigin+  :: ExactPoint+  -> OriginAccumulation+  -> Map ExactPoint OriginAccumulation+  -> Map ExactPoint OriginAccumulation+insertOrigin = Map.insertWith mergeOrigin++finalizeOrigin :: OriginAccumulation -> OverlayVertexOrigin+finalizeOrigin accumulated =+  OverlayVertexOrigin+    { overlayOriginLeftVertices = Set.toAscList (accumulatedLeftVertices accumulated)+    , overlayOriginRightVertices = Set.toAscList (accumulatedRightVertices accumulated)+    , overlayOriginLeftEdges = Set.toAscList (accumulatedLeftEdges accumulated)+    , overlayOriginRightEdges = Set.toAscList (accumulatedRightEdges accumulated)+    }++exactArrangementDraft+  :: V.Vector (SourceBoundary leftLabel rightLabel)+  -> ExactSegmentEventPlan+  -> V.Vector (AtomicEdge leftLabel rightLabel)+  -> Map ExactPoint DraftVertexId+  -> Map (ExactSweepSegmentId, ExactSweepSegmentId) SegmentRelation+  -> Either (OverlayError leftLabel rightLabel) ExactArrangementDraft+exactArrangementDraft sources sourcePlan atomicEdges pointIds atomicRelations = do+  draftSegmentsMap <-+    Map.fromList+      <$> traverse+        (\(segmentIndex, edge) -> do+           from <- requireDraftVertex pointIds (atomicEdgeFrom edge)+           to <- requireDraftVertex pointIds (atomicEdgeTo edge)+           pure (DraftSegmentId segmentIndex, (from, to)))+        (V.toList (V.indexed atomicEdges))+  memberships <-+    Map.fromList+      <$> traverse+        (\(sourceIndex, source) -> do+           values <-+             traverse+               (\point -> do+                  parameter <- exactSourceParameter source point+                  vertex <- requireDraftVertex pointIds point+                  pure (parameter, vertex))+               (exactSegmentSplitPoints sourcePlan (ExactSweepSegmentId sourceIndex))+           pure (DraftSourceId sourceIndex, values))+        (V.toList (V.indexed sources))+  neighborhoods <- buildDraftNeighborhoods atomicEdges pointIds+  let incidences =+        [ DraftIncidence+            (DraftSegmentId leftIndex)+            (DraftSegmentId rightIndex)+            relation+        | ((ExactSweepSegmentId leftIndex, ExactSweepSegmentId rightIndex), relation) <-+            Map.toAscList atomicRelations+        ]+  pure+    ExactArrangementDraft+      { draftVertices = Map.fromList [(vertexId, point) | (point, vertexId) <- Map.toAscList pointIds]+      , draftSegments = draftSegmentsMap+      , draftSourceMemberships = memberships+      , draftIncidences = incidences+      , draftNeighborhoods = neighborhoods+      }++requireDraftVertex+  :: Map ExactPoint DraftVertexId+  -> ExactPoint+  -> Either (OverlayError leftLabel rightLabel) DraftVertexId+requireDraftVertex pointIds point =+  case Map.lookup point pointIds of+    Just vertex -> Right vertex+    Nothing -> Left (OverlayProvenanceIncomplete (OverlayExactVertexMissing point))++exactSourceParameter+  :: SourceBoundary leftLabel rightLabel+  -> ExactPoint+  -> Either (OverlayError leftLabel rightLabel) ExactRational+exactSourceParameter source point =+  let (from, to) = exactSegmentEndpoints (sourceExactSegment source)+      (fromX, fromY) = exactPointCoordinates from+      (toX, toY) = exactPointCoordinates to+      (pointX, pointY) = exactPointCoordinates point+      (numerator, denominator) =+        if exactRationalIsZero (toX - fromX)+          then (pointY - fromY, toY - fromY)+          else (pointX - fromX, toX - fromX)+   in first OverlayExactArithmetic (exactDivide numerator denominator)++buildDraftNeighborhoods+  :: V.Vector (AtomicEdge leftLabel rightLabel)+  -> Map ExactPoint DraftVertexId+  -> Either (OverlayError leftLabel rightLabel) [DraftNeighborhood]+buildDraftNeighborhoods edges pointIds =+  traverse neighborhood (Map.toAscList pointIds)+ where+  neighborhood (centerPoint, centerId) = do+    let neighbors = Map.findWithDefault Set.empty centerPoint adjacency+    orderedPoints <-+      case NonEmpty.nonEmpty (sortBy (compareAround centerPoint) (Set.toList neighbors)) of+        Just points -> Right points+        Nothing -> Left (OverlayArrangementInvalid (OverlayRotationDegenerate centerPoint))+    orderedIds <- traverse (requireDraftVertex pointIds) orderedPoints+    pure (DraftNeighborhood centerId orderedIds)+  adjacency =+    V.foldl'+      (\graph edge ->+         Map.insertWith Set.union (atomicEdgeTo edge) (Set.singleton (atomicEdgeFrom edge))+           (Map.insertWith Set.union (atomicEdgeFrom edge) (Set.singleton (atomicEdgeTo edge)) graph))+      Map.empty+      edges++compareAround :: ExactPoint -> ExactPoint -> ExactPoint -> Ordering+compareAround center left right =+  case+    compareExactVectorAngle+      (exactVectorFromPoints center left)+      (exactVectorFromPoints center right) of+    EQ -> compare left right+    ordering -> ordering++-- | Normalization splits every source at every exact event and coalesces+-- duplicate intervals. Distinct atomics can therefore meet only at a stored+-- endpoint; their entire relation section is the endpoint-incidence index.+atomicEndpointRelations+  :: V.Vector (AtomicEdge leftLabel rightLabel)+  -> Map (ExactSweepSegmentId, ExactSweepSegmentId) SegmentRelation+atomicEndpointRelations edges =+  Map.fromList+    [ ( orderedPair+          (ExactSweepSegmentId leftIndex)+          (ExactSweepSegmentId rightIndex)+      , SegmentsShareEndpoint+      )+    | incident <- Map.elems incidenceByPoint+    , (leftIndex, rightIndex) <- unorderedPairs (Set.toAscList incident)+    ]+ where+  incidenceByPoint =+    V.ifoldl'+      (\incidence index edge ->+         Map.insertWith Set.union (atomicEdgeTo edge) (Set.singleton index)+           ( Map.insertWith Set.union+               (atomicEdgeFrom edge)+               (Set.singleton index)+               incidence+           ))+      Map.empty+      edges+projectedExactPoints+  :: LocalEmbeddingCertificate+  -> Either (OverlayError leftLabel rightLabel) (Map DraftVertexId ExactPoint)+projectedExactPoints certificate =+  Map.traverseWithKey+    (\vertex point ->+       first+         (\projectionError ->+            OverlayEmbeddingRefused+              (VertexProjectionRefused vertex projectionError :| []))+         (exactPointFromPoint point))+    (certificateRoundedVertices certificate)++projectedAtomicSegments+  :: V.Vector (AtomicEdge leftLabel rightLabel)+  -> Map ExactPoint DraftVertexId+  -> Map DraftVertexId ExactPoint+  -> Either (OverlayError leftLabel rightLabel) (V.Vector ExactSegment)+projectedAtomicSegments edges pointIds projected =+  V.imapM project edges+ where+  project segmentIndex edge = do+    fromId <- requireDraftVertex pointIds (atomicEdgeFrom edge)+    toId <- requireDraftVertex pointIds (atomicEdgeTo edge)+    from <- requireProjected fromId+    to <- requireProjected toId+    first+      (\_ ->+         OverlayEmbeddingRefused+           ( ProjectedSegmentCollapsed+               (DraftSegmentId segmentIndex)+               fromId+               toId+               :| []+           ))+      (exactSegment from to)+  requireProjected vertex =+    case Map.lookup vertex projected of+      Just point -> Right point+      Nothing ->+        Left+          ( OverlayEmbeddingRefused+              (DraftReferenceMissing (DraftVertexReference vertex) :| [])+          )++dischargeGlobalRelations+  :: Map (ExactSweepSegmentId, ExactSweepSegmentId) SegmentRelation+  -> ExactSegmentEventPlan+  -> Either (OverlayError leftLabel rightLabel) ()+dischargeGlobalRelations exactRelations projectedPlan =+  case NonEmpty.nonEmpty obstructions of+    Nothing -> Right ()+    Just failures -> Left (OverlayEmbeddingRefused failures)+ where+  projectedRelations = exactSegmentRelationMap projectedPlan+  keys = Set.toAscList (Map.keysSet exactRelations <> Map.keysSet projectedRelations)+  obstructions = concatMap compareRelation keys+  compareRelation key@(ExactSweepSegmentId leftId, ExactSweepSegmentId rightId) =+    case (Map.lookup key exactRelations, Map.lookup key projectedRelations) of+      (Nothing, Just projected) ->+        [GlobalRelationAdded (DraftSegmentId leftId) (DraftSegmentId rightId) projected]+      (Just exact, Nothing) ->+        [GlobalRelationRemoved (DraftSegmentId leftId) (DraftSegmentId rightId) exact]+      (Just exact, Just projected)+        | exact /= projected ->+            [GlobalRelationChanged (DraftSegmentId leftId) (DraftSegmentId rightId) exact projected]+      _ -> []++overlayVertexSeeds+  :: Map ExactPoint DraftVertexId+  -> Map ExactPoint OverlayVertexOrigin+  -> LocalEmbeddingCertificate+  -> Either (OverlayError leftLabel rightLabel) (V.Vector OverlayVertexSeed)+overlayVertexSeeds pointIds origins certificate =+  V.fromList+    <$> traverse+      (\(point, vertexId) -> do+         embedded <-+           case Map.lookup vertexId (certificateRoundedVertices certificate) of+             Just value -> Right value+             Nothing ->+               Left+                 ( OverlayEmbeddingRefused+                     (DraftReferenceMissing (DraftVertexReference vertexId) :| [])+                 )+         origin <-+           case Map.lookup point origins of+             Just value -> Right value+             Nothing -> Left (OverlayProvenanceIncomplete (OverlayExactVertexMissing point))+         pure (OverlayVertexSeed point embedded origin))+      (Map.toAscList pointIds)++atomicConstraints+  :: Map ExactPoint DraftVertexId+  -> V.Vector (AtomicEdge leftLabel rightLabel)+  -> Either (OverlayError leftLabel rightLabel) (V.Vector (Int, Int))+atomicConstraints pointIds =+  V.mapM+    (\edge -> do+       DraftVertexId from <- requireDraftVertex pointIds (atomicEdgeFrom edge)+       DraftVertexId to <- requireDraftVertex pointIds (atomicEdgeTo edge)+       pure (from, to))+++canonicalEdgeKey :: ExactPoint -> ExactPoint -> ExactEdgeKey+canonicalEdgeKey = orderedPair++atomicEdgeFrom :: AtomicEdge leftLabel rightLabel -> ExactPoint+atomicEdgeFrom = fst . exactSegmentEndpoints . atomicEdgeSegment++atomicEdgeTo :: AtomicEdge leftLabel rightLabel -> ExactPoint+atomicEdgeTo = snd . exactSegmentEndpoints . atomicEdgeSegment++atomicKey :: AtomicEdge leftLabel rightLabel -> ExactEdgeKey+atomicKey edge = (atomicEdgeFrom edge, atomicEdgeTo edge)
+ src-build/Moonlight/Triangulation/Internal/Overlay/Resident.hs view
@@ -0,0 +1,868 @@+{-# LANGUAGE DataKinds #-}++-- | Resident DCEL descent and exact-cell gluing. The certified arrangement is+-- authoritative at this seam; diagonal schedules may change only its resident+-- triangulation, never its exact cell descriptors.+module Moonlight.Triangulation.Internal.Overlay.Resident+  ( OverlayDiagonalSchedule (..)+  , residentOverlay+  , faceLabels+  , regionFaceLabels+  , vertexSupport+  , edgeSupport+  ) where++import Control.Monad (foldM)+import Data.Bifunctor (first)+import Data.Foldable (traverse_)+import Data.List (partition, sort, sortBy)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Maybe (listToMaybe, mapMaybe)+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Vector as V+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.Dcel+  ( faceData+  , faceDirectedEdges+  , imapUndirectedEdges+  , incidentFace+  , isConstraintEdge+  , numInnerFaces+  , numVertices+  , outerFace+  , undirectedEndpoints+  , vertexData+  , vertexOutgoingEdges+  )+import Moonlight.Triangulation.Exact (ExactPoint, exactOrient2d)+import Moonlight.Triangulation.FloodFillIterator+  ( FaceComponent+  , componentBoundary+  , faceComponentFaces+  , faceComponents+  )+import Moonlight.Triangulation.Handles.HandleDefs+  ( DirectedEdgeId+  , FaceId+  , UndirectedEdgeId+  , VertexId+  , asUndirected+  , directedPair+  , reverseEdge+  )+import Moonlight.Triangulation.Handles.Iterators.FixedIterators+  ( allFaces+  , innerFaces+  , undirectedEdges+  )+import Moonlight.Triangulation.Internal.BoxedPaged (boxedFromVector)+import Moonlight.Triangulation.Internal.BoundaryCycle (consecutivePairs)+import Moonlight.Triangulation.Internal.Canonical (canonicalize)+import Moonlight.Triangulation.Internal.Cdt.Build (constrainedDelaunay)+import Moonlight.Triangulation.Internal.Cdt.Types (CdtError (..))+import Moonlight.Triangulation.Internal.Overlay.Arrangement+  ( ArrangementMetrics (..)+  , AtomicEdge (..)+  , atomicEdgeFrom+  , atomicEdgeTo+  , CertifiedArrangement (..)+  , ExactEdgeKey+  , OverlayVertexSeed (..)+  , atomicKey+  , canonicalEdgeKey+  , compareAround+  )+import Moonlight.Triangulation.Internal.Overlay.Types+import Moonlight.Triangulation.Internal.Region.Publication+  ( polygonComponentFromBoundaryCoordinates+  )+import Moonlight.Triangulation.Internal.Region.Types+  ( ExactLoop+  , PolygonComponent+  , RegionPublicationError (..)+  )+import Moonlight.Triangulation.Internal.Representation+  ( BuildResult (..)+  , Triangulation (..)+  )+import Moonlight.Triangulation.Internal.Types+  ( ConstraintMode (Constrained)+  , ElementDefaults (..)+  )+import Moonlight.Triangulation.Region (exactLoop)++data OverlayDiagonalSchedule+  = CanonicalOverlayDiagonals+  | FlipFirstAdmissibleDiagonal+  deriving stock (Eq, Ord, Show)++data ComponentDraft leftLabel rightLabel = ComponentDraft+  { componentDraftLabels :: !(leftLabel, rightLabel)+  , componentDraftFaces :: !FaceComponent+  , componentDraftPolygon :: !PolygonComponent+  , componentDraftTouchesOuter :: !Bool+  }++residentOverlay+  :: (Ord leftLabel, Ord rightLabel)+  => OverlayDiagonalSchedule+  -> (leftLabel, rightLabel)+  -> CertifiedArrangement leftLabel rightLabel+  -> Either+      (OverlayError leftLabel rightLabel)+      (OverlayResult leftLabel rightLabel)+residentOverlay diagonalSchedule outsidePair certified = do+  let atomicVector = certifiedAtomicEdges certified+      seeds = certifiedVertexSeeds certified+      constraints = certifiedConstraints certified+      metrics = certifiedMetrics certified+      defaults = ElementDefaults () () ()+  built <- first OverlayBuildFailed (constrainedDelaunay defaults seeds constraints)+  let resident = buildTriangulation built+  if numVertices resident == V.length seeds+    then Right ()+    else+      Left+        ( OverlayProvenanceIncomplete+            (OverlayEmbeddedVertexCountMismatch (V.length seeds) (numVertices resident))+        )+  canonicalResident <-+    first (OverlayBuildFailed . CdtBuildError) (canonicalize resident)+  let atomicByKey =+        Map.fromList+          [ (atomicKey edge, edge)+          | edge <- V.toList atomicVector+          ]+  validateAtomicConstraints canonicalResident atomicByKey+  scheduledResident <-+    applyDiagonalSchedule+      diagonalSchedule+      defaults+      seeds+      constraints+      canonicalResident+  labelledFaces <- labelResidentFaces outsidePair scheduledResident atomicByKey+  componentDrafts <- residentComponentDrafts scheduledResident labelledFaces+  let (unboundedDrafts, boundedDrafts) =+        partitionDrafts outsidePair componentDrafts+  numberedBounded <- numberBoundedComponents boundedDrafts+  let cellIdByFace =+        Map.fromList+          ( [ (face, OverlayCellId 0)+            | draftComponent <- unboundedDrafts+            , face <- faceComponentFaces (componentDraftFaces draftComponent)+            ]+              <> [ (face, cellId)+                 | (cellId, draftComponent) <- numberedBounded+                 , face <- faceComponentFaces (componentDraftFaces draftComponent)+                 ]+          )+  unboundedLoops <-+    unboundedCellBoundaryLoops scheduledResident atomicByKey cellIdByFace+  let cells =+        V.fromList+          ( OverlayCell+              { overlayCellLeft = fst outsidePair+              , overlayCellRight = snd outsidePair+              , overlayCellGeometry = UnboundedOverlayCell unboundedLoops+              }+              : [ OverlayCell+                    { overlayCellLeft = fst (componentDraftLabels draftComponent)+                    , overlayCellRight = snd (componentDraftLabels draftComponent)+                    , overlayCellGeometry =+                        BoundedOverlayCell (componentDraftPolygon draftComponent)+                    }+                | (_, draftComponent) <- numberedBounded+                ]+          )+  withFaces <- attachFaceCells cellIdByFace scheduledResident+  let withVertices = attachOverlayVertices withFaces+      withEdges =+        imapUndirectedEdges+          OverlayDiagonal+          (\edge _ ->+             case Map.lookup (residentEdgeKey withVertices edge) atomicByKey of+               Nothing -> OverlayDiagonal+               Just atomic -> OverlayBoundary (atomicEdgeOrigin atomic))+          withVertices+      receipt =+        OverlayReceipt+          { overlayInputSegments = arrangementInputSegments metrics+          , overlayRelationEvents = arrangementRelationEvents metrics+          , overlayExactCrossings = arrangementExactCrossings metrics+          , overlayOverlapIntervals = arrangementOverlapIntervals metrics+          , overlayAtomicEdges = V.length atomicVector+          , overlayOutputVertices = numVertices withEdges+          , overlayArrangementCells = V.length cells+          , overlayResidentFaces = numInnerFaces withEdges+          , overlayEmbeddingCandidates = arrangementEmbeddingCandidates metrics+          , overlayTotalRelationChecks = arrangementTotalRelationChecks metrics+          , overlaySweepMaximumHeight = arrangementSweepMaximumHeight metrics+          }+  pure+    OverlayResult+      { overlayResultTriangulation = withEdges+      , overlayResultCells = cells+      , overlayResultOutsideLabels = outsidePair+      , overlayResultReceipt = receipt+      }++applyDiagonalSchedule+  :: OverlayDiagonalSchedule+  -> ElementDefaults () () ()+  -> V.Vector OverlayVertexSeed+  -> V.Vector (Int, Int)+  -> Triangulation 'Constrained OverlayVertexSeed () () ()+  -> Either+      (OverlayError leftLabel rightLabel)+      (Triangulation 'Constrained OverlayVertexSeed () () ())+applyDiagonalSchedule CanonicalOverlayDiagonals _ _ _ triangulation =+  Right triangulation+applyDiagonalSchedule+  FlipFirstAdmissibleDiagonal+  defaults+  seeds+  constraints+  triangulation =+    case firstAlternativeDiagonal triangulation of+      Nothing -> Right triangulation+      Just (from, to) -> do+        let indexByPoint =+              Map.fromList+                [ (seedExactPoint seed, index)+                | (index, seed) <- V.toList (V.indexed seeds)+                ]+        fromIndex <- requireSeedIndex indexByPoint from+        toIndex <- requireSeedIndex indexByPoint to+        rebuilt <-+          first OverlayBuildFailed+            (constrainedDelaunay defaults seeds (V.snoc constraints (fromIndex, toIndex)))+        first (OverlayBuildFailed . CdtBuildError)+          (canonicalize (buildTriangulation rebuilt))++requireSeedIndex+  :: Map ExactPoint Int+  -> ExactPoint+  -> Either (OverlayError leftLabel rightLabel) Int+requireSeedIndex indexByPoint point =+  case Map.lookup point indexByPoint of+    Just index -> Right index+    Nothing -> Left (OverlayProvenanceIncomplete (OverlayExactVertexMissing point))++firstAlternativeDiagonal+  :: Triangulation 'Constrained OverlayVertexSeed () () ()+  -> Maybe ExactEdgeKey+firstAlternativeDiagonal triangulation =+  listToMaybe+    (mapMaybe (alternativeDiagonal triangulation) (undirectedEdges triangulation))++alternativeDiagonal+  :: Triangulation 'Constrained OverlayVertexSeed () () ()+  -> UndirectedEdgeId+  -> Maybe ExactEdgeKey+alternativeDiagonal triangulation edge+  | isConstraintEdge triangulation edge = Nothing+  | leftFace == outerFace || rightFace == outerFace = Nothing+  | exactOrient2d c d b == GT && exactOrient2d d c a == GT =+      Just (canonicalEdgeKey c d)+  | otherwise = Nothing+ where+  (forward, backward) = directedPair edge+  leftFace = incidentFace triangulation forward+  rightFace = incidentFace triangulation backward+  a = seedExactPoint (vertexData triangulation (Dcel.origin triangulation forward))+  b = seedExactPoint (vertexData triangulation (Dcel.origin triangulation backward))+  c =+    seedExactPoint+      (vertexData triangulation (Dcel.origin triangulation (Dcel.previous triangulation forward)))+  d =+    seedExactPoint+      (vertexData triangulation (Dcel.origin triangulation (Dcel.previous triangulation backward)))+labelResidentFaces+  :: (Ord leftLabel, Ord rightLabel)+  => (leftLabel, rightLabel)+  -> Triangulation 'Constrained OverlayVertexSeed () () ()+  -> Map ExactEdgeKey (AtomicEdge leftLabel rightLabel)+  -> Either+      (OverlayError leftLabel rightLabel)+      (Map FaceId (leftLabel, rightLabel))+labelResidentFaces outsideLabels triangulation atomicByKey = do+  labelled <-+    descendFaceTransitions+      triangulation+      atomicByKey+      (Map.singleton outerFace outsideLabels)+      (Seq.singleton outerFace)+  case+    [ face+    | face <- innerFaces triangulation+    , Map.notMember face labelled+    ] of+    missing : _ ->+      Left (OverlayProvenanceIncomplete (OverlayResidentFaceUnassigned missing))+    [] -> Right (Map.delete outerFace labelled)++seedDirectedEndpoints+  :: Triangulation mode OverlayVertexSeed directed undirected face+  -> DirectedEdgeId+  -> ExactEdgeKey+seedDirectedEndpoints triangulation edge =+  ( seedExactPoint (vertexData triangulation (Dcel.origin triangulation edge))+  , seedExactPoint (vertexData triangulation (Dcel.destination triangulation edge))+  )++swapTransition :: (label, label) -> (label, label)+swapTransition (fromLabel, toLabel) = (toLabel, fromLabel)++descendFaceTransitions+  :: (Eq leftLabel, Eq rightLabel)+  => Triangulation 'Constrained OverlayVertexSeed () () ()+  -> Map ExactEdgeKey (AtomicEdge leftLabel rightLabel)+  -> Map FaceId (leftLabel, rightLabel)+  -> Seq.Seq FaceId+  -> Either+      (OverlayError leftLabel rightLabel)+      (Map FaceId (leftLabel, rightLabel))+descendFaceTransitions triangulation atomicByKey labelled queued =+  case Seq.viewl queued of+    Seq.EmptyL -> Right labelled+    face Seq.:< remaining ->+      case Map.lookup face labelled of+        Nothing ->+          Left (OverlayProvenanceIncomplete (OverlayResidentFaceUnassigned face))+        Just current -> do+          (nextLabels, nextQueue) <-+            foldM+              (descendFaceTransition triangulation atomicByKey face current)+              (labelled, remaining)+              (faceDirectedEdges triangulation face)+          descendFaceTransitions triangulation atomicByKey nextLabels nextQueue++descendFaceTransition+  :: (Eq leftLabel, Eq rightLabel)+  => Triangulation 'Constrained OverlayVertexSeed () () ()+  -> Map ExactEdgeKey (AtomicEdge leftLabel rightLabel)+  -> FaceId+  -> (leftLabel, rightLabel)+  -> (Map FaceId (leftLabel, rightLabel), Seq.Seq FaceId)+  -> DirectedEdgeId+  -> Either+      (OverlayError leftLabel rightLabel)+      (Map FaceId (leftLabel, rightLabel), Seq.Seq FaceId)+descendFaceTransition triangulation atomicByKey source current (labelled, queued) directed = do+  let edge = asUndirected directed+      destinationFace = incidentFace triangulation (reverseEdge directed)+  (leftTransition, rightTransition) <-+    case Map.lookup (residentSeedEdgeKey triangulation edge) atomicByKey of+      Nothing -> Right (Nothing, Nothing)+      Just atomic -> orientedTransitions edge directed atomic+  let+      expected =+        ( maybe (fst current) fst leftTransition+        , maybe (snd current) fst rightTransition+        )+      derived =+        ( maybe (fst current) snd leftTransition+        , maybe (snd current) snd rightTransition+        )+  if current == expected+    then+      case Map.lookup destinationFace labelled of+        Nothing ->+          Right+            ( Map.insert destinationFace derived labelled+            , queued Seq.|> destinationFace+            )+        Just existing+          | existing == derived -> Right (labelled, queued)+          | otherwise ->+              Left+                ( OverlayArrangementInvalid+                    ( OverlayResidentFaceLabelConflict+                        destinationFace+                        edge+                        existing+                        derived+                    )+                )+    else+      Left+        ( OverlayArrangementInvalid+            (OverlayTransitionSourceMismatch source edge current expected)+        )+ where+  orientedTransitions edge candidateDirection atomic+    | directedEndpoints == (atomicEdgeFrom atomic, atomicEdgeTo atomic) =+        Right+          ( atomicEdgeLeftTransition atomic+          , atomicEdgeRightTransition atomic+          )+    | directedEndpoints == (atomicEdgeTo atomic, atomicEdgeFrom atomic) =+        Right+          ( swapTransition <$> atomicEdgeLeftTransition atomic+          , swapTransition <$> atomicEdgeRightTransition atomic+          )+    | otherwise =+        Left+          ( OverlayProvenanceIncomplete+              ( OverlayAtomicConstraintOrientationMismatch+                  edge+                  (atomicEdgeFrom atomic)+                  (atomicEdgeTo atomic)+              )+          )+   where+    directedEndpoints = seedDirectedEndpoints triangulation candidateDirection++residentComponentDrafts+  :: (Ord leftLabel, Ord rightLabel)+  => Triangulation 'Constrained OverlayVertexSeed () () ()+  -> Map FaceId (leftLabel, rightLabel)+  -> Either+      (OverlayError leftLabel rightLabel)+      [ComponentDraft leftLabel rightLabel]+residentComponentDrafts triangulation labels =+  traverse convert (faceComponents triangulation (`Map.lookup` labels))+ where+  exactPointAt vertex =+    Right (seedExactPoint (vertexData triangulation vertex))+  convert (maybeLabels, component) = do+    componentLabels <-+      case maybeLabels of+        Just value -> Right value+        Nothing ->+          case faceComponentFaces component of+            face : _ -> Left (OverlayProvenanceIncomplete (OverlayResidentFaceUnassigned face))+            [] -> Left (OverlayArrangementInvalid OverlayFaceComponentEmpty)+    boundary <-+      first+        (OverlayRegionPublicationFailed . RegionBoundaryObstruction)+        (componentBoundary triangulation component)+    polygon <-+      first OverlayRegionPublicationFailed+        (polygonComponentFromBoundaryCoordinates exactPointAt boundary)+    pure+      ComponentDraft+        { componentDraftLabels = componentLabels+        , componentDraftFaces = component+        , componentDraftPolygon = polygon+        , componentDraftTouchesOuter = touchesOuter triangulation component+        }++touchesOuter+  :: Triangulation mode vertex directed undirected face+  -> FaceComponent+  -> Bool+touchesOuter triangulation component =+  any+    ( any ((== outerFace) . incidentFace triangulation . reverseEdge)+        . faceDirectedEdges triangulation+    )+    (faceComponentFaces component)++partitionDrafts+  :: (Eq leftLabel, Eq rightLabel)+  => (leftLabel, rightLabel)+  -> [ComponentDraft leftLabel rightLabel]+  -> ([ComponentDraft leftLabel rightLabel], [ComponentDraft leftLabel rightLabel])+partitionDrafts outsidePair =+  partition+    (\draftComponent ->+       componentDraftTouchesOuter draftComponent+         && componentDraftLabels draftComponent == outsidePair)++sortComponentDrafts+  :: (Ord leftLabel, Ord rightLabel)+  => [ComponentDraft leftLabel rightLabel]+  -> [ComponentDraft leftLabel rightLabel]+sortComponentDrafts =+  sortBy+    (\left right ->+       compare+         (componentDraftPolygon left, componentDraftLabels left)+         (componentDraftPolygon right, componentDraftLabels right))++numberBoundedComponents+  :: (Ord leftLabel, Ord rightLabel)+  => [ComponentDraft leftLabel rightLabel]+  -> Either+      (OverlayError leftLabel rightLabel)+      [(OverlayCellId, ComponentDraft leftLabel rightLabel)]+numberBoundedComponents drafts =+  case+    [ componentDraftPolygon left+    | (left, right) <- consecutivePairs ordered+    , componentSignature left == componentSignature right+    ] of+    duplicate : _ ->+      Left+        ( OverlayArrangementInvalid+            (OverlayDuplicateCellSignature duplicate)+        )+    [] ->+      Right+        ( zipWith+            (\index component -> (OverlayCellId index, component))+            [1 ..]+            ordered+        )+ where+  ordered = sortComponentDrafts drafts+  componentSignature+    :: ComponentDraft leftLabel' rightLabel'+    -> (PolygonComponent, (leftLabel', rightLabel'))+  componentSignature component =+    (componentDraftPolygon component, componentDraftLabels component)++-- | Trace the finite boundary cycles of the unbounded exact cell from atomic+-- edges only. Resident hull edges and Delaunay diagonals are absent by+-- construction; the DCEL contributes only the already-proved incident-cell+-- gluing needed to orient each atomic edge with cell zero on its left.+unboundedCellBoundaryLoops+  :: Triangulation 'Constrained OverlayVertexSeed () () ()+  -> Map ExactEdgeKey (AtomicEdge leftLabel rightLabel)+  -> Map FaceId OverlayCellId+  -> Either (OverlayError leftLabel rightLabel) [ExactLoop]+unboundedCellBoundaryLoops triangulation atomicByKey cellIdByFace = do+  orientedEdges <-+    Set.fromList . concat+      <$> traverse orientAtomicEdge (undirectedEdges triangulation)+  traceBoundaryCycles orientedEdges+ where+  orientAtomicEdge edge+    | Map.notMember (residentSeedEdgeKey triangulation edge) atomicByKey = Right []+    | otherwise = do+        let (forward, backward) = directedPair edge+        forwardCell <- faceCellId (incidentFace triangulation forward)+        backwardCell <- faceCellId (incidentFace triangulation backward)+        pure+          ( case (forwardCell == OverlayCellId 0, backwardCell == OverlayCellId 0) of+              (True, False) -> [seedDirectedEndpoints triangulation forward]+              (False, True) -> [seedDirectedEndpoints triangulation backward]+              _ -> []+          )+  faceCellId face+    | face == outerFace = Right (OverlayCellId 0)+    | otherwise =+        case Map.lookup face cellIdByFace of+          Just cellId -> Right cellId+          Nothing -> Left (OverlayProvenanceIncomplete (OverlayResidentFaceUnassigned face))++traceBoundaryCycles+  :: Set ExactEdgeKey+  -> Either (OverlayError leftLabel rightLabel) [ExactLoop]+traceBoundaryCycles orientedEdges = descend orientedEdges []+ where+  outgoing =+    Map.mapWithKey orderAroundOrigin+      ( Set.foldl'+          (\byOrigin edge@(from, _) -> Map.insertWith (<>) from [edge] byOrigin)+          Map.empty+          orientedEdges+      )+  orderAroundOrigin :: ExactPoint -> [ExactEdgeKey] -> [ExactEdgeKey]+  orderAroundOrigin origin =+    sortBy (\(_, left) (_, right) -> compareAround origin left right)+  descend remaining cycles =+    case Set.lookupMin remaining of+      Nothing -> Right (sort cycles)+      Just seed ->+        let (untraced, circuit) = boundaryEulerCircuit outgoing remaining (fst seed)+         in case splitBoundaryCircuit circuit of+          Nothing ->+            Left+              ( OverlayArrangementInvalid+                  (uncurry OverlayCellCycleDidNotClose seed)+              )+          Just pointCycles -> do+            loops <-+              traverse+                ( first+                    (OverlayRegionPublicationFailed . RegionValidationObstruction)+                    . exactLoop+                )+                pointCycles+            descend untraced (loops <> cycles)++-- | Consume one directed Eulerian boundary component. Each edge is deleted+-- exactly once; circuit extraction therefore cannot acquire the exponential+-- branch factor of simple-cycle backtracking at point contacts.+boundaryEulerCircuit+  :: Map ExactPoint [ExactEdgeKey]+  -> Set ExactEdgeKey+  -> ExactPoint+  -> (Set ExactEdgeKey, [ExactEdgeKey])+boundaryEulerCircuit outgoing remaining start =+  descend remaining [start] [] []+ where+  descend untraced vertexStack incomingEdges circuit =+    case vertexStack of+      [] -> (untraced, circuit)+      vertex : previousVertices ->+        case nextUntracedEdge vertex untraced of+          Just edge ->+            descend+              (Set.delete edge untraced)+              (snd edge : vertexStack)+              (edge : incomingEdges)+              circuit+          Nothing ->+            case incomingEdges of+              edge : previousEdges ->+                descend+                  untraced+                  previousVertices+                  previousEdges+                  (edge : circuit)+              [] -> (untraced, circuit)+  nextUntracedEdge vertex untraced =+    case+        [ edge+        | edge <- Map.findWithDefault [] vertex outgoing+        , Set.member edge untraced+        ] of+      edge : _ -> Just edge+      [] -> Nothing++-- | Split an Euler circuit at repeated vertices. The maintained path is+-- simple; closing against any resident path vertex emits one simple cycle and+-- deletes precisely that suffix before descent continues.+splitBoundaryCircuit :: [ExactEdgeKey] -> Maybe [NonEmpty ExactPoint]+splitBoundaryCircuit circuit =+  case circuit of+    [] -> Nothing+    (start, _) : _ ->+      reverse+        <$> descend+          start+          0+          (Map.singleton start 0)+          [start]+          []+          []+          circuit+ where+  descend+    :: ExactPoint+    -> Int+    -> Map ExactPoint Int+    -> [ExactPoint]+    -> [ExactEdgeKey]+    -> [NonEmpty ExactPoint]+    -> [ExactEdgeKey]+    -> Maybe [NonEmpty ExactPoint]+  descend+    current+    currentDepth+    depthByPoint+    reversedPathPoints+    reversedPathEdges+    cycles+    remainingEdges =+      case remainingEdges of+        []+          | currentDepth == 0+          , [_] <- reversedPathPoints+          , null reversedPathEdges -> Just cycles+          | otherwise -> Nothing+        edge@(fromPoint, toPoint) : rest+          | fromPoint /= current -> Nothing+          | otherwise ->+              case Map.lookup toPoint depthByPoint of+                Nothing ->+                  descend+                    toPoint+                    (currentDepth + 1)+                    (Map.insert toPoint (currentDepth + 1) depthByPoint)+                    (toPoint : reversedPathPoints)+                    (edge : reversedPathEdges)+                    cycles+                    rest+                Just repeatedDepth ->+                  let cyclePathLength = currentDepth - repeatedDepth+                      removedPoints = take cyclePathLength reversedPathPoints+                      cycleEdges = reverse (edge : take cyclePathLength reversedPathEdges)+                      remainingPathPoints = drop cyclePathLength reversedPathPoints+                      remainingPathEdges = drop cyclePathLength reversedPathEdges+                      remainingDepths =+                        foldr Map.delete depthByPoint removedPoints+                   in case NonEmpty.nonEmpty (map fst cycleEdges) of+                        Nothing -> Nothing+                        Just cyclePoints ->+                          descend+                            toPoint+                            repeatedDepth+                            remainingDepths+                            remainingPathPoints+                            remainingPathEdges+                            (cyclePoints : cycles)+                            rest++attachFaceCells+  :: Map FaceId OverlayCellId+  -> Triangulation 'Constrained OverlayVertexSeed () () ()+  -> Either+      (OverlayError leftLabel rightLabel)+      (Triangulation 'Constrained OverlayVertexSeed () () OverlayFace)+attachFaceCells cellIdByFace triangulation = do+  payloads <- V.fromList <$> traverse facePayload (allFaces triangulation)+  let outerPayload = OverlayFace (OverlayCellId 0)+      defaults = triElementDefaults triangulation+  pure+    triangulation+      { triFaceData = boxedFromVector (Just outerPayload) payloads+      , triElementDefaults = defaults{defaultFaceData = outerPayload}+      }+ where+  facePayload face+    | face == outerFace = Right (OverlayFace (OverlayCellId 0))+    | otherwise =+        case Map.lookup face cellIdByFace of+          Just cellId -> Right (OverlayFace cellId)+          Nothing ->+            Left+              ( OverlayProvenanceIncomplete+                  (OverlayResidentFaceUnassigned face)+              )++attachOverlayVertices+  :: Triangulation 'Constrained OverlayVertexSeed () () face+  -> Triangulation 'Constrained OverlayVertex () () face+attachOverlayVertices =+  Dcel.mapVertices+    (\seed -> OverlayVertex (seedExactPoint seed) (seedOrigin seed))++cellPayload+  :: V.Vector (OverlayCell leftLabel rightLabel)+  -> OverlayCellId+  -> Either OverlayCellWitness (OverlayCell leftLabel rightLabel)+cellPayload cells cellId@(OverlayCellId index) =+  case cells V.!? index of+    Just cell -> Right cell+    Nothing -> Left (OverlayCellPayloadMissing cellId)++faceLabels+  :: OverlayResult leftLabel rightLabel+  -> FaceId+  -> Either OverlayCellWitness (leftLabel, rightLabel)+faceLabels result face = do+  cell <-+    cellPayload+      (overlayResultCells result)+      (overlayFaceCellId (faceData (overlayResultTriangulation result) face))+  pure (overlayCellLeft cell, overlayCellRight cell)++regionFaceLabels+  :: OverlayResult leftLabel rightLabel+  -> FaceId+  -> Either RegionPublicationError (leftLabel, rightLabel)+regionFaceLabels result face =+  case faceLabels result face of+    Right labels -> Right labels+    Left _ -> Left (RegionFaceLabelMissing face)++vertexSupport+  :: (Ord leftLabel, Ord rightLabel)+  => OverlayResult leftLabel rightLabel+  -> VertexId+  -> Either OverlayCellWitness (OverlayCellSupport leftLabel rightLabel)+vertexSupport result vertex = do+  labels <-+    traverse+      (faceLabels result . incidentFace triangulation)+      (vertexOutgoingEdges triangulation vertex)+  case supportFromPairs labels of+    Just support -> Right support+    Nothing -> Left (OverlayVertexSupportMissing vertex)+ where+  triangulation = overlayResultTriangulation result++edgeSupport+  :: (Ord leftLabel, Ord rightLabel)+  => OverlayResult leftLabel rightLabel+  -> UndirectedEdgeId+  -> Either OverlayCellWitness (OverlayCellSupport leftLabel rightLabel)+edgeSupport result edge = do+  pairs <- traverse (faceLabels result . incidentFace triangulation) [forward, backward]+  case supportFromPairs pairs of+    Just support -> Right support+    Nothing -> Left (OverlayEdgeSupportMissing edge)+ where+  triangulation = overlayResultTriangulation result+  (forward, backward) = directedPair edge++supportFromPairs+  :: (Ord leftLabel, Ord rightLabel)+  => [(leftLabel, rightLabel)]+  -> Maybe (OverlayCellSupport leftLabel rightLabel)+supportFromPairs pairs = do+  let (leftLabels, rightLabels) =+        foldl'+          (\(left, right) (leftLabel, rightLabel) ->+             (Set.insert leftLabel left, Set.insert rightLabel right))+          (Set.empty, Set.empty)+          pairs+  leftSupport <- nonEmptySupport leftLabels+  rightSupport <- nonEmptySupport rightLabels+  pure (OverlayCellSupport leftSupport rightSupport)++nonEmptySupport :: Set label -> Maybe (OverlaySupport label)+nonEmptySupport labels = OverlaySupport <$> NonEmpty.nonEmpty (Set.toAscList labels)++validateAtomicConstraints+  :: Triangulation+      'Constrained+      OverlayVertexSeed+      ()+      ()+      ()+  -> Map ExactEdgeKey (AtomicEdge leftLabel rightLabel)+  -> Either (OverlayError leftLabel rightLabel) ()+validateAtomicConstraints triangulation atomicByKey = do+  traverse_ requireAtomic (Map.keys atomicByKey)+  traverse_ requireExpectedConstraint (undirectedEdges triangulation)+ where+  residentByKey =+    Map.fromList+      [ (residentSeedEdgeKey triangulation edge, edge)+      | edge <- undirectedEdges triangulation+      ]+  requireAtomic key@(from, to) =+    case Map.lookup key residentByKey of+      Nothing -> Left (OverlayProvenanceIncomplete (OverlayAtomicConstraintMissing from to))+      Just edge+        | isConstraintEdge triangulation edge -> Right ()+        | otherwise -> Left (OverlayProvenanceIncomplete (OverlayBoundaryEdgeNotConstrained edge))+  requireExpectedConstraint edge+    | isConstraintEdge triangulation edge+        && Map.notMember (residentSeedEdgeKey triangulation edge) atomicByKey =+        Left (OverlayProvenanceIncomplete (OverlayUnexpectedConstraint edge))+    | otherwise = Right ()++residentSeedEdgeKey+  :: Triangulation mode OverlayVertexSeed directed undirected face+  -> UndirectedEdgeId+  -> ExactEdgeKey+residentSeedEdgeKey = residentEdgeKeyBy seedExactPoint++residentEdgeKey+  :: Triangulation mode OverlayVertex directed undirected face+  -> UndirectedEdgeId+  -> ExactEdgeKey+residentEdgeKey = residentEdgeKeyBy overlayExactPoint++residentEdgeKeyBy+  :: (vertex -> ExactPoint)+  -> Triangulation mode vertex directed undirected face+  -> UndirectedEdgeId+  -> ExactEdgeKey+residentEdgeKeyBy exactPointAt triangulation edge =+  let (from, to) = undirectedEndpoints triangulation edge+   in canonicalEdgeKey+        (exactPointAt (vertexData triangulation from))+        (exactPointAt (vertexData triangulation to))
+ src-build/Moonlight/Triangulation/Internal/Overlay/Types.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE KindSignatures #-}++-- | Closed vocabulary and opaque carrier representation for exact labelled+-- overlay. Construction lives in the public build-tier module; this module+-- exists so every invariant-bearing payload shares one owner.+module Moonlight.Triangulation.Internal.Overlay.Types+  ( BoundaryLoopRef (..)+  , OverlayOperand (..)+  , BoundaryVertexRef (..)+  , BoundaryEdgeRef (..)+  , OverlayVertexOrigin (..)+  , OverlayEdgeOrigin (..)+  , OverlaySupport (..)+  , overlaySupportLabels+  , OverlayCellSupport (..)+  , OverlayCellId (..)+  , OverlayCellGeometry (..)+  , OverlayCell (..)+  , OverlayFace (..)+  , OverlayVertex (..)+  , OverlayEdge (..)+  , OverlayReceipt (..)+  , OverlayArrangementObstruction (..)+  , OverlayCellWitness (..)+  , OverlayError (..)+  , OverlayResult (..)+  , OverlaySelectionKind (..)+  , OverlaySelectionError (..)+  ) where++import Control.DeepSeq (NFData)+import Data.List.NonEmpty (NonEmpty)+import Data.Vector (Vector)+import GHC.Generics (Generic)+import Moonlight.Triangulation.CellSet (CellSelectionError)+import Moonlight.Triangulation.Exact+  ( ExactPoint+  )+import Moonlight.Triangulation.Handles.HandleDefs+  ( FaceId+  , UndirectedEdgeId+  , VertexId+  )+import Moonlight.Triangulation.Internal.Cdt.Types (CdtError)+import Moonlight.Triangulation.Internal.ExactRational (ExactArithmeticError)+import Moonlight.Triangulation.Internal.ExactSegmentEvents (ExactSegmentEventObstruction)+import Moonlight.Triangulation.Internal.Overlay.Embedding (OverlayEmbeddingObstruction)+import Moonlight.Triangulation.Internal.Region.Types+  ( ExactLoop+  , PolygonComponent+  , RegionPublicationError+  )+import Moonlight.Triangulation.Internal.Representation (Triangulation)+import Moonlight.Triangulation.Internal.Types+  ( ConstraintMode (Constrained)+  )++-- | Which cycle inside a polygon component supplied a source reference.+data BoundaryLoopRef+  = BoundaryOuterLoop+  | BoundaryHoleLoop !Int+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data OverlayOperand+  = LeftOverlayOperand+  | RightOverlayOperand++-- | A boundary vertex reference whose phantom operand prevents left/right+-- provenance from being interchanged while sharing their identical payload.+data BoundaryVertexRef (operand :: OverlayOperand) = BoundaryVertexRef+  { boundaryVertexComponent :: !Int+  , boundaryVertexLoop :: !BoundaryLoopRef+  , boundaryVertexLocalIndex :: !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | The corresponding typed reference for one source boundary edge.+data BoundaryEdgeRef (operand :: OverlayOperand) = BoundaryEdgeRef+  { boundaryEdgeComponent :: !Int+  , boundaryEdgeLoop :: !BoundaryLoopRef+  , boundaryEdgeLocalIndex :: !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Complete typed source closure of one arrangement vertex.+data OverlayVertexOrigin = OverlayVertexOrigin+  { overlayOriginLeftVertices :: ![BoundaryVertexRef 'LeftOverlayOperand]+  , overlayOriginRightVertices :: ![BoundaryVertexRef 'RightOverlayOperand]+  , overlayOriginLeftEdges :: ![BoundaryEdgeRef 'LeftOverlayOperand]+  , overlayOriginRightEdges :: ![BoundaryEdgeRef 'RightOverlayOperand]+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Nonempty typed source-edge provenance of one exact atomic interval.+data OverlayEdgeOrigin = OverlayEdgeOrigin+  { overlayEdgeLeftSources :: ![BoundaryEdgeRef 'LeftOverlayOperand]+  , overlayEdgeRightSources :: ![BoundaryEdgeRef 'RightOverlayOperand]+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Sorted nonempty labels whose closures contain one relatively open cell.+newtype OverlaySupport label = OverlaySupport (NonEmpty label)+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++overlaySupportLabels :: OverlaySupport label -> NonEmpty label+overlaySupportLabels (OverlaySupport labels) = labels++data OverlayCellSupport leftLabel rightLabel = OverlayCellSupport+  { overlaySupportLeft :: !(OverlaySupport leftLabel)+  , overlaySupportRight :: !(OverlaySupport rightLabel)+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++newtype OverlayCellId = OverlayCellId Int+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data OverlayCellGeometry+  = BoundedOverlayCell !PolygonComponent+  | UnboundedOverlayCell ![ExactLoop]+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data OverlayCell leftLabel rightLabel = OverlayCell+  { overlayCellLeft :: !leftLabel+  , overlayCellRight :: !rightLabel+  , overlayCellGeometry :: !OverlayCellGeometry+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A resident face stores only its authoritative dense-cell reference.+-- Labels and geometry belong to 'OverlayCell'; duplicating them here made+-- every observation carry a reconciliation obligation with no additional law.+newtype OverlayFace = OverlayFace+  { overlayFaceCellId :: OverlayCellId+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Exact geometry and provenance are intrinsic to a vertex. Label support is+-- the finite union of incident cell descriptors and is therefore a view.+data OverlayVertex = OverlayVertex+  { overlayExactPoint :: !ExactPoint+  , overlayVertexOrigin :: !OverlayVertexOrigin+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Boundary provenance is intrinsic; label support is derived from the two+-- incident face-cell references.+data OverlayEdge+  = OverlayBoundary !OverlayEdgeOrigin+  | OverlayDiagonal+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data OverlayReceipt = OverlayReceipt+  { overlayInputSegments :: !Int+  , overlayRelationEvents :: !Int+  , overlayExactCrossings :: !Int+  , overlayOverlapIntervals :: !Int+  , overlayAtomicEdges :: !Int+  , overlayOutputVertices :: !Int+  , overlayArrangementCells :: !Int+  , overlayResidentFaces :: !Int+  , overlayEmbeddingCandidates :: !Int+  , overlayTotalRelationChecks :: !Int+  , overlaySweepMaximumHeight :: !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data OverlayArrangementObstruction leftLabel rightLabel+  = OverlayLeftSourceSideConflict+      !OverlayEdgeOrigin+      !(NonEmpty leftLabel)+  | OverlayRightSourceSideConflict+      !OverlayEdgeOrigin+      !(NonEmpty rightLabel)+  | OverlayRotationDegenerate !ExactPoint+  | OverlayFaceComponentEmpty+  | OverlayCellCycleDidNotClose !ExactPoint !ExactPoint+  | OverlayTransitionSourceMismatch+      !FaceId+      !UndirectedEdgeId+      !(leftLabel, rightLabel)+      !(leftLabel, rightLabel)+  | OverlayResidentFaceLabelConflict+      !FaceId+      !UndirectedEdgeId+      !(leftLabel, rightLabel)+      !(leftLabel, rightLabel)+  | OverlayDuplicateCellSignature !PolygonComponent+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++data OverlayCellWitness+  = OverlayAtomicConstraintMissing !ExactPoint !ExactPoint+  | OverlayAtomicConstraintOrientationMismatch+      !UndirectedEdgeId+      !ExactPoint+      !ExactPoint+  | OverlayUnexpectedConstraint !UndirectedEdgeId+  | OverlayBoundaryEdgeNotConstrained !UndirectedEdgeId+  | OverlayResidentFaceUnassigned !FaceId+  | OverlayCellPayloadMissing !OverlayCellId+  | OverlayVertexSupportMissing !VertexId+  | OverlayEdgeSupportMissing !UndirectedEdgeId+  | OverlayEmbeddedVertexCountMismatch !Int !Int+  | OverlayExactVertexMissing !ExactPoint+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++data OverlayError leftLabel rightLabel+  = OverlayExactArithmetic !ExactArithmeticError+  | OverlaySegmentEventsInvalid !ExactSegmentEventObstruction+  | OverlayArrangementInvalid !(OverlayArrangementObstruction leftLabel rightLabel)+  | OverlayEmbeddingRefused !(NonEmpty OverlayEmbeddingObstruction)+  | OverlayBuildFailed !CdtError+  | OverlayRegionPublicationFailed !RegionPublicationError+  | OverlayProvenanceIncomplete !OverlayCellWitness+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | The singular exact subdivision carrier. Its embedded DCEL is a derived+-- binary64 realization; exact coordinates remain in the vertex payload plane.+data OverlayResult leftLabel rightLabel = OverlayResult+  { overlayResultTriangulation+      :: !( Triangulation+              'Constrained+              OverlayVertex+              ()+              OverlayEdge+              OverlayFace+          )+  , overlayResultCells :: !(Vector (OverlayCell leftLabel rightLabel))+  , overlayResultOutsideLabels :: !(leftLabel, rightLabel)+  , overlayResultReceipt :: !OverlayReceipt+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++data OverlaySelectionKind+  = ClosedUnionSelection+  | ClosedIntersectionSelection+  | RegularizedDifferenceSelection+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data OverlaySelectionError+  = OverlaySelectionContainsUnboundedCell !OverlaySelectionKind+  | OverlaySelectionProvenance !OverlayCellWitness+  | OverlaySelectionInvalid !CellSelectionError+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)
+ src-build/Moonlight/Triangulation/Minkowski.hs view
@@ -0,0 +1,583 @@+{-# LANGUAGE DataKinds #-}++-- | Exact polygonal Minkowski addition and regularized two-dimensional+-- morphology. Convex convolution is direct; nonconvex construction descends+-- through the existing exact overlay, resident CDT, and grouped publication+-- owners. Lower-dimensional erosion residuals cannot inhabit 'PlanarRegion'+-- and therefore publish as empty rather than being forged as polygons.+module Moonlight.Triangulation.Minkowski+  ( ConvexPolygon+  , convexPolygon+  , convexPolygonPoints+  , StructuringElement+  , structuringElement+  , MinkowskiOperation (..)+  , MinkowskiError (..)+  , MinkowskiReceipt (..)+  , convexMinkowskiSum+  , minkowskiSum+  , erodeBy+  , openWith+  , closeWith+  , polygonOffset+  , polygonInset+  ) where++import Control.Applicative ((<|>))+import Control.Monad (filterM)+import Data.Bifunctor (first)+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Map.Strict as Map+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (fromMaybe)+import qualified Data.Set as Set+import qualified Data.Vector as V+import Moonlight.Triangulation.Dcel+  ( faceData+  , faceVertices+  , vertexData+  )+import Moonlight.Triangulation.Exact+  ( ExactPoint+  , exactPointCoordinates+  )+import Moonlight.Triangulation.Handles.HandleDefs+  ( FaceId+  )+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (innerFaces)+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactRational+  , exactRationalDenominator+  , exactRationalNumerator+  )+import Moonlight.Triangulation.Internal.BoundaryCycle (cyclePairs)+import Moonlight.Triangulation.Internal.Dyadic (integerBitLength)+import Moonlight.Triangulation.Internal.Minkowski.Convex+  ( addExactPoints+  , admittedConvexLoop+  , convexHullPolygon+  , convexMinkowskiPolygon+  , convexMinkowskiSum+  , convexPolygon+  , convexPolygonCentroid+  , convexPolygonPoints+  , convexPolygonRegion+  , erodeConvexBy+  , reflectConvexPolygon+  , structuringElement+  , structuringElementPolygon+  )+import Moonlight.Triangulation.Internal.Minkowski.Types+import Moonlight.Triangulation.Internal.Overlay.Resident (faceLabels)+import Moonlight.Triangulation.Internal.Overlay.Types+  ( OverlayCell (..)+  , OverlayCellGeometry (..)+  , OverlayCellId (..)+  , OverlayFace (..)+  , OverlayResult (..)+  , OverlayVertex (..)+  )+import Moonlight.Triangulation.Overlay+  ( OverlayReceipt (..)+  , overlayLayers+  , overlayReceipt+  , overlaySelectedRegion+  )+import Moonlight.Triangulation.Region+  ( PlanarLayer+  , PlanarRegion+  , PolygonComponent+  , RegionPointLocation (..)+  , emptyPlanarRegion+  , exactLoopPoints+  , planarLayerRegions+  , planarRegionComponents+  , polygonHoleLoops+  , polygonOuterLoop+  , regionPointLocation+  )+import Moonlight.Triangulation.Internal.Region.Publication+  ( labelledPlanarLayerFromExactCoordinates+  , planarLayerFromAdmittedComponents+  )++data MorphologyMetrics = MorphologyMetrics+  { metricOverlayPasses :: !Int+  , metricExactCrossings :: !Int+  , metricOutputCells :: !(Maybe Int)+  }++emptyMetrics :: MorphologyMetrics+emptyMetrics = MorphologyMetrics 0 0 Nothing++appendMetrics :: MorphologyMetrics -> MorphologyMetrics -> MorphologyMetrics+appendMetrics left right =+  MorphologyMetrics+    { metricOverlayPasses = metricOverlayPasses left + metricOverlayPasses right+    , metricExactCrossings = metricExactCrossings left + metricExactCrossings right+    , metricOutputCells = metricOutputCells right <|> metricOutputCells left+    }++minkowskiSum+  :: PlanarRegion+  -> PlanarRegion+  -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt)+minkowskiSum left right = do+  (leftPieces, leftMetrics) <- decomposeRegion left+  (rightPieces, rightMetrics) <- decomposeRegion right+  let generated =+        [ convexMinkowskiPolygon leftPiece rightPiece+        | leftPiece <- leftPieces+        , rightPiece <- rightPieces+        ]+      generatedRegions = map convexPolygonRegion generated+      convolutionEdges = sum (map (NonEmpty.length . convexPolygonPoints) generated)+  (result, unionMetrics) <- unionRegions generatedRegions+  let metrics = leftMetrics `appendMetrics` rightMetrics `appendMetrics` unionMetrics+  pure+    ( result+    , MinkowskiReceipt+        { minkowskiOperation = MinkowskiAddition+        , minkowskiInputComponents =+            length (planarRegionComponents left)+              + length (planarRegionComponents right)+        , minkowskiConvexPieces = length leftPieces + length rightPieces+        , minkowskiGeneratedPieces = length generated+        , minkowskiGeneratedConvolutionEdges = convolutionEdges+        , minkowskiOverlayPasses = metricOverlayPasses metrics+        , minkowskiExactCrossings = metricExactCrossings metrics+        , minkowskiOutputCells = fromMaybe 0 (metricOutputCells metrics)+        , minkowskiExactCoordinateBitGrowth =+            coordinateBitGrowth [left, right] result+        }+    )++-- | Erode a polygonal region by an origin-anchored convex kernel and publish+-- the regularized full-dimensional result. A residual consisting only of+-- points or segments is represented by 'emptyPlanarRegion'.+erodeBy+  :: StructuringElement+  -> PlanarRegion+  -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt)+erodeBy element source =+  case singleConvexRegion source of+    Just sourcePolygon -> convexErosion element source sourcePolygon+    Nothing -> generalErosion element source++openWith+  :: StructuringElement+  -> PlanarRegion+  -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt)+openWith element source = do+  (eroded, erosionReceipt) <- erodeBy element source+  (opened, additionReceipt) <- polygonOffset element eroded+  pure+    ( opened+    , composeReceipts+        MinkowskiOpening+        (length (planarRegionComponents source))+        erosionReceipt+        additionReceipt+    )++closeWith+  :: StructuringElement+  -> PlanarRegion+  -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt)+closeWith element source = do+  (expanded, additionReceipt) <- polygonOffset element source+  (closed, erosionReceipt) <- erodeBy element expanded+  pure+    ( closed+    , composeReceipts+        MinkowskiClosing+        (length (planarRegionComponents source))+        additionReceipt+        erosionReceipt+    )++polygonOffset+  :: StructuringElement+  -> PlanarRegion+  -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt)+polygonOffset element source =+  minkowskiSum source (convexPolygonRegion (structuringElementPolygon element))++polygonInset+  :: StructuringElement+  -> PlanarRegion+  -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt)+polygonInset = erodeBy++decomposeRegion+  :: PlanarRegion+  -> Either MinkowskiError ([ConvexPolygon], MorphologyMetrics)+decomposeRegion region =+  case traverse convexComponent (planarRegionComponents region) of+    Just convexPieces -> Right (convexPieces, emptyMetrics)+    Nothing -> triangulatedPieces region++convexComponent :: PolygonComponent -> Maybe ConvexPolygon+convexComponent component =+  case polygonHoleLoops component of+    [] -> admittedConvexLoop (polygonOuterLoop component)+    _ -> Nothing++singleConvexRegion :: PlanarRegion -> Maybe ConvexPolygon+singleConvexRegion region =+  case planarRegionComponents region of+    [component] -> convexComponent component+    _ -> Nothing++triangulatedPieces+  :: PlanarRegion+  -> Either MinkowskiError ([ConvexPolygon], MorphologyMetrics)+triangulatedPieces region = do+  let sourceLayer = morphologyLayer region+  result <- first MinkowskiOverlayFailed (overlayLayers sourceLayer emptyMorphologyLayer)+  selectedFaces <-+    filterM+      ( fmap fst+          . first MinkowskiOverlayCellWitness+          . faceLabels result+      )+      (innerFaces (overlayResultTriangulation result))+  pieces <- traverse (faceConvexPolygon result) selectedFaces+  pure (pieces, metricsFromOverlay result (length pieces))++faceConvexPolygon+  :: OverlayResult leftLabel rightLabel+  -> FaceId+  -> Either MinkowskiError ConvexPolygon+faceConvexPolygon result face =+  case+    map+      (overlayExactPoint . vertexData triangulation)+      (faceVertices triangulation face) of+    [firstPoint, secondPoint, thirdPoint] ->+      convexHullPolygon (firstPoint :| [secondPoint, thirdPoint])+    vertices -> Left (MinkowskiFaceArity face (length vertices))+ where+  triangulation = overlayResultTriangulation result++unionRegions+  :: [PlanarRegion]+  -> Either MinkowskiError (PlanarRegion, MorphologyMetrics)+unionRegions [] = Right (emptyPlanarRegion, emptyMetrics)+unionRegions [region] =+  Right+    ( region+    , emptyMetrics{metricOutputCells = Just (length (planarRegionComponents region))}+    )+unionRegions regions = do+  let (leftRegions, rightRegions) = splitAt (length regions `div` 2) regions+  left <- unionRegions leftRegions+  right <- unionRegions rightRegions+  glueRegionUnion left right++glueRegionUnion+  :: (PlanarRegion, MorphologyMetrics)+  -> (PlanarRegion, MorphologyMetrics)+  -> Either MinkowskiError (PlanarRegion, MorphologyMetrics)+glueRegionUnion (left, leftMetrics) (right, rightMetrics)+  | null (planarRegionComponents left) = Right (right, leftMetrics `appendMetrics` rightMetrics)+  | null (planarRegionComponents right) = Right (left, leftMetrics `appendMetrics` rightMetrics)+  | otherwise = do+      result <-+        first MinkowskiOverlayFailed+          (overlayLayers (morphologyLayer left) (morphologyLayer right))+      published <-+        first MinkowskiPublicationFailed+          ( overlaySelectedRegion+              (uncurry (||))+              result+          )+      let selectedCells =+            V.foldl'+              (\count cell ->+                 case overlayCellGeometry cell of+                   BoundedOverlayCell _+                     | overlayCellLeft cell || overlayCellRight cell ->+                         count + 1+                   _ -> count)+              0+              (overlayResultCells result)+      pure+        ( published+        , leftMetrics+            `appendMetrics` rightMetrics+            `appendMetrics` metricsFromOverlay result selectedCells+        )++convexErosion+  :: StructuringElement+  -> PlanarRegion+  -> ConvexPolygon+  -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt)+convexErosion element source sourcePolygon = do+  eroded <- erodeConvexBy sourcePolygon (structuringElementPolygon element)+  let result = maybe emptyPlanarRegion convexPolygonRegion eroded+      outputCells = maybe 0 (const 1) eroded+      generatedEdges = maybe 0 (NonEmpty.length . convexPolygonPoints) eroded+  pure+    ( result+    , MinkowskiReceipt+        { minkowskiOperation = MinkowskiErosion+        , minkowskiInputComponents = 1+        , minkowskiConvexPieces = 2+        , minkowskiGeneratedPieces = outputCells+        , minkowskiGeneratedConvolutionEdges = generatedEdges+        , minkowskiOverlayPasses = 0+        , minkowskiExactCrossings = 0+        , minkowskiOutputCells = outputCells+        , minkowskiExactCoordinateBitGrowth =+            coordinateBitGrowth+              [ source+              , convexPolygonRegion (structuringElementPolygon element)+              ]+              result+        }+    )++generalErosion+  :: StructuringElement+  -> PlanarRegion+  -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt)+generalErosion element source+  | null sourceEdges = Right (emptyPlanarRegion, emptyErosionReceipt)+  | otherwise = do+      sweptPolygons <- traverse (sweepBoundaryEdge reflectedKernel) sourceEdges+      let sweptRegions = map convexPolygonRegion sweptPolygons+          generatedEdges =+            sum (map (NonEmpty.length . convexPolygonPoints) sweptPolygons)+      (contactRegion, unionMetrics) <- unionRegions sweptRegions+      candidateOverlay <-+        first MinkowskiOverlayFailed+          (overlayLayers (morphologyLayer contactRegion) emptyMorphologyLayer)+      kernelWitness <- convexPolygonCentroid kernel+      let representativeFaceByCell = representativeFaces candidateOverlay+      selectedCellIds <-+        Set.fromList+          <$> filterM+            ( classifyCandidateCell+                source+                kernelWitness+                representativeFaceByCell+                candidateOverlay+            )+            (boundedOutsideCellIds candidateOverlay)+      published <- publishCellSelection selectedCellIds candidateOverlay+      let candidateMetrics =+            metricsFromOverlay candidateOverlay (Set.size selectedCellIds)+          metrics = unionMetrics `appendMetrics` candidateMetrics+      pure+        ( published+        , MinkowskiReceipt+            { minkowskiOperation = MinkowskiErosion+            , minkowskiInputComponents = length (planarRegionComponents source)+            , minkowskiConvexPieces = 1+            , minkowskiGeneratedPieces = length sweptPolygons+            , minkowskiGeneratedConvolutionEdges = generatedEdges+            , minkowskiOverlayPasses = metricOverlayPasses metrics+            , minkowskiExactCrossings = metricExactCrossings metrics+            , minkowskiOutputCells = Set.size selectedCellIds+            , minkowskiExactCoordinateBitGrowth =+                coordinateBitGrowth+                  [source, convexPolygonRegion kernel]+                  published+            }+        )+ where+  kernel = structuringElementPolygon element+  reflectedKernel = reflectConvexPolygon kernel+  sourceEdges = regionBoundaryEdges source+  emptyErosionReceipt =+    MinkowskiReceipt+      { minkowskiOperation = MinkowskiErosion+      , minkowskiInputComponents = 0+      , minkowskiConvexPieces = 1+      , minkowskiGeneratedPieces = 0+      , minkowskiGeneratedConvolutionEdges = 0+      , minkowskiOverlayPasses = 0+      , minkowskiExactCrossings = 0+      , minkowskiOutputCells = 0+      , minkowskiExactCoordinateBitGrowth = 0+      }++sweepBoundaryEdge+  :: ConvexPolygon+  -> (ExactPoint, ExactPoint)+  -> Either MinkowskiError ConvexPolygon+sweepBoundaryEdge reflectedKernel (from, to) =+  case convexPolygonPoints reflectedKernel of+    firstKernelPoint :| remainingKernelPoints ->+      convexHullPolygon+        ( addExactPoints from firstKernelPoint+            :| ( map (addExactPoints from) remainingKernelPoints+                   <> map (addExactPoints to) kernelPoints+               )+        )+ where+  kernelPoints = NonEmpty.toList (convexPolygonPoints reflectedKernel)++boundedOutsideCellIds+  :: OverlayResult Bool Bool+  -> [OverlayCellId]+boundedOutsideCellIds result =+  V.ifoldr+    (\index cell selected ->+       case overlayCellGeometry cell of+         BoundedOverlayCell _+           | not (overlayCellLeft cell)+               && not (overlayCellRight cell) ->+               OverlayCellId index : selected+         _ -> selected)+    []+    (overlayResultCells result)++classifyCandidateCell+  :: PlanarRegion+  -> ExactPoint+  -> IntMap.IntMap FaceId+  -> OverlayResult Bool Bool+  -> OverlayCellId+  -> Either MinkowskiError Bool+classifyCandidateCell source kernelWitness representativeFaceByCell result cellId = do+  face <-+    maybe+      (Left (MinkowskiCandidateCellMissing cellId))+      Right+      (IntMap.lookup (overlayCellIndex cellId) representativeFaceByCell)+  candidate <- convexPolygonCentroid =<< faceConvexPolygon result face+  let inclusionWitness = addExactPoints candidate kernelWitness+  case regionPointLocation source inclusionWitness of+    RegionInterior -> Right True+    RegionExterior -> Right False+    RegionOnBoundary -> Left (MinkowskiInclusionAmbiguous cellId inclusionWitness)++representativeFaces+  :: OverlayResult leftLabel rightLabel+  -> IntMap.IntMap FaceId+representativeFaces result =+  IntMap.fromListWith min+    [ (overlayCellIndex (overlayFaceCellId (faceData triangulation face)), face)+    | face <- innerFaces triangulation+    ]+ where+  triangulation = overlayResultTriangulation result++overlayCellIndex :: OverlayCellId -> Int+overlayCellIndex (OverlayCellId index) = index++publishCellSelection+  :: Set.Set OverlayCellId+  -> OverlayResult leftLabel rightLabel+  -> Either MinkowskiError PlanarRegion+publishCellSelection selected result = do+  layer <-+    first MinkowskiPublicationFailed+      ( labelledPlanarLayerFromExactCoordinates+          False+          triangulation+          (\vertex -> Right (overlayExactPoint (vertexData triangulation vertex)))+          (\face ->+             Right+               ( Set.member+                   (overlayFaceCellId (faceData triangulation face))+                   selected+               ))+      )+  pure (Map.findWithDefault emptyPlanarRegion True (planarLayerRegions layer))+ where+  triangulation = overlayResultTriangulation result++morphologyLayer+  :: PlanarRegion+  -> PlanarLayer Bool+morphologyLayer region =+  planarLayerFromAdmittedComponents+    False+    [(True, component) | component <- planarRegionComponents region]++emptyMorphologyLayer :: PlanarLayer Bool+emptyMorphologyLayer = morphologyLayer emptyPlanarRegion++regionBoundaryEdges :: PlanarRegion -> [(ExactPoint, ExactPoint)]+regionBoundaryEdges region =+  concatMap+    (\component ->+       concatMap+         (cyclePairs . exactLoopPoints)+         (polygonOuterLoop component : polygonHoleLoops component))+    (planarRegionComponents region)++metricsFromOverlay+  :: OverlayResult leftLabel rightLabel+  -> Int+  -> MorphologyMetrics+metricsFromOverlay result outputCells =+  MorphologyMetrics+    { metricOverlayPasses = 1+    , metricExactCrossings = overlayExactCrossings (overlayReceipt result)+    , metricOutputCells = Just outputCells+    }++composeReceipts+  :: MinkowskiOperation+  -> Int+  -> MinkowskiReceipt+  -> MinkowskiReceipt+  -> MinkowskiReceipt+composeReceipts operation inputComponents firstReceipt secondReceipt =+  MinkowskiReceipt+    { minkowskiOperation = operation+    , minkowskiInputComponents = inputComponents+    , minkowskiConvexPieces =+        minkowskiConvexPieces firstReceipt+          + minkowskiConvexPieces secondReceipt+    , minkowskiGeneratedPieces =+        minkowskiGeneratedPieces firstReceipt+          + minkowskiGeneratedPieces secondReceipt+    , minkowskiGeneratedConvolutionEdges =+        minkowskiGeneratedConvolutionEdges firstReceipt+          + minkowskiGeneratedConvolutionEdges secondReceipt+    , minkowskiOverlayPasses =+        minkowskiOverlayPasses firstReceipt+          + minkowskiOverlayPasses secondReceipt+    , minkowskiExactCrossings =+        minkowskiExactCrossings firstReceipt+          + minkowskiExactCrossings secondReceipt+    , minkowskiOutputCells = minkowskiOutputCells secondReceipt+    , minkowskiExactCoordinateBitGrowth =+        max+          (minkowskiExactCoordinateBitGrowth firstReceipt)+          (minkowskiExactCoordinateBitGrowth secondReceipt)+    }++coordinateBitGrowth :: [PlanarRegion] -> PlanarRegion -> Int+coordinateBitGrowth inputs output =+  max 0+    ( regionCoordinateBits output+        - foldl' (\maximumBits -> max maximumBits . regionCoordinateBits) 0 inputs+    )++regionCoordinateBits :: PlanarRegion -> Int+regionCoordinateBits = foldl' componentBits 0 . planarRegionComponents+ where+  componentBits maximumBits component =+    foldl'+      loopBits+      maximumBits+      (polygonOuterLoop component : polygonHoleLoops component)+  loopBits maximumBits =+    foldl' pointBits maximumBits . exactLoopPoints+  pointBits maximumBits point =+    let (x, y) = exactPointCoordinates point+     in max maximumBits (max (rationalBits x) (rationalBits y))++rationalBits :: ExactRational -> Int+rationalBits value =+  max+    (integerBitLength (abs (exactRationalNumerator value)))+    (integerBitLength (exactRationalDenominator value))
+ src-build/Moonlight/Triangulation/Overlay.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Exact labelled common refinement. Source boundaries descend through one+-- exact segment-event plan, glue into canonical atomic constraints, and are+-- admitted only when their binary64 DCEL realization preserves every exact+-- relation.+module Moonlight.Triangulation.Overlay+  ( BoundaryLoopRef (..)+  , OverlayOperand+  , BoundaryVertexRef+  , boundaryVertexComponent+  , boundaryVertexLoop+  , boundaryVertexLocalIndex+  , BoundaryEdgeRef+  , boundaryEdgeComponent+  , boundaryEdgeLoop+  , boundaryEdgeLocalIndex+  , OverlayVertexOrigin+  , overlayOriginLeftVertices+  , overlayOriginRightVertices+  , overlayOriginLeftEdges+  , overlayOriginRightEdges+  , OverlayEdgeOrigin+  , overlayEdgeLeftSources+  , overlayEdgeRightSources+  , OverlaySupport+  , overlaySupportLabels+  , OverlayCellSupport (..)+  , OverlayCellId (..)+  , OverlayCellGeometry (..)+  , OverlayCell (..)+  , OverlayFace (..)+  , OverlayVertex (..)+  , OverlayEdge (..)+  , OverlayReceipt (..)+  , OverlayArrangementObstruction (..)+  , OverlayCellWitness (..)+  , OverlayError (..)+  , OverlayResult+  , OverlaySelectionKind (..)+  , OverlaySelectionError (..)+  , overlayLayers+  , overlayEmbeddedTriangulation+  , overlayReceipt+  , overlayCells+  , overlayArrangementVertices+  , overlayArrangementEdges+  , overlayPlanarLayer+  , overlaySelectedRegion+  , overlayClosedUnion+  , overlayClosedIntersection+  , overlayRegularizedDifference+  ) where++import Data.Bifunctor (first)+import Control.Monad (filterM)+import qualified Data.Map.Strict as Map+import qualified Data.Vector as V+import Moonlight.Triangulation.CellSet (ExactCellSet)+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.Dcel (vertexData)+import Moonlight.Triangulation.Handles.HandleDefs+  ( UndirectedEdgeId+  , VertexId+  )+import Moonlight.Triangulation.Handles.Iterators.FixedIterators+  ( innerFaces+  , undirectedEdges+  , vertices+  )+import Moonlight.Triangulation.Internal.CellSet (closeExactCellSetWith)+import Moonlight.Triangulation.Internal.Overlay.Arrangement+  ( certifyArrangement+  )+import Moonlight.Triangulation.Internal.Overlay.Resident+  ( OverlayDiagonalSchedule (CanonicalOverlayDiagonals)+  , edgeSupport+  , faceLabels+  , regionFaceLabels+  , residentOverlay+  , vertexSupport+  )+import Moonlight.Triangulation.Internal.Overlay.Types+import Moonlight.Triangulation.Internal.Representation (Triangulation)+import Moonlight.Triangulation.Internal.Types+  ( ConstraintMode (Constrained)+  )+import Moonlight.Triangulation.Region+  ( PlanarLayer+  , PlanarRegion+  , RegionPublicationError (..)+  , emptyPlanarRegion+  , planarLayerOutsideLabel+  , planarLayerRegions+  )+import Moonlight.Triangulation.Internal.Region.Publication+  ( labelledPlanarLayerFromExactCoordinates+  , planarLayerFromAdmittedComponents+  )++-- | Construct the exact common refinement and its one faithful resident DCEL.+overlayLayers+  :: (Ord leftLabel, Ord rightLabel)+  => PlanarLayer leftLabel+  -> PlanarLayer rightLabel+  -> Either+      (OverlayError leftLabel rightLabel)+      (OverlayResult leftLabel rightLabel)+overlayLayers leftLayer rightLayer = do+  certified <- certifyArrangement leftLayer rightLayer+  residentOverlay+    CanonicalOverlayDiagonals+    (planarLayerOutsideLabel leftLayer, planarLayerOutsideLabel rightLayer)+    certified++-- | The binary64 realization used by existing DCEL observations. Exact overlay+-- operations accept 'OverlayResult', never this projection.+overlayEmbeddedTriangulation+  :: OverlayResult leftLabel rightLabel+  -> Triangulation+      'Constrained+      OverlayVertex+      ()+      OverlayEdge+      OverlayFace+overlayEmbeddedTriangulation = overlayResultTriangulation++overlayReceipt :: OverlayResult leftLabel rightLabel -> OverlayReceipt+overlayReceipt = overlayResultReceipt++overlayCells+  :: OverlayResult leftLabel rightLabel+  -> [(OverlayCellId, OverlayCell leftLabel rightLabel)]+overlayCells result =+  V.toList+    (V.imap (\index cell -> (OverlayCellId index, cell)) (overlayResultCells result))++overlayArrangementVertices+  :: OverlayResult leftLabel rightLabel+  -> [(VertexId, OverlayVertex)]+overlayArrangementVertices result =+  let triangulation = overlayResultTriangulation result+   in [(vertex, vertexData triangulation vertex) | vertex <- vertices triangulation]++overlayArrangementEdges+  :: OverlayResult leftLabel rightLabel+  -> [(UndirectedEdgeId, OverlayEdgeOrigin)]+overlayArrangementEdges result =+  let triangulation = overlayResultTriangulation result+   in [ (edge, origin)+      | edge <- undirectedEdges triangulation+      , OverlayBoundary origin <- [Dcel.undirectedEdgeData triangulation edge]+      ]++-- | Publish the already-admitted bounded cell geometry. The resident DCEL is+-- a realization of these exact cells, not a second authoring source.+overlayPlanarLayer+  :: (Ord leftLabel, Ord rightLabel)+  => OverlayResult leftLabel rightLabel+  -> PlanarLayer (leftLabel, rightLabel)+overlayPlanarLayer result =+  planarLayerFromAdmittedComponents+    (overlayResultOutsideLabels result)+    [ ( (overlayCellLeft cell, overlayCellRight cell)+      , component+      )+    | cell <- V.toList (overlayResultCells result)+    , (overlayCellLeft cell, overlayCellRight cell)+        /= overlayResultOutsideLabels result+    , BoundedOverlayCell component <- [overlayCellGeometry cell]+    ]++-- | Publish the selected two-dimensional cells. Internal arrangement edges+-- between differently labelled but jointly selected cells dissolve because+-- selection precedes component descent.+overlaySelectedRegion+  :: ((leftLabel, rightLabel) -> Bool)+  -> OverlayResult leftLabel rightLabel+  -> Either RegionPublicationError PlanarRegion+overlaySelectedRegion selected result+  | selected (overlayResultOutsideLabels result) = Left RegionUnboundedSelection+  | otherwise = do+      published <-+        labelledPlanarLayerFromExactCoordinates+          False+          triangulation+          exactPointAt+          labelFace+      pure (Map.findWithDefault emptyPlanarRegion True (planarLayerRegions published))+ where+  triangulation = overlayResultTriangulation result+  exactPointAt vertex = Right (overlayExactPoint (vertexData triangulation vertex))+  labelFace face =+    selected <$> regionFaceLabels result face++overlayClosedUnion+  :: (Ord leftLabel, Ord rightLabel)+  => (leftLabel -> Bool)+  -> (rightLabel -> Bool)+  -> OverlayResult leftLabel rightLabel+  -> Either OverlaySelectionError ExactCellSet+overlayClosedUnion selectLeft selectRight =+  selectClosedCells+    ClosedUnionSelection+    (\support -> supportAny selectLeft (overlaySupportLeft support) || supportAny selectRight (overlaySupportRight support))+    (\leftLabel rightLabel -> selectLeft leftLabel || selectRight rightLabel)++overlayClosedIntersection+  :: (Ord leftLabel, Ord rightLabel)+  => (leftLabel -> Bool)+  -> (rightLabel -> Bool)+  -> OverlayResult leftLabel rightLabel+  -> Either OverlaySelectionError ExactCellSet+overlayClosedIntersection selectLeft selectRight =+  selectClosedCells+    ClosedIntersectionSelection+    (\support -> supportAny selectLeft (overlaySupportLeft support) && supportAny selectRight (overlaySupportRight support))+    (\leftLabel rightLabel -> selectLeft leftLabel && selectRight rightLabel)++overlayRegularizedDifference+  :: (leftLabel -> Bool)+  -> (rightLabel -> Bool)+  -> OverlayResult leftLabel rightLabel+  -> Either OverlaySelectionError ExactCellSet+overlayRegularizedDifference selectLeft selectRight result =+  let outsidePair = overlayResultOutsideLabels result+      selectFace leftLabel rightLabel = selectLeft leftLabel && not (selectRight rightLabel)+   in if uncurry selectFace outsidePair+        then Left (OverlaySelectionContainsUnboundedCell RegularizedDifferenceSelection)+        else closeSelectedCells [] [] selectFace result++selectClosedCells+  :: (Ord leftLabel, Ord rightLabel)+  => OverlaySelectionKind+  -> (OverlayCellSupport leftLabel rightLabel -> Bool)+  -> (leftLabel -> rightLabel -> Bool)+  -> OverlayResult leftLabel rightLabel+  -> Either OverlaySelectionError ExactCellSet+selectClosedCells selectionKind selectSupport selectFace result =+  let outsidePair = overlayResultOutsideLabels result+      triangulation = overlayResultTriangulation result+   in if uncurry selectFace outsidePair+        then Left (OverlaySelectionContainsUnboundedCell selectionKind)+        else do+          selectedVertices <-+            filterM+              ( fmap selectSupport+                  . first OverlaySelectionProvenance+                  . vertexSupport result+              )+              (vertices triangulation)+          selectedEdges <-+            filterM+              (\edge ->+                 case Dcel.undirectedEdgeData triangulation edge of+                   OverlayDiagonal -> Right False+                   OverlayBoundary _ ->+                     selectSupport+                       <$> first OverlaySelectionProvenance (edgeSupport result edge))+              (undirectedEdges triangulation)+          closeSelectedCells selectedVertices selectedEdges selectFace result++closeSelectedCells+  :: [VertexId]+  -> [UndirectedEdgeId]+  -> (leftLabel -> rightLabel -> Bool)+  -> OverlayResult leftLabel rightLabel+  -> Either OverlaySelectionError ExactCellSet+closeSelectedCells selectedVertices selectedEdges selectFace result =+  let triangulation = overlayResultTriangulation result+      exactPointAt vertex = Right (overlayExactPoint (vertexData triangulation vertex))+   in do+        selectedFaces <-+          filterM+            ( fmap (uncurry selectFace)+                . first OverlaySelectionProvenance+                . faceLabels result+            )+            (innerFaces triangulation)+        first OverlaySelectionInvalid+          ( closeExactCellSetWith+              exactPointAt+              triangulation+              selectedVertices+              selectedEdges+              selectedFaces+          )++supportAny :: (label -> Bool) -> OverlaySupport label -> Bool+supportAny predicate = any predicate . overlaySupportLabels
src-core/Moonlight/Triangulation/Internal/Dyadic.hs view
@@ -7,12 +7,21 @@   ( exactOrientDet   , exactOrientSignDouble   , exactInCircleDet+  , exactCircumradiusSquaredWithin   , exactBarycentricDeterminants   , exactDiametralDot   , integerRatioToDouble+  , integerBitLength   ) where -import Data.Bits (shiftL, shiftR)+import Data.Bits+  ( countLeadingZeros+  , countTrailingZeros+  , finiteBitSize+  , shiftL+  , shiftR+  )+import Data.Word (Word64) #if WORD_SIZE_IN_BITS == 64 import GHC.Exts   ( Double (D#)@@ -66,7 +75,7 @@  aligned6   :: Double -> Double -> Double -> Double -> Double -> Double-  -> (Integer, Integer, Integer, Integer, Integer, Integer)+  -> (Int, Integer, Integer, Integer, Integer, Integer, Integer) aligned6 a b c d e f =   let !da = decodeFloat a       !db = decodeFloat b@@ -75,7 +84,8 @@       !de = decodeFloat e       !df = decodeFloat f       !power = commonExponent [da, db, dc, dd, de, df]-   in ( alignDecoded power da+   in ( power+      , alignDecoded power da       , alignDecoded power db       , alignDecoded power dc       , alignDecoded power dd@@ -109,13 +119,164 @@ 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+  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 +-- | Exact closed comparison of squared circumradius with a finite,+-- non-negative binary64 threshold. No constructed circumcenter participates.+exactCircumradiusSquaredWithin+  :: Double+  -> Double -> Double -> Double -> Double -> Double -> Double+  -> Bool+exactCircumradiusSquaredWithin+  threshold+  ax ay bx by cx cy =+    let (!thresholdMantissa, !thresholdPower) = decodeFloat threshold+     in smallIntegralCircumradiusSquaredWithin+          (fromInteger thresholdMantissa)+          thresholdPower+          ax ay bx by cx cy+{-# INLINE exactCircumradiusSquaredWithin #-}++arbitraryCircumradiusSquaredWithin+  :: Integer+  -> Int+  -> Double -> Double -> Double -> Double -> Double -> Double+  -> Bool+arbitraryCircumradiusSquaredWithin+  thresholdMantissa+  thresholdPower+  ax ay bx by cx cy =+  let (!coordinatePower, !iax, !iay, !ibx, !iby, !icx, !icy) =+        aligned6 ax ay bx by cx cy+      !abx = ibx - iax+      !aby = iby - iay+      !acx = icx - iax+      !acy = icy - iay+      !bcx = icx - ibx+      !bcy = icy - iby+      !abSquared = abx * abx + aby * aby+      !acSquared = acx * acx + acy * acy+      !bcSquared = bcx * bcx + bcy * bcy+      !determinant = abx * acy - aby * acx+      !radiusNumerator = abSquared * acSquared * bcSquared+      !thresholdDenominator =+        4 * determinant * determinant * thresholdMantissa+   in determinant /= 0+        && compareDyadic+          radiusNumerator+          (6 * coordinatePower)+          thresholdDenominator+          (4 * coordinatePower + thresholdPower)+          /= GT++-- Integer-sized edges cover grid, pixel, and indexed-world faces without+-- allocating arbitrary-precision mantissas. Larger or fractional edges+-- descend to the general dyadic comparison above.+smallIntegralCircumradiusSquaredWithin+  :: Word64+  -> Int+  -> Double -> Double -> Double -> Double -> Double -> Double+  -> Bool+smallIntegralCircumradiusSquaredWithin+  rawThresholdMantissa+  rawThresholdPower+  ax ay bx by cx cy =+    if not admittedDifferences+      then+        arbitraryCircumradiusSquaredWithin+          (toInteger rawThresholdMantissa)+          rawThresholdPower+          ax ay bx by cx cy+      else+        let !abSquared = squaredIntegralLength abx aby+            !acSquared = squaredIntegralLength acx acy+            !bcSquared = squaredIntegralLength bcx bcy+            !radiusNumerator = abSquared * acSquared * bcSquared+            !determinant = abx * acy - aby * acx+            !determinantMagnitude = fromIntegral (abs determinant)+         in if determinant == 0 || rawThresholdMantissa == 0+              then False+              else+                let !trailingZeros = countTrailingZeros rawThresholdMantissa+                    !thresholdMantissa = rawThresholdMantissa `shiftR` trailingZeros+                    !thresholdPower = rawThresholdPower + trailingZeros+                    !determinantSquared = determinantMagnitude * determinantMagnitude+                    !scaledDeterminant = 4 * determinantSquared+                    !productsFit =+                      determinantMagnitude <= maxBound `quot` determinantMagnitude+                        && determinantSquared <= maxBound `quot` 4+                        && thresholdMantissa <= maxBound `quot` scaledDeterminant+                 in if productsFit+                      then+                        compareWordDyadic+                          radiusNumerator+                          0+                          (scaledDeterminant * thresholdMantissa)+                          thresholdPower+                          /= GT+                      else+                        arbitraryCircumradiusSquaredWithin+                          (toInteger rawThresholdMantissa)+                          rawThresholdPower+                          ax ay bx by cx cy+ where+  !abxValue = bx - ax+  !abyValue = by - ay+  !acxValue = cx - ax+  !acyValue = cy - ay+  !abx = truncate abxValue+  !aby = truncate abyValue+  !acx = truncate acxValue+  !acy = truncate acyValue+  !bcx = acx - abx+  !bcy = acy - aby+  admittedDifferences =+    integralDifference abxValue abx+      && integralDifference abyValue aby+      && integralDifference acxValue acx+      && integralDifference acyValue acy+{-# INLINE smallIntegralCircumradiusSquaredWithin #-}++integralDifference :: Double -> Int -> Bool+integralDifference value integral =+  abs value <= 512 && fromIntegral integral == value+{-# INLINE integralDifference #-}++squaredIntegralLength :: Int -> Int -> Word64+squaredIntegralLength x y =+  let !xMagnitude = fromIntegral (abs x)+      !yMagnitude = fromIntegral (abs y)+   in xMagnitude * xMagnitude + yMagnitude * yMagnitude+{-# INLINE squaredIntegralLength #-}++compareWordDyadic :: Word64 -> Int -> Word64 -> Int -> Ordering+compareWordDyadic left leftPower right rightPower+  | left == 0 = compare left right+  | right == 0 = GT+  | leftMagnitude /= rightMagnitude = compare leftMagnitude rightMagnitude+  | leftPower < rightPower = compare left (right `shiftL` (rightPower - leftPower))+  | otherwise = compare (left `shiftL` (leftPower - rightPower)) right+ where+  !leftMagnitude = wordBitLength left + leftPower+  !rightMagnitude = wordBitLength right + rightPower++  wordBitLength :: Word64 -> Int+  wordBitLength value = finiteBitSize value - countLeadingZeros value+{-# INLINE compareWordDyadic #-}++compareDyadic :: Integer -> Int -> Integer -> Int -> Ordering+compareDyadic left leftPower right rightPower =+  case compare leftPower rightPower of+    LT -> compare left (right `shiftL` (rightPower - leftPower))+    EQ -> compare left right+    GT -> compare (left `shiftL` (leftPower - rightPower)) right+{-# INLINE compareDyadic #-}+ exactInCircleDet   :: Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double   -> Integer@@ -139,7 +300,7 @@ 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+  let (!_, !iax, !iay, !ibx, !iby, !ipx, !ipy) = aligned6 ax ay bx by px py       !pax = ipx - iax       !pay = ipy - iay       !pbx = ipx - ibx
+ src-core/Moonlight/Triangulation/Internal/ExactRational.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Normalized exact rational arithmetic without geometric dependencies.+module Moonlight.Triangulation.Internal.ExactRational+  ( ExactRational+  , ExactArithmeticError (..)+  , exactRational+  , exactRationalFromDouble+  , exactRationalFromFiniteDouble+  , exactRationalFromDyadic+  , exactRationalNumerator+  , exactRationalDenominator+  , exactRationalIsZero+  , exactDivide+  , exactSignum+  ) where++import Control.DeepSeq (NFData)+import Data.Bits (shiftL)+import Data.Ratio (Ratio, (%))+import qualified Data.Ratio as Ratio+import GHC.Generics (Generic)++-- | A checked wrapper around a reduced ratio with a strictly positive+-- denominator. 'Data.Ratio' owns normalization, including the unique zero+-- representation @0 / 1@.+newtype ExactRational = ExactRational (Ratio Integer)+  deriving stock (Eq, Ord, Show, Generic)+  deriving newtype (Num)+  deriving anyclass (NFData)++-- | Typed refusals from exact rational construction and division.+data ExactArithmeticError+  = ExactZeroDenominator+  | ExactZeroDivisor+  | ExactNaNInput+  | ExactInfiniteInput+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Construct a reduced rational, moving any sign onto the numerator and+-- refusing a zero denominator.+exactRational :: Integer -> Integer -> Either ExactArithmeticError ExactRational+exactRational _ 0 = Left ExactZeroDenominator+exactRational numerator denominator = Right (ExactRational (numerator % denominator))++-- | Convert a binary64 value without loss, refusing NaN and infinities.+exactRationalFromDouble :: Double -> Either ExactArithmeticError ExactRational+exactRationalFromDouble value+  | isNaN value = Left ExactNaNInput+  | isInfinite value = Left ExactInfiniteInput+  | otherwise = Right (exactRationalFromFiniteDouble value)++-- | Convert an already-admitted finite coordinate without loss. The caller+-- supplies a finite value, such as a coordinate inside a validated+-- @QueryPoint@, so this worker does not repeat the admission refusal.+exactRationalFromFiniteDouble :: Double -> ExactRational+exactRationalFromFiniteDouble value =+  uncurry exactRationalFromDyadic (decodeFloat value)+{-# INLINE exactRationalFromFiniteDouble #-}++-- | Construct @numerator * 2^power@ without a partial denominator path.+exactRationalFromDyadic :: Integer -> Int -> ExactRational+exactRationalFromDyadic numerator power+  | power >= 0 = fromInteger (numerator `shiftL` power)+  | otherwise = ExactRational (numerator % (1 `shiftL` negate power))+{-# INLINE exactRationalFromDyadic #-}++-- | Read the reduced numerator.+exactRationalNumerator :: ExactRational -> Integer+exactRationalNumerator (ExactRational value) = Ratio.numerator value+{-# INLINE exactRationalNumerator #-}++-- | Read the strictly positive reduced denominator.+exactRationalDenominator :: ExactRational -> Integer+exactRationalDenominator (ExactRational value) = Ratio.denominator value+{-# INLINE exactRationalDenominator #-}++-- | Test whether the exact value is zero.+exactRationalIsZero :: ExactRational -> Bool+exactRationalIsZero (ExactRational value) = Ratio.numerator value == 0+{-# INLINE exactRationalIsZero #-}++-- | Divide by a nonzero exact rational, refusing a zero divisor explicitly.+exactDivide+  :: ExactRational+  -> ExactRational+  -> Either ExactArithmeticError ExactRational+exactDivide (ExactRational left) (ExactRational right)+  | Ratio.numerator right == 0 = Left ExactZeroDivisor+  | otherwise = Right (ExactRational (left / right))++-- | Compare an exact rational with zero through its canonical numerator.+exactSignum :: ExactRational -> Ordering+exactSignum (ExactRational value) = compare (Ratio.numerator value) 0+{-# INLINE exactSignum #-}
src-core/Moonlight/Triangulation/Internal/Paged.hs view
@@ -3,6 +3,7 @@ module Moonlight.Triangulation.Internal.Paged   ( Paged   , MutablePaged+  , FlatMutablePaged   , emptyPaged   , fromVector   , fromLocalVector@@ -16,6 +17,9 @@   , thawPaged   , thawPagedDense   , thawPagedShaped+  , flatMutableSection+  , readFlatMutable+  , writeFlatMutable   , readPaged   , writePaged   , freezePaged@@ -52,6 +56,12 @@       !(MUV.MVector s Bool)       !(STRef s Int) +-- | A proof that one mutable sequence is in its contiguous physical section.+-- The constructor stays private: callers can only obtain it by descending+-- through 'flatMutableSection', after which hot indexed programs no longer+-- re-test the storage sum at every cell.+newtype FlatMutablePaged s a = FlatMutablePaged (MUV.MVector s a)+ localPageBits :: Int localPageBits = 8 {-# INLINE localPageBits #-}@@ -289,6 +299,21 @@                 copyPage (pageIndex + 1) (offset + width)        in copyPage 0 0   pure (MutableFlatPaged (pagedBits paged) values)++flatMutableSection :: MutablePaged s a -> Maybe (FlatMutablePaged s a)+flatMutableSection mutable =+  case mutable of+    MutableFlatPaged _ values -> Just (FlatMutablePaged values)+    MutableSharedPaged{} -> Nothing+{-# INLINE flatMutableSection #-}++readFlatMutable :: U.Unbox a => FlatMutablePaged s a -> Int -> ST s a+readFlatMutable (FlatMutablePaged values) = MUV.unsafeRead values+{-# INLINE readFlatMutable #-}++writeFlatMutable :: U.Unbox a => FlatMutablePaged s a -> Int -> a -> ST s ()+writeFlatMutable (FlatMutablePaged values) = MUV.unsafeWrite values+{-# INLINE writeFlatMutable #-}  readPaged :: U.Unbox a => MutablePaged s a -> Int -> ST s a readPaged mutable index =
src-core/Moonlight/Triangulation/Scalar.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fllvm -optlo-O3 -optlc-O3 #-}+ -- | The binary64 coordinate kernel and exact predicate boundary. module Moonlight.Triangulation.Scalar   ( scalarName@@ -9,16 +11,22 @@   , scalarInCircleErrorBound   , orient2dCoordinates   , inCircleCoordinates+  , circumradiusSquaredWithinCoordinates   , BinaryFormat   , formatRadix   , formatMantissaDigits   , formatExponentRange   , minimumAllowedCoordinate   , maximumAllowedCoordinate+  , isFinite   , canonicalScalarZero   ) where -import Moonlight.Triangulation.Internal.Dyadic (exactInCircleDet, exactOrientSignDouble)+import Moonlight.Triangulation.Internal.Dyadic+  ( exactCircumradiusSquaredWithin+  , exactInCircleDet+  , exactOrientSignDouble+  )  -- | The coordinate component of canonical point identity. IEEE signed zeros -- compare equal but hash differently by bits; every coordinate-keyed owner@@ -85,6 +93,44 @@   -> Double -> Double -> Double -> Double   -> Ordering inCircleCoordinates = filteredInCircle scalarInCircleErrorBound++-- | Closed exact circumradius membership at a finite, non-negative binary64+-- threshold. Invalid thresholds and collinear triples are outside.+circumradiusSquaredWithinCoordinates+  :: Double+  -> Double -> Double -> Double -> Double -> Double -> Double+  -> Bool+circumradiusSquaredWithinCoordinates threshold ax ay bx by cx cy+    | threshold < 0 || not (isFinite threshold) = False+    | not (isFinite ax && isFinite ay && isFinite bx+        && isFinite by && isFinite cx && isFinite cy) = False+    | isFinite difference && isFinite tolerance+        && tolerance > 0 && abs difference > tolerance = difference <= 0+    | otherwise = exactCircumradiusSquaredWithin threshold ax ay bx by cx cy+   where+    !abx = bx - ax+    !aby = by - ay+    !acx = cx - ax+    !acy = cy - ay+    !bcx = cx - bx+    !bcy = cy - by+    !abSquared = abx * abx + aby * aby+    !acSquared = acx * acx + acy * acy+    !bcSquared = bcx * bcx + bcy * bcy+    !determinant = abx * acy - aby * acx+    !radiusNumerator = abSquared * acSquared * bcSquared+    !thresholdDenominator = 4 * determinant * determinant * threshold+    !difference = radiusNumerator - thresholdDenominator+    !permanent = abs radiusNumerator + abs thresholdDenominator+    !tolerance = 128 * scalarUnitRoundoff * permanent++{-# INLINE circumradiusSquaredWithinCoordinates #-}++-- | Whether a scalar is neither infinite nor NaN. Pure subtraction avoids the+-- FFI calls used by base's predicates in the supported GHC.+isFinite :: Double -> Bool+isFinite value = value - value == 0+{-# INLINE isFinite #-}  -- The binary64 kernel pairs the approximation test with the -- fixed-precision exact sign, which answers the dyadic determinant's sign in
+ src-dcel/Moonlight/Triangulation/CellSet.hs view
@@ -0,0 +1,18 @@+-- | Finite downward-closed selections of relatively open vertices, edges, and+-- bounded faces. A selection retains its resident DCEL and exact coordinate+-- projection behind an opaque carrier.+module Moonlight.Triangulation.CellSet+  ( ExactCellSet+  , CellSelectionError (..)+  , exactCellSet+  , closeFaceCellSet+  , exactCellSetVertexCount+  , exactCellSetEdgeCount+  , exactCellSetFaceCount+  , foldExactCellVertices+  , foldExactCellEdges+  , foldExactCellFaces+  ) where++import Moonlight.Triangulation.Internal.CellSet+
src-dcel/Moonlight/Triangulation/Dcel.hs view
@@ -24,6 +24,8 @@   , mapDirectedEdges   , mapUndirectedEdges   , mapFaces+  , imapUndirectedEdges+  , imapFaces   , vertexOutEdge   , adjacentEdge   , origin@@ -39,6 +41,7 @@   , faceDirectedEdges   , faceVertices   , innerFaceDirectedEdges+  , innerFaceDirectedEdgeTriples   , innerFaceVertices   , innerFaceVertexTriples   , vertexOutgoingEdges@@ -249,8 +252,8 @@  -- | The three directed edges of a bounded triangular face. innerFaceDirectedEdges :: Triangulation mode vertex directed undirected face -> FaceId -> Maybe (DirectedEdgeId, DirectedEdgeId, DirectedEdgeId)-innerFaceDirectedEdges triangulation face-  | face == outerFace = Nothing+innerFaceDirectedEdges triangulation face@(FaceId rawFace)+  | face == outerFace || fromIntegral rawFace >= numFaces triangulation = Nothing   | otherwise = do       e0 <- adjacentEdge triangulation face       let !e1 = next triangulation e0@@ -260,6 +263,20 @@         else Nothing {-# INLINE innerFaceDirectedEdges #-} +-- | Dense bounded-face directed-edge triples in face-handle order.+innerFaceDirectedEdgeTriples+  :: Triangulation mode vertex directed undirected face+  -> V.Vector (DirectedEdgeId, DirectedEdgeId, DirectedEdgeId)+innerFaceDirectedEdgeTriples triangulation =+  V.generate (numInnerFaces triangulation) $ \innerFaceIndex ->+    let !faceIndex = innerFaceIndex + 1+        !firstEdge =+          DirectedEdgeId+            (pagedUnsafeIndex (triFaceEdge triangulation) faceIndex)+        !secondEdge = next triangulation firstEdge+     in (firstEdge, secondEdge, next triangulation secondEdge)+{-# INLINE innerFaceDirectedEdgeTriples #-}+ -- | The three vertices of a bounded triangular face. innerFaceVertices :: Triangulation mode vertex directed undirected face -> FaceId -> Maybe (VertexId, VertexId, VertexId) innerFaceVertices triangulation face = do@@ -272,17 +289,14 @@   :: 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-        )+  fmap+    (\(firstEdge, secondEdge, thirdEdge) ->+      ( origin triangulation firstEdge+      , origin triangulation secondEdge+      , origin triangulation thirdEdge+      )+    )+    (innerFaceDirectedEdgeTriples triangulation) {-# INLINE innerFaceVertexTriples #-}  -- | Counter-clockwise ring of directed edges originating at a vertex.
+ src-dcel/Moonlight/Triangulation/Exact.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Exact rational planar geometry over admitted binary64 points.+module Moonlight.Triangulation.Exact+  ( ExactPoint+  , exactPoint+  , exactPointCoordinates+  , exactPointCross+  , ExactVector (..)+  , exactVectorFromPoints+  , addExactVectors+  , exactCross+  , compareExactVectorAngle+  , translateExactPoint+  , ExactSegment+  , ExactGeometryError (..)+  , exactSegment+  , exactSegmentEndpoints+  , exactPointFromPoint+  , exactPointFromQueryPoint+  , exactPointToEmbeddingCandidate+  , exactOrient2d+  , exactOnClosedSegment+  , SegmentRelation (..)+  , allSegmentRelations+  , exactSegmentRelation+  , ExactIntersectionError (..)+  , exactLineIntersection+  , exactSupportingLineIntersection+  ) where++import Control.DeepSeq (NFData)+import GHC.Generics (Generic)+import Moonlight.Triangulation.Internal.Dyadic (integerRatioToDouble)+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactArithmeticError (..)+  , ExactRational+  , exactDivide+  , exactRationalDenominator+  , exactRationalFromFiniteDouble+  , exactRationalNumerator+  , exactSignum+  )+import Moonlight.Triangulation.Internal.SegmentRelation+  ( SegmentRelation (..)+  , allSegmentRelations+  , segmentRelationWith+  )+import Moonlight.Triangulation.Math (mkQueryPoint)+import Moonlight.Triangulation.Types+  ( Point (..)+  , PointValidationError+  , QueryPoint+  , queryPointValue+  )++-- | A strict exact Cartesian point.+data ExactPoint = ExactPoint !ExactRational !ExactRational+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A strict exact segment whose endpoints are distinct.+data ExactSegment = ExactSegment !ExactPoint !ExactPoint+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Witness-bearing refusals from exact segment construction.+data ExactGeometryError+  = ExactSegmentEndpointsCoincide !ExactPoint+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Witness-bearing refusals from exact line intersection.+data ExactIntersectionError+  = ExactIntersectionAbsent !SegmentRelation+  | ExactIntersectionNonUnique !SegmentRelation+  | ExactIntersectionParallelOrDegenerate !ExactRational+  | ExactIntersectionArithmetic !ExactArithmeticError+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Construct an exact point from two exact coordinates.+exactPoint :: ExactRational -> ExactRational -> ExactPoint+exactPoint = ExactPoint+{-# INLINE exactPoint #-}++-- | Read both exact point coordinates.+exactPointCoordinates :: ExactPoint -> (ExactRational, ExactRational)+exactPointCoordinates (ExactPoint x y) = (x, y)+{-# INLINE exactPointCoordinates #-}++-- | Determinant of two points regarded as vectors from the Cartesian origin.+exactPointCross :: ExactPoint -> ExactPoint -> ExactRational+exactPointCross (ExactPoint ax ay) (ExactPoint bx by) = ax * by - ay * bx+{-# INLINE exactPointCross #-}++-- | Construct an exact segment, refusing coincident endpoints with their+-- shared point as the witness.+exactSegment+  :: ExactPoint+  -> ExactPoint+  -> Either ExactGeometryError ExactSegment+exactSegment from to+  | from == to = Left (ExactSegmentEndpointsCoincide from)+  | otherwise = Right (ExactSegment from to)++-- | Read both distinct exact segment endpoints.+exactSegmentEndpoints :: ExactSegment -> (ExactPoint, ExactPoint)+exactSegmentEndpoints (ExactSegment from to) = (from, to)+{-# INLINE exactSegmentEndpoints #-}++-- | Validate and exactly embed a raw binary64 point.+exactPointFromPoint :: Point -> Either PointValidationError ExactPoint+exactPointFromPoint = fmap exactPointFromQueryPoint . mkQueryPoint++-- | Exactly embed an already-admitted query point without repeating+-- coordinate validation.+exactPointFromQueryPoint :: QueryPoint -> ExactPoint+exactPointFromQueryPoint queryPoint =+  case queryPointValue queryPoint of+    Point x y ->+      ExactPoint+        (exactRationalFromFiniteDouble x)+        (exactRationalFromFiniteDouble y)+{-# INLINE exactPointFromQueryPoint #-}++-- | Deterministically project an exact point to a validated binary64+-- embedding candidate. This is not a correctly-rounded nearest-double claim;+-- callers must certify the candidate projection before relying on it.+exactPointToEmbeddingCandidate+  :: ExactPoint+  -> Either PointValidationError Point+exactPointToEmbeddingCandidate (ExactPoint x y) =+  queryPointValue+    <$> mkQueryPoint+      ( Point+          (integerRatioToDouble (exactRationalNumerator x) (exactRationalDenominator x))+          (integerRatioToDouble (exactRationalNumerator y) (exactRationalDenominator y))+      )++-- | Exact orientation of an ordered triple. 'GT' is a positive determinant+-- and counter-clockwise turn, 'EQ' is collinear, and 'LT' is clockwise.+exactOrient2d :: ExactPoint -> ExactPoint -> ExactPoint -> Ordering+exactOrient2d+  (ExactPoint ax ay)+  (ExactPoint bx by)+  (ExactPoint cx cy) =+    exactSignum+      ((bx - ax) * (cy - ay) - (by - ay) * (cx - ax))+{-# INLINE exactOrient2d #-}++-- | Whether an exact point lies on an exact closed segment.+exactOnClosedSegment :: ExactPoint -> ExactPoint -> ExactPoint -> Bool+exactOnClosedSegment+  from@(ExactPoint ax ay)+  to@(ExactPoint bx by)+  query@(ExactPoint qx qy) =+    exactOrient2d from to query == EQ+      && qx >= min ax bx+      && qx <= max ax bx+      && qy >= min ay by+      && qy <= max ay by+{-# INLINE exactOnClosedSegment #-}++-- | Exact rational specialization of the one closed-segment relation policy.+exactSegmentRelation+  :: ExactPoint+  -> ExactPoint+  -> ExactPoint+  -> ExactPoint+  -> SegmentRelation+exactSegmentRelation =+  segmentRelationWith (==) compare exactOrient2d exactOnClosedSegment+{-# INLINE exactSegmentRelation #-}++-- | Return the unique exact intersection of two exact segments. Disjoint and+-- non-unique relations are refused with their relation witness; a zero line+-- cross product and arithmetic failure retain their exact witnesses.+exactLineIntersection+  :: ExactSegment+  -> ExactSegment+  -> Either ExactIntersectionError ExactPoint+exactLineIntersection+  (ExactSegment a b)+  (ExactSegment c d) =+    case exactSegmentRelation a b c d of+      SegmentsDisjoint -> Left (ExactIntersectionAbsent SegmentsDisjoint)+      SegmentsDuplicate -> Left (ExactIntersectionNonUnique SegmentsDuplicate)+      SegmentsCollinearlyOverlap ->+        Left (ExactIntersectionNonUnique SegmentsCollinearlyOverlap)+      SegmentsShareEndpoint -> uniqueIntersection+      SegmentsProperlyCross -> uniqueIntersection+      SegmentEndpointTouchesInterior -> uniqueIntersection+ where+  uniqueIntersection =+    exactSupportingLineIntersection (ExactSegment a b) (ExactSegment c d)++-- | Intersect the infinite supporting lines of two admitted exact segments.+-- Unlike 'exactLineIntersection', the intersection need not lie inside either+-- closed segment. Parallel supporting lines retain the exact zero denominator+-- witness.+exactSupportingLineIntersection+  :: ExactSegment+  -> ExactSegment+  -> Either ExactIntersectionError ExactPoint+exactSupportingLineIntersection+  (ExactSegment a b)+  (ExactSegment c d) =+  let directionAB = exactVectorFromPoints a b+      directionCD = exactVectorFromPoints c d+      fromAToC = exactVectorFromPoints a c+      denominator = exactCross directionAB directionCD+      numerator = exactCross fromAToC directionCD+   in case exactDivide numerator denominator of+        Left ExactZeroDivisor ->+          Left (ExactIntersectionParallelOrDegenerate denominator)+        Left arithmeticError -> Left (ExactIntersectionArithmetic arithmeticError)+        Right parameter ->+          Right (translateExactPoint a (scaleExactVector parameter directionAB))++-- | A strict exact displacement vector. Points and vectors remain distinct;+-- all exact planar algorithms share this single vector carrier.+data ExactVector = ExactVector !ExactRational !ExactRational+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++exactVectorFromPoints :: ExactPoint -> ExactPoint -> ExactVector+exactVectorFromPoints (ExactPoint ax ay) (ExactPoint bx by) =+  ExactVector (bx - ax) (by - ay)++addExactVectors :: ExactVector -> ExactVector -> ExactVector+addExactVectors (ExactVector ax ay) (ExactVector bx by) =+  ExactVector (ax + bx) (ay + by)++exactCross :: ExactVector -> ExactVector -> ExactRational+exactCross (ExactVector ax ay) (ExactVector bx by) =+  ax * by - ay * bx++-- | Counter-clockwise angular order from the positive x-axis. Collinear+-- vectors on the same ray compare equal so convolution can merge them;+-- callers that need a total point order may add their own radial tie-break.+compareExactVectorAngle :: ExactVector -> ExactVector -> Ordering+compareExactVectorAngle left right =+  case compare (vectorHalf left) (vectorHalf right) of+    EQ ->+      case exactSignum (exactCross left right) of+        GT -> LT+        LT -> GT+        EQ -> EQ+    ordering -> ordering+ where+  vectorHalf (ExactVector x y)+    | exactSignum y == GT = False+    | exactSignum y == EQ && exactSignum x /= LT = False+    | otherwise = True+{-# INLINE compareExactVectorAngle #-}++scaleExactVector :: ExactRational -> ExactVector -> ExactVector+scaleExactVector scale (ExactVector x y) =+  ExactVector (scale * x) (scale * y)++translateExactPoint :: ExactPoint -> ExactVector -> ExactPoint+translateExactPoint (ExactPoint x y) (ExactVector dx dy) =+  ExactPoint (x + dx) (y + dy)
src-dcel/Moonlight/Triangulation/FloodFillIterator.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-}  -- | Shape queries and face flood fills over immutable triangulations.@@ -5,6 +9,7 @@   ( DistanceMetric (..)   , CircleMetric   , CircleMetricError (..)+  , RadiusSquaredError (..)   , RectangleMetric   , RectangleMetricError (..)   , circleMetric@@ -18,16 +23,96 @@   , floodFillFaces   , outerFaceFloodFill   , facesAtEvenBarrierDepth+  , FaceComponent+  , faceComponentFaces+  , BoundaryLoop+  , boundaryLoopVertices+  , RegionBoundary+  , regionBoundaryOuterLoop+  , regionBoundaryHoleLoops+  , BoundaryObstruction (..)+  , faceComponents+  , labelledRegionBoundaries+  , componentBoundary+  , RadiusSquared+  , mkRadiusSquared+  , alphaShapeContainsFace   ) where +import Control.DeepSeq (NFData)+import Data.Bifunctor (first)+import qualified Data.IntMap.Strict as IntMap import qualified Data.IntSet as IntSet+import Data.List (partition, unfoldr)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Sequence as Seq+import qualified Data.Vector as V+import GHC.Generics (Generic) import Moonlight.Triangulation.Dcel import Moonlight.Triangulation.Handles.HandleDefs import Moonlight.Triangulation.Handles.Iterators.FixedIterators (undirectedEdges)+import Moonlight.Triangulation.Internal.BoundaryCycle (simplifyBoundaryCycle) import Moonlight.Triangulation.Math import Moonlight.Triangulation.PointLocation+import Moonlight.Triangulation.Scalar (circumradiusSquaredWithinCoordinates) import Moonlight.Triangulation.Types +-- | One non-empty connected set of equally labelled bounded face indices.+newtype FaceComponent = FaceComponent IntSet.IntSet+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Component faces in ascending DCEL order.+faceComponentFaces :: FaceComponent -> [FaceId]+faceComponentFaces (FaceComponent faces) =+  fmap (FaceId . fromIntegral) (IntSet.toAscList faces)++-- | One non-empty simple boundary loop. Outer loops are counter-clockwise and+-- hole loops clockwise.+newtype BoundaryLoop = BoundaryLoop+  { boundaryLoopVertices :: NonEmpty VertexId+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | The authoritative boundary of one face component.+data RegionBoundary = RegionBoundary+  { regionBoundaryOuterLoop :: !BoundaryLoop+  , regionBoundaryHoleLoops :: ![BoundaryLoop]+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Typed failure to descend boundary half-edges into simple polygon loops.+data BoundaryObstruction+  = BoundaryComponentFaceOutOfRange !FaceId {-# UNPACK #-} !Int+  | BoundaryPinch !VertexId !DirectedEdgeId !DirectedEdgeId+  | BoundaryCycleDidNotClose !DirectedEdgeId !DirectedEdgeId+  | BoundaryLoopDegenerate ![VertexId]+  | BoundaryOuterLoopCardinality !Int+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | An admitted finite, non-negative squared radius.+newtype RadiusSquared = RadiusSquared Double+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Typed refusal shared by every squared-radius constructor.+data RadiusSquaredError+  = NonFiniteRadiusSquared !NonFiniteValue+  | NegativeRadiusSquared !Double+  deriving stock (Eq, Ord, Show)++-- | Admit a finite, non-negative squared radius.+mkRadiusSquared :: Double -> Either RadiusSquaredError RadiusSquared+mkRadiusSquared value =+  case classifyNonFinite value of+    Just nonFinite -> Left (NonFiniteRadiusSquared nonFinite)+    Nothing+      | value < 0 -> Left (NegativeRadiusSquared value)+      | otherwise -> Right (RadiusSquared value)+ -- | A query shape that can admit points, test edges, and supply a location -- seed. class DistanceMetric metric where@@ -36,14 +121,13 @@   metricStartPoint :: metric -> QueryPoint  -- | An admitted center and squared radius.-data CircleMetric = CircleMetric !(QueryPoint) !Double+data CircleMetric = CircleMetric !QueryPoint !RadiusSquared   deriving stock (Eq, Ord, Show)  -- | Typed refusal for an invalid circle query. data CircleMetricError   = InvalidCircleCenter !PointValidationError-  | NonFiniteRadiusSquared !NonFiniteValue-  | NegativeRadiusSquared !Double+  | InvalidCircleRadius !RadiusSquaredError   deriving stock (Eq, Ord, Show)  -- | Admitted lower corner, upper corner, and center of an axis-aligned box.@@ -59,13 +143,10 @@  -- | 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)+circleMetric center radiusSquared =+  CircleMetric+    <$> first InvalidCircleCenter (mkQueryPoint center)+    <*> first InvalidCircleRadius (mkRadiusSquared radiusSquared)  -- | An axis-aligned rectangle metric, or why the corners are unusable. rectangleMetric :: Point -> Point -> Either RectangleMetricError RectangleMetric@@ -80,9 +161,9 @@   Right (RectangleMetric queryLower queryUpper queryCenter)  instance DistanceMetric CircleMetric where-  metricContainsPoint (CircleMetric center radiusSquared) point =+  metricContainsPoint (CircleMetric center (RadiusSquared radiusSquared)) point =     squaredDistanceWide (queryPointValue center) point <= radiusSquared-  metricIntersectsEdge (CircleMetric center radiusSquared) from to =+  metricIntersectsEdge (CircleMetric center (RadiusSquared radiusSquared)) from to =     segmentDistanceSquaredWide from to (queryPointValue center) <= radiusSquared   metricStartPoint (CircleMetric center _) = center @@ -174,7 +255,11 @@   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)+          foldFaceDirectedEdges'+            triangulation+            face+            expand+            (stack, visited, accepted, rejected)      in go stack' visited' accepted' rejected' (face : result)    expand (stack, visited, accepted, rejected) edge =@@ -198,6 +283,199 @@     | otherwise = (face : stack, IntSet.insert index visited)    where     index = fromIntegral value++-- | Connected components of equally labelled bounded faces. Labels are+-- evaluated once; the component carrier is the same 'IntSet' used by descent.+faceComponents+  :: Eq label+  => Triangulation mode vertex directed undirected face+  -> (FaceId -> label)+  -> [(label, FaceComponent)]+faceComponents triangulation labelFace = unfoldr descend initialUnvisited+ where+  labels =+    V.generate+      (numInnerFaces triangulation)+      (\index -> labelFace (FaceId (fromIntegral (index + 1))))+  initialUnvisited =+    IntSet.fromRange (1, numFaces triangulation - 1)+  labelAt faceIndex = labels V.!? (faceIndex - 1)++  descend remaining =+    case IntSet.minView remaining of+      Nothing -> Nothing+      Just (seedIndex, unseeded) ->+        case labelAt seedIndex of+          Nothing -> descend unseeded+          Just componentLabel ->+            let unvisited =+                  collectComponent componentLabel (Seq.singleton seedIndex) unseeded+                componentFaces = IntSet.difference remaining unvisited+             in Just ((componentLabel, FaceComponent componentFaces), unvisited)++  collectComponent componentLabel queued unvisited =+    case Seq.viewl queued of+      Seq.EmptyL -> unvisited+      faceIndex Seq.:< remainingQueue ->+        let face = FaceId (fromIntegral faceIndex)+            (expandedQueue, remainingUnvisited) =+              foldFaceDirectedEdges'+                triangulation+                face+                (admitAdjacent componentLabel)+                (remainingQueue, unvisited)+         in collectComponent+              componentLabel+              expandedQueue+              remainingUnvisited++  admitAdjacent componentLabel (queued, unvisited) edge =+    if+      adjacent /= outerFace+        && IntSet.member adjacentIndex unvisited+        && labelAt adjacentIndex == Just componentLabel+      then+        ( queued Seq.|> adjacentIndex+        , IntSet.delete adjacentIndex unvisited+        )+      else (queued, unvisited)+   where+    adjacent@(FaceId adjacentRaw) =+      incidentFace triangulation (reverseEdge edge)+    adjacentIndex = fromIntegral adjacentRaw++-- | Descend every equally labelled bounded-face component through the one+-- authoritative boundary tracer. Components are converted independently;+-- callers may group equal labels only after this descent has succeeded.+labelledRegionBoundaries+  :: Eq label+  => Triangulation mode vertex directed undirected face+  -> (FaceId -> label)+  -> Either BoundaryObstruction [(label, RegionBoundary)]+labelledRegionBoundaries triangulation labelFace =+  traverse+    (\(label, component) -> (label,) <$> componentBoundary triangulation component)+    (faceComponents triangulation labelFace)++-- | Extract all simple boundary loops of a component from the DCEL. Boundary+-- half-edges retain their incident component face on the left; this gives the+-- outer loop counter-clockwise and holes clockwise without a later guess.+componentBoundary+  :: Triangulation mode vertex directed undirected face+  -> FaceComponent+  -> Either BoundaryObstruction RegionBoundary+componentBoundary triangulation (FaceComponent componentFaces) = do+  case IntSet.lookupGE (numFaces triangulation) componentFaces of+    Just invalid ->+      Left+        ( BoundaryComponentFaceOutOfRange+            (FaceId (fromIntegral invalid))+            (numFaces triangulation)+        )+    Nothing -> Right ()+  (boundaryEdges, outgoingSuccessor) <-+    IntSet.foldl'+      collectFaceBoundaryEdges+      (Right (IntSet.empty, IntMap.empty))+      componentFaces+  orientedLoops <- traceBoundaryLoops triangulation outgoingSuccessor boundaryEdges+  let (outer, holes) = partition ((== GT) . fst) orientedLoops+      outerLoops = fmap snd outer+      holeLoops = fmap snd holes+  case outerLoops of+    [outerLoop] ->+      Right+        RegionBoundary+          { regionBoundaryOuterLoop = outerLoop+          , regionBoundaryHoleLoops = holeLoops+          }+    _ -> Left (BoundaryOuterLoopCardinality (length outerLoops))+ where+  collectFaceBoundaryEdges boundaryGraph face =+    foldFaceDirectedEdges'+      triangulation+      (FaceId (fromIntegral face))+      insertBoundaryEdge+      boundaryGraph++  insertBoundaryEdge outcome edge = do+    graph@(edges, successors) <- outcome+    let FaceId adjacent = incidentFace triangulation (reverseEdge edge)+    if IntSet.member (fromIntegral adjacent) componentFaces+      then Right graph+      else+        let vertex@(VertexId rawVertex) = origin triangulation edge+            vertexIndex = fromIntegral rawVertex+            DirectedEdgeId rawEdge = edge+         in case IntMap.lookup vertexIndex successors of+              Just previousEdge -> Left (BoundaryPinch vertex previousEdge edge)+              Nothing ->+                Right+                  ( IntSet.insert (fromIntegral rawEdge) edges+                  , IntMap.insert vertexIndex edge successors+                  )++traceBoundaryLoops+  :: Triangulation mode vertex directed undirected face+  -> IntMap.IntMap DirectedEdgeId+  -> IntSet.IntSet+  -> Either BoundaryObstruction [(Ordering, BoundaryLoop)]+traceBoundaryLoops triangulation outgoingByVertex = descend []+ where+  descend loops unvisited =+    case IntSet.minView unvisited of+      Nothing -> Right (reverse loops)+      Just (rawStart, _) -> do+        let start = DirectedEdgeId (fromIntegral rawStart)+        (vertices, remaining) <- traceCycle start start unvisited []+        oriented <- simplifyBoundaryLoop triangulation vertices+        descend (oriented : loops) remaining++  traceCycle start current unvisited reversedVertices =+    let DirectedEdgeId rawCurrent = current+        remaining = IntSet.delete (fromIntegral rawCurrent) unvisited+        accumulated = origin triangulation current : reversedVertices+        VertexId rawTarget = destination triangulation current+     in case IntMap.lookup (fromIntegral rawTarget) outgoingByVertex of+          Just successor+            | successor == start -> Right (reverse accumulated, remaining)+            | let DirectedEdgeId rawSuccessor = successor+            , IntSet.member (fromIntegral rawSuccessor) remaining ->+                traceCycle start successor remaining accumulated+            | otherwise -> Left (BoundaryCycleDidNotClose start successor)+          Nothing -> Left (BoundaryCycleDidNotClose start current)++simplifyBoundaryLoop+  :: Triangulation mode vertex directed undirected face+  -> [VertexId]+  -> Either BoundaryObstruction (Ordering, BoundaryLoop)+simplifyBoundaryLoop triangulation =+  fmap (\(orientation, vertices) -> (orientation, BoundaryLoop vertices))+    . simplifyBoundaryCycle BoundaryLoopDegenerate redundant winding key+ where+  point vertex = vertexPoint triangulation vertex+  redundant previousVertex current nextVertex =+    orient2d (point previousVertex) (point current) (point nextVertex) == EQ+      && onClosedSegment (point previousVertex) (point nextVertex) (point current)+  winding previousVertex current nextVertex =+    orient2d (point previousVertex) (point current) (point nextVertex)+  key vertex = (point vertex, vertex)++-- | Membership of a bounded face in the closed alpha shape. Exact dyadic+-- comparison makes equality independent of circumcenter rounding.+alphaShapeContainsFace+  :: RadiusSquared+  -> Triangulation 'Unconstrained vertex directed undirected face+  -> FaceId+  -> Bool+alphaShapeContainsFace (RadiusSquared threshold) triangulation =+  maybe False withinRadius . innerFaceVertices triangulation+ where+  withinRadius (firstVertex, secondVertex, thirdVertex) =+    let Point ax ay = vertexPoint triangulation firstVertex+        Point bx by = vertexPoint triangulation secondVertex+        Point cx cy = vertexPoint triangulation thirdVertex+     in circumradiusSquaredWithinCoordinates threshold ax ay bx by cx cy  -- | 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,
+ src-dcel/Moonlight/Triangulation/Internal/BoundaryCycle.hs view
@@ -0,0 +1,136 @@+-- | The shared algebra for simplifying and classifying an already-traced+-- boundary cycle. Topology traversal remains in 'FloodFillIterator'; this+-- module owns only fixed-point collinear deletion and winding observation.+module Moonlight.Triangulation.Internal.BoundaryCycle+  ( simplifyBoundaryCycle+  , rotateCycleLeast+  , rotateCycleLeastBy+  , consecutivePairs+  , unorderedPairs+  , orderedPair+  , cyclePairs+  , cyclePairsNonEmpty+  , cyclicTriples+  ) where++import Data.List.NonEmpty (NonEmpty (..))+import Data.List (tails)+import qualified Data.List.NonEmpty as NonEmpty++-- | Remove precisely the vertices admitted by @isRedundant@ until a fixed+-- point is reached, then classify the winding at the least keyed retained+-- vertex. The returned cycle preserves the tracer's start; publication layers+-- may rotate their value-level observation independently. The caller supplies+-- its obstruction constructor so the shared worker does not allocate a+-- disposable intermediate error vocabulary at either specialization.+simplifyBoundaryCycle+  :: (Eq value, Ord key)+  => ([value] -> obstruction)+  -> (value -> value -> value -> Bool)+  -> (value -> value -> value -> Ordering)+  -> (value -> key)+  -> [value]+  -> Either obstruction (Ordering, NonEmpty value)+simplifyBoundaryCycle obstruction isRedundant orientation key = descend+ where+  descend values@(_ : _ : _ : _) =+    let triples = cyclicTriples values+        retained =+          [ current+          | (previousValue, current, nextValue) <- triples+          , not (isRedundant previousValue current nextValue)+          ]+     in if retained == values+          then classify values triples+          else descend retained+  descend values = Left (obstruction values)++  classify values triples =+    case triples of+      [] -> Left (obstruction values)+      firstTriple : remainingTriples ->+        let (previousValue, current, nextValue) =+              foldl' chooseLeast firstTriple remainingTriples+            winding = orientation previousValue current nextValue+         in case (winding, values) of+              (EQ, _) -> Left (obstruction values)+              (_, initialValue : rest) -> Right (winding, initialValue :| rest)+              _ -> Left (obstruction values)++  chooseLeast selected@(_, selectedValue, _) candidate@(_, candidateValue, _)+    | key candidateValue < key selectedValue = candidate+    | otherwise = selected+{-# INLINE simplifyBoundaryCycle #-}++-- | Choose the least value as a cycle's observational origin without changing+-- its orientation. Boundary publication and generated convex geometry share+-- this one canonical rotation owner.+rotateCycleLeast :: Ord value => NonEmpty value -> NonEmpty value+rotateCycleLeast = rotateCycleLeastBy id+{-# INLINE rotateCycleLeast #-}++-- | Choose the least keyed value as a cycle's observational origin.+rotateCycleLeastBy+  :: Ord key+  => (value -> key)+  -> NonEmpty value+  -> NonEmpty value+rotateCycleLeastBy key values =+  case break ((== minimumKey) . key) asList of+    (before, selected : after) -> selected :| (after <> before)+    _ -> values+ where+  asList = NonEmpty.toList values+  minimumKey =+    foldl'+      (\selected candidate -> min selected (key candidate))+      (key (NonEmpty.head values))+      (NonEmpty.tail values)+{-# INLINE rotateCycleLeastBy #-}++-- | Every adjacent pair in a linear sequence.+consecutivePairs :: [value] -> [(value, value)]+consecutivePairs values = zip values (drop 1 values)+{-# INLINE consecutivePairs #-}++-- | Every unordered pair exactly once.+unorderedPairs :: [value] -> [(value, value)]+unorderedPairs values =+  [(left, right) | left : remaining <- tails values, right <- remaining]+{-# INLINE unorderedPairs #-}++-- | Canonically orient an unordered pair.+orderedPair :: Ord value => value -> value -> (value, value)+orderedPair left right+  | left <= right = (left, right)+  | otherwise = (right, left)+{-# INLINE orderedPair #-}++-- | Every directed edge of a non-empty cycle in cycle order.+cyclePairs :: NonEmpty value -> [(value, value)]+cyclePairs = NonEmpty.toList . cyclePairsNonEmpty+{-# INLINE cyclePairs #-}++-- | The non-empty form of 'cyclePairs'. A singleton cycle has its sole value+-- as both ends of its sole cyclic edge.+cyclePairsNonEmpty :: NonEmpty value -> NonEmpty (value, value)+cyclePairsNonEmpty values@(firstValue :| remaining) =+  NonEmpty.zip values successors+ where+  successors =+    case remaining of+      [] -> firstValue :| []+      nextValue : rest -> nextValue :| (rest <> [firstValue])+{-# INLINE cyclePairsNonEmpty #-}++-- | Consecutive cyclic triples, one centered at every value.+cyclicTriples :: [value] -> [(value, value, value)]+cyclicTriples values =+  case values of+    initial : second : remaining ->+      let final = foldl' (\_ current -> current) initial (second : remaining)+       in zip3+            (final : values)+            values+            (second : remaining <> [initial])+    _ -> []
src-dcel/Moonlight/Triangulation/Internal/Canonical.hs view
@@ -57,7 +57,10 @@   :: Triangulation mode vertex () () ()   -> Either BuildError (Triangulation mode vertex () () ()) canonicalize source = runST $ do-  mutable <- newMutableDcel (triElementDefaults source) (max 1 vertexTotal)+  mutable <-+    newMutableDcel+      (triElementDefaults source)+      (exactDcelCapacity vertexTotal directedTotal faceTotal)   forRange 0 vertexTotal $ \canonical -> do     let !old = vertexOrder `U.unsafeIndex` canonical     _ <-
+ src-dcel/Moonlight/Triangulation/Internal/CellSet.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}++-- | Invariant-bearing finite closed cell selections. The resident DCEL and+-- the exact coordinates of precisely the selected vertices remain sealed+-- together; no detached handle mask or whole-mesh projection exists.+module Moonlight.Triangulation.Internal.CellSet+  ( ExactCellSet (..)+  , CellSelectionError (..)+  , exactCellSet+  , closeFaceCellSet+  , closeExactCellSetWith+  , exactCellSetVertexCount+  , exactCellSetEdgeCount+  , exactCellSetFaceCount+  , foldExactCellVertices+  , foldExactCellEdges+  , foldExactCellFaces+  , exactCellSetIsFaceClosure+  ) where++import Control.DeepSeq (NFData)+import Data.Bifunctor (first)+import Data.Foldable (traverse_)+import qualified Data.IntMap.Strict as IntMap+import qualified Data.IntSet as IntSet+import GHC.Generics (Generic)+import Moonlight.Triangulation.Dcel+  ( faceDirectedEdges+  , numFaces+  , numUndirectedEdges+  , numVertices+  , undirectedEndpoints+  , vertexPoint+  )+import Moonlight.Triangulation.Exact (ExactPoint, exactPointFromPoint)+import Moonlight.Triangulation.Handles.HandleDefs+  ( FaceId (..)+  , UndirectedEdgeId (..)+  , VertexId (..)+  , asUndirected+  )+import Moonlight.Triangulation.Internal.Representation (Triangulation)+import Moonlight.Triangulation.Internal.Types (PointValidationError)++-- | The keys of the exact-point map are the selected vertices; a second+-- vertex set would merely be a disagreeable copy.+data ExactCellSet where+  ExactCellSet+    :: !(Triangulation mode vertex directed undirected face)+    -> !(IntMap.IntMap ExactPoint)+    -> !IntSet.IntSet+    -> !IntSet.IntSet+    -> ExactCellSet++data ClosedCellIds = ClosedCellIds+  { closedVertexIds :: !IntSet.IntSet+  , closedEdgeIds :: !IntSet.IntSet+  , closedFaceIds :: !IntSet.IntSet+  }++data CellSelectionError+  = CellVertexOutOfRange !VertexId !Int+  | CellEdgeOutOfRange !UndirectedEdgeId !Int+  | CellFaceOutOfRange !FaceId !Int+  | CellOuterFaceSelected+  | CellCoordinateInvalid !VertexId !PointValidationError+  | CellEdgeBoundaryMissing !UndirectedEdgeId !VertexId+  | CellFaceEdgeMissing !FaceId !UndirectedEdgeId+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | The strict authoring boundary validates handles and closure once, then+-- converts only selected vertices.+exactCellSet+  :: Triangulation mode vertex directed undirected face+  -> [VertexId]+  -> [UndirectedEdgeId]+  -> [FaceId]+  -> Either CellSelectionError ExactCellSet+exactCellSet triangulation selectedVertices selectedEdges selectedFaces = do+  validateHandles triangulation selectedVertices selectedEdges selectedFaces+  let verticesSet = vertexSet selectedVertices+      edgesSet = edgeSet selectedEdges+      facesSet = faceSet selectedFaces+  traverse_ (validateEdgeClosure triangulation verticesSet) selectedEdges+  traverse_ (validateFaceClosure triangulation edgesSet) selectedFaces+  sealCellSet+    (ordinaryExactPoint triangulation)+    triangulation+    (ClosedCellIds verticesSet edgesSet facesSet)++-- | Close a bounded face selection over all resident boundary cells. Face+-- handles are author input and are checked; constructed closure is not then+-- pointlessly proved a second time.+closeFaceCellSet+  :: Triangulation mode vertex directed undirected face+  -> [FaceId]+  -> Either CellSelectionError ExactCellSet+closeFaceCellSet triangulation selectedFaces = do+  validateHandles triangulation [] [] selectedFaces+  sealCellSet+    (ordinaryExactPoint triangulation)+    triangulation+    (closeCellIds triangulation [] [] selectedFaces)++-- | Seal closure derived by a trusted downstream owner. Overlay supplies+-- handles from this very DCEL, so repeating range and closure validation would+-- protect against an impossible phase while charging every selection for it.+closeExactCellSetWith+  :: (VertexId -> Either CellSelectionError ExactPoint)+  -> Triangulation mode vertex directed undirected face+  -> [VertexId]+  -> [UndirectedEdgeId]+  -> [FaceId]+  -> Either CellSelectionError ExactCellSet+closeExactCellSetWith exactPointAt triangulation explicitVertices explicitEdges selectedFaces =+  sealCellSet+    exactPointAt+    triangulation+    (closeCellIds triangulation explicitVertices explicitEdges selectedFaces)++ordinaryExactPoint+  :: Triangulation mode vertex directed undirected face+  -> VertexId+  -> Either CellSelectionError ExactPoint+ordinaryExactPoint triangulation vertex =+  first (CellCoordinateInvalid vertex)+    (exactPointFromPoint (vertexPoint triangulation vertex))++sealCellSet+  :: (VertexId -> Either CellSelectionError ExactPoint)+  -> Triangulation mode vertex directed undirected face+  -> ClosedCellIds+  -> Either CellSelectionError ExactCellSet+sealCellSet exactPointAt triangulation closed = do+  exactPoints <- exactPointsFor exactPointAt (closedVertexIds closed)+  pure+    ( ExactCellSet+        triangulation+        exactPoints+        (closedEdgeIds closed)+        (closedFaceIds closed)+    )++closeCellIds+  :: Triangulation mode vertex directed undirected face+  -> [VertexId]+  -> [UndirectedEdgeId]+  -> [FaceId]+  -> ClosedCellIds+closeCellIds triangulation explicitVertices explicitEdges selectedFaces =+  let faceEdges =+        concatMap+          (map asUndirected . faceDirectedEdges triangulation)+          selectedFaces+      edges = edgeSet (explicitEdges <> faceEdges)+      closedEdges = map (UndirectedEdgeId . fromIntegral) (IntSet.toAscList edges)+      edgeVertices =+        concatMap+          (\edge ->+             let (from, to) = undirectedEndpoints triangulation edge+              in [from, to])+          closedEdges+      vertices =+        vertexSet+          ( explicitVertices+              <> edgeVertices+          )+   in ClosedCellIds+        { closedVertexIds = vertices+        , closedEdgeIds = edges+        , closedFaceIds = faceSet selectedFaces+        }++exactPointsFor+  :: (VertexId -> Either CellSelectionError ExactPoint)+  -> IntSet.IntSet+  -> Either CellSelectionError (IntMap.IntMap ExactPoint)+exactPointsFor exactPointAt selected =+  IntMap.fromAscList+    <$> traverse+      (\index -> do+         point <- exactPointAt (VertexId (fromIntegral index))+         pure (index, point))+      (IntSet.toAscList selected)++validateHandles+  :: Triangulation mode vertex directed undirected face+  -> [VertexId]+  -> [UndirectedEdgeId]+  -> [FaceId]+  -> Either CellSelectionError ()+validateHandles triangulation selectedVertices selectedEdges selectedFaces = do+  traverse_ validateVertex selectedVertices+  traverse_ validateEdge selectedEdges+  traverse_ validateFace selectedFaces+ where+  validateVertex vertex@(VertexId raw)+    | fromIntegral raw < numVertices triangulation = Right ()+    | otherwise = Left (CellVertexOutOfRange vertex (numVertices triangulation))+  validateEdge edge@(UndirectedEdgeId raw)+    | fromIntegral raw < numUndirectedEdges triangulation = Right ()+    | otherwise = Left (CellEdgeOutOfRange edge (numUndirectedEdges triangulation))+  validateFace face@(FaceId raw)+    | raw == 0 = Left CellOuterFaceSelected+    | fromIntegral raw < numFaces triangulation = Right ()+    | otherwise = Left (CellFaceOutOfRange face (numFaces triangulation))++validateEdgeClosure+  :: Triangulation mode vertex directed undirected face+  -> IntSet.IntSet+  -> UndirectedEdgeId+  -> Either CellSelectionError ()+validateEdgeClosure triangulation selectedVertices edge =+  traverse_ requireVertex [from, to]+ where+  (from, to) = undirectedEndpoints triangulation edge+  requireVertex vertex@(VertexId raw)+    | IntSet.member (fromIntegral raw) selectedVertices = Right ()+    | otherwise = Left (CellEdgeBoundaryMissing edge vertex)++validateFaceClosure+  :: Triangulation mode vertex directed undirected face+  -> IntSet.IntSet+  -> FaceId+  -> Either CellSelectionError ()+validateFaceClosure triangulation selectedEdges face =+  traverse_ (requireEdge . asUndirected) (faceDirectedEdges triangulation face)+ where+  requireEdge edge@(UndirectedEdgeId raw)+    | IntSet.member (fromIntegral raw) selectedEdges = Right ()+    | otherwise = Left (CellFaceEdgeMissing face edge)++vertexSet :: [VertexId] -> IntSet.IntSet+vertexSet = IntSet.fromList . map (\(VertexId raw) -> fromIntegral raw)++edgeSet :: [UndirectedEdgeId] -> IntSet.IntSet+edgeSet = IntSet.fromList . map (\(UndirectedEdgeId raw) -> fromIntegral raw)++faceSet :: [FaceId] -> IntSet.IntSet+faceSet = IntSet.fromList . map (\(FaceId raw) -> fromIntegral raw)++exactCellSetVertexCount :: ExactCellSet -> Int+exactCellSetVertexCount (ExactCellSet _ selected _ _) = IntMap.size selected++exactCellSetEdgeCount :: ExactCellSet -> Int+exactCellSetEdgeCount (ExactCellSet _ _ selected _) = IntSet.size selected++exactCellSetFaceCount :: ExactCellSet -> Int+exactCellSetFaceCount (ExactCellSet _ _ _ selected) = IntSet.size selected++foldExactCellVertices+  :: (accumulator -> VertexId -> ExactPoint -> accumulator)+  -> accumulator+  -> ExactCellSet+  -> accumulator+foldExactCellVertices step initial (ExactCellSet _ selected _ _) =+  IntMap.foldlWithKey'+    (\accumulator index point ->+       step accumulator (VertexId (fromIntegral index)) point)+    initial+    selected++foldExactCellEdges+  :: (accumulator -> UndirectedEdgeId -> accumulator)+  -> accumulator+  -> ExactCellSet+  -> accumulator+foldExactCellEdges step initial (ExactCellSet _ _ selected _) =+  IntSet.foldl'+    (\accumulator index -> step accumulator (UndirectedEdgeId (fromIntegral index)))+    initial+    selected++foldExactCellFaces+  :: (accumulator -> FaceId -> accumulator)+  -> accumulator+  -> ExactCellSet+  -> accumulator+foldExactCellFaces step initial (ExactCellSet _ _ _ selected) =+  IntSet.foldl'+    (\accumulator index -> step accumulator (FaceId (fromIntegral index)))+    initial+    selected++-- | Whether the value contains exactly the downward closure of its selected+-- faces, with no additional isolated vertex or edge cells. This is the precise+-- admission condition for the conventional polygonal perimeter projection.+exactCellSetIsFaceClosure :: ExactCellSet -> Bool+exactCellSetIsFaceClosure (ExactCellSet triangulation points edges faces) =+  let selectedFaces =+        map (FaceId . fromIntegral) (IntSet.toAscList faces)+      closed = closeCellIds triangulation [] [] selectedFaces+   in IntMap.keysSet points == closedVertexIds closed+        && edges == closedEdgeIds closed+        && faces == closedFaceIds closed
src-dcel/Moonlight/Triangulation/Internal/DcelOperations.hs view
@@ -14,25 +14,33 @@   , lineToArea   , insertIntoFace   , insertOnEdge+  , ReservedSweepCells+  , SweepCellCursor+  , SweepInsertion (..)+  , reserveSweepCells+  , initialSweepCellCursor+  , commitReservedSweepConnections   , insertOutsideHull-  , insertOutsideHullBetween+  , insertOutsideHullAtEdge   , closeOuterTurn+  , closeOuterTurnReserved   , fixHullConvexity   , flipEdge   , legalizeScratch+  , legalizeStarEdge   , legalizeEdges   , legalizeCavityFanScratch   , LegalizationLaw (..)   , seedStarScratch   , seedGenericEdges   , drainLegalization-  , noStarVertex+  , CandidateDiscipline (..)   , isFlippableEdge   , collectLineChain   ) where  import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena-  ( noStarVertex+  ( CandidateDiscipline (..)   , seedGenericEdges   , seedStarScratch   )@@ -50,15 +58,23 @@   , isFlippableEdge   ) import Moonlight.Triangulation.Internal.DcelOperations.Hull-  ( closeOuterTurn+  ( ReservedSweepCells+  , SweepCellCursor+  , SweepInsertion (..)+  , closeOuterTurn+  , closeOuterTurnReserved+  , commitReservedSweepConnections   , fixHullConvexity+  , initialSweepCellCursor   , insertOutsideHull-  , insertOutsideHullBetween+  , insertOutsideHullAtEdge+  , reserveSweepCells   ) import Moonlight.Triangulation.Internal.DcelOperations.Legalize   ( legalizeCavityFanScratch   , legalizeEdges   , legalizeScratch+  , legalizeStarEdge   ) import Moonlight.Triangulation.Internal.DcelOperations.Normalize (drainLegalization) import Moonlight.Triangulation.Internal.DcelOperations.Subdivide
src-dcel/Moonlight/Triangulation/Internal/DcelOperations/CandidateArena.hs view
@@ -5,42 +5,35 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} --- | The legalization candidate stack: tagging, growth, and seeding.+-- | The legalization candidate stack: discipline, growth, and seeding. module Moonlight.Triangulation.Internal.DcelOperations.CandidateArena-  ( starCandidate-  , genericCandidate+  ( CandidateDiscipline (..)   , growLegalizationArena   , seedStarScratch+  , seedGenericPairInArena   , 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 (..)+  , 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 #-}+-- | Every normalization epoch is homogeneous. A star epoch turns each edge so+-- the inserted vertex is the opposite apex; a generic epoch consumes the+-- directed edge exactly as seeded. Keeping that fact at the epoch boundary+-- prevents every candidate from carrying and decoding a tag for a distinction+-- that cannot vary inside the stack.+data CandidateDiscipline+  = StarCandidates !Int+  | GenericCandidates  -- | Seed candidates from the scratch arena, returning the new stack top. -- Transaction-sized preallocation covers the normal path; rare adversarial@@ -49,33 +42,54 @@ seedStarScratch operation top candidateCount = do   initialArena <- legalizationArena operation   arena <- growLegalizationArena initialArena (top + candidateCount)-  when (MUV.length arena /= MUV.length initialArena) (storeLegalizationArena operation arena)+  when (legalizationArenaLength arena /= legalizationArenaLength initialArena) (storeLegalizationArena operation arena)+  let LegalizationArena values = arena   forM_ [0 .. candidateCount - 1] $ \index -> do     edge <- readScratch operation index-    MUV.unsafeWrite arena (top + index) (packIndex (starCandidate edge))+    MUV.unsafeWrite values (top + index) (packIndex edge)   pure (top + candidateCount) +-- | Append the fixed two-edge section produced by one closed hull turn.+-- Materializing @[left, right]@ only to count, zip and traverse it made the+-- dominant sweep rewrite pay list traffic for an arity known by construction.+-- The arena is explicit because a circle sweep borrows it once and glues it+-- back to the operation once, rather than performing three reference lookups+-- around every inserted point.+seedGenericPairInArena+  :: LegalizationArena s+  -> Int+  -> Int+  -> Int+  -> ST s (LegalizationArena s, Int)+seedGenericPairInArena initialArena top left right = do+  let !nextTop = top + 2+  arena <- growLegalizationArena initialArena nextTop+  let LegalizationArena values = arena+  MUV.unsafeWrite values top (packIndex left)+  MUV.unsafeWrite values (top + 1) (packIndex right)+  pure (arena, nextTop)+{-# INLINE seedGenericPairInArena #-}+ -- | 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)+  when (legalizationArenaLength arena /= legalizationArenaLength initialArena) (storeLegalizationArena operation arena)+  let LegalizationArena values = arena   forM_ (zip [0 ..] edges) $ \(!index, !edge) ->-    MUV.unsafeWrite arena (top + index) (packIndex (genericCandidate edge))+    MUV.unsafeWrite values (top + index) (packIndex edge)   pure (top + count) -growLegalizationArena :: MUV.MVector s Word32 -> Int -> ST s (MUV.MVector s Word32)-growLegalizationArena arena required+growLegalizationArena :: LegalizationArena s -> Int -> ST s (LegalizationArena s)+growLegalizationArena arena@(LegalizationArena values) required   | required <= current = pure arena-  | otherwise = MUV.grow arena (max (required - current) (max 1 current))+  | otherwise = LegalizationArena <$> MUV.grow values (max (required - current) (max 1 current))  where-  !current = MUV.length arena+  !current = MUV.length values {-# 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-+legalizationArenaLength :: LegalizationArena s -> Int+legalizationArenaLength (LegalizationArena values) = MUV.length values+{-# INLINE legalizationArenaLength #-}
src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRewrite.hs view
@@ -17,6 +17,7 @@ import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex) import Moonlight.Triangulation.Internal.Mutable   ( MutableDcel+  , MutableTopology (..)   , payloadsPristine   , readConstraint   , readFace@@ -25,9 +26,6 @@   , readPrevious   , resetEdgeData   , resetFaceData-  , setCycle3-  , writeOrigin-  , writeVertexOut   ) import Moonlight.Triangulation.Internal.Types (BuildError (ConstrainedEdgeFlipRefused)) @@ -57,7 +55,8 @@ -- 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+  :: MutableTopology mutable+  => mutable s vertex directed undirected face   -> Int   -> Int   -> Int@@ -71,11 +70,31 @@   -> 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+applyFlip topology edge twin edgeNext edgePrevious twinNext twinPrevious leftFace rightFace a b c d = do+  let !mutable = topologyOwner topology+  -- Rewrite only fields whose denotation changes. Re-stating both complete+  -- triangles writes the two unchanged face labels and face anchors, then+  -- needlessly redirects the two new diagonal endpoints even though each+  -- already owns another live outgoing edge. The local quadrilateral proof+  -- above names every changed adjacency, so the minimal section is exact.+  topologyWriteOrigin topology edge c+  topologyWriteOrigin topology twin d+  topologyWriteNext topology edgeNext edge+  topologyWritePrevious topology edgeNext twinPrevious+  topologyWriteNext topology edge twinPrevious+  topologyWritePrevious topology edge edgeNext+  topologyWriteNext topology twinPrevious edgeNext+  topologyWritePrevious topology twinPrevious edge+  topologyWriteFace topology twinPrevious leftFace+  topologyWriteFaceEdge topology leftFace edge+  topologyWriteNext topology twinNext twin+  topologyWritePrevious topology twinNext edgePrevious+  topologyWriteNext topology twin edgePrevious+  topologyWritePrevious topology twin twinNext+  topologyWriteNext topology edgePrevious twinNext+  topologyWritePrevious topology edgePrevious twin+  topologyWriteFace topology edgePrevious rightFace+  topologyWriteFaceEdge topology rightFace twin   -- 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.@@ -83,8 +102,6 @@     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+  topologyWriteVertexOut topology a twinNext+  topologyWriteVertexOut topology b edgeNext {-# INLINE applyFlip #-}
src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRule.hs view
@@ -31,9 +31,10 @@ -- 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+-- Both interpreters reach the same incircle rule with different eligibility+-- proofs. 'ValidMesh' arrives from two consistently oriented incident faces;+-- 'CavityRepair' restricts firing to the new fan through its floor witness.+-- The drain reaches this with the quadrilateral already in hand; the firing -- condition itself has one owner. diagonalFires   :: LegalizationLaw@@ -41,10 +42,13 @@   -> 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+    -- A valid triangulation already proves the two incident triangles are+    -- consistently oriented. If their union is concave, the opposite apex is+    -- outside the first triangle's circumcircle and the in-circle rule refuses+    -- the flip; re-running two exact orientation predicates merely re-proves+    -- that premise for every candidate. This is the same lawful section used+    -- by Spade's removal legalizer: the diagonal rule alone decides.+    ValidMesh -> illegalDiagonal ax ay bx by cx cy dx dy     CavityRepair _ -> illegalDiagonal ax ay bx by cx cy dx dy {-# INLINE diagonalFires #-} @@ -106,9 +110,9 @@ -- 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.+-- non-convex quadrilateral's diagonal is necessarily locally Delaunay, so the+-- incircle rule itself declines the flip; separately re-running two exact+-- orientation predicates would only re-prove the incident-face premise. -- -- 'CavityRepair' legalizes the fan that fills a removed vertex's hole, which is -- not yet a triangulation. That implication fails on an inverted quadrilateral,
src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Hull.hs view
@@ -4,39 +4,71 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fllvm -optlo-O3 -optlc-O3 #-}  -- | Growth outside the hull: visible ranges, turn closure, and convexity repair. module Moonlight.Triangulation.Internal.DcelOperations.Hull-  ( insertOutsideHull-  , insertOutsideHullBetween+  ( ReservedSweepCells+  , SweepCellCursor+  , SweepInsertion (..)+  , reserveSweepCells+  , initialSweepCellCursor+  , commitReservedSweepConnections+  , insertOutsideHull+  , insertOutsideHullAtEdge   , closeOuterTurn+  , closeOuterTurnReserved   , fixHullConvexity   ) where -import Control.Monad (forM_)+import Control.Monad (forM_, when) import Control.Monad.ST (ST) import Data.STRef (writeSTRef) import Moonlight.Triangulation.Handles.HandleDefs (DirectedEdgeId (..), FaceId (..)) import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena-  ( noStarVertex-  , seedGenericEdges+  ( seedGenericPairInArena   )-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.Legalize+  ( legalizeScratch+  , legalizeDenseStarEdgeInArena+  )+import Moonlight.Triangulation.Internal.DcelOperations.Normalize+  ( LegalizationDrain (..)+  , drainDenseUnconstrainedGenericLegalization+  ) import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex) import Moonlight.Triangulation.Internal.Mutable-  ( MutableDcel (..)+  ( DenseMutableDcel+  , MutableDcel (..)   , addEdge   , addEdgeBlock   , addFaceBlock   , directedEdgeCount+  , denseCommitFreshConnections+  , denseInitializeUnconstrainedEdgeBlock+  , denseLinkEdges+  , denseMarkFreshConnected+  , denseMutableOwner+  , denseReadFace+  , denseReadFaceEdge+  , denseReadNext+  , denseReadOrigin+  , denseReadPointX+  , denseReadPointY+  , denseReadPrevious+  , denseSetCycle3+  , denseWriteFace+  , denseWriteFaceEdge+  , denseWriteNext+  , denseWriteOrigin+  , denseWritePrevious+  , denseWriteVertexOut   , ensureCellCapacity+  , faceCount   , linkEdges   , markConnected   , pointAt   , readFace-  , readFaceEdge   , readNext   , readOrigin   , readPointX@@ -45,11 +77,14 @@   , setCycle3   , writeFace   , writeFaceEdge+  , writeNext   , writeOrigin+  , writePrevious   , writeVertexOut   ) import Moonlight.Triangulation.Internal.OperationState   ( Counter (..)+  , LegalizationArena   , OperationState   , addCounter   , readScratch@@ -59,6 +94,74 @@ import Moonlight.Triangulation.Types (BuildError (..), Point (..)) import Moonlight.Triangulation.Scalar (orient2dCoordinates) +-- | Proof that the remaining circle-sweep program fits the particular mutable+-- arena carried here. The constructor is private: only 'reserveSweepCells' can+-- pair a DCEL with the one-time capacity check. Carrying the DCEL inside the+-- witness prevents a proof for one mutable mesh from being applied to another+-- mesh that happens to share the same @ST@ region.+data ReservedSweepCells s vertex directed undirected face = ReservedSweepCells+  !(DenseMutableDcel s vertex directed undirected face)+  {-# UNPACK #-} !SweepCellCursor++-- | The uncommitted directed-edge and face cardinalities of one reserved+-- sweep section. Its constructor is private: only the reservation can mint the+-- initial cursor, and only reserved topology rewrites can advance it.+data SweepCellCursor = SweepCellCursor+  {-# UNPACK #-} !Int+  {-# UNPACK #-} !Int++-- | The outer edges glued by one direct sweep insertion and the normalization+-- work discharged while its star still existed. The sweep accumulates these+-- strict metrics and charges the operation counters once, instead of mutating+-- diagnostic cells once per point.+data SweepInsertion s+  = SweepInsertionFailure !BuildError+  | SweepInsertion+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+      !(LegalizationArena s)+      {-# UNPACK #-} !SweepCellCursor++-- | Discharge the monotone circle-sweep allocation budget once. Every+-- remaining point can contribute at most three undirected edges and two faces+-- to a planar triangulation. The seed already occupies its own cells, so this+-- bound is stated only over the points the sweep has not connected yet.+reserveSweepCells+  :: DenseMutableDcel s vertex directed undirected face+  -> Int+  -> ST s (Either BuildError (ReservedSweepCells s vertex directed undirected face))+reserveSweepCells dense remainingPoints = do+  let !mutable = denseMutableOwner dense+  halfEdges <- directedEdgeCount mutable+  faces <- faceCount mutable+  capacity <- ensureCellCapacity mutable (3 * remainingPoints) (2 * remainingPoints)+  pure (ReservedSweepCells dense (SweepCellCursor halfEdges faces) <$ capacity)++initialSweepCellCursor+  :: ReservedSweepCells s vertex directed undirected face+  -> SweepCellCursor+initialSweepCellCursor (ReservedSweepCells _ cursor) = cursor+{-# INLINE initialSweepCellCursor #-}++-- | Commit the cardinality of the fresh connectivity sections materialized by+-- direct sweep insertions. Their per-vertex bits and outgoing edges are already+-- present; this is the one global descent step before any skipped point enters+-- the ordinary insertion interpreter.+commitReservedSweepConnections+  :: ReservedSweepCells s vertex directed undirected face+  -> SweepCellCursor+  -> Int+  -> ST s ()+commitReservedSweepConnections (ReservedSweepCells dense _) (SweepCellCursor halfEdges faces) inserted = do+  denseCommitFreshConnections dense inserted+  let !MutableDcel{mdHalfCount, mdFaceCount, mdLastFace} = denseMutableOwner dense+  writeSTRef mdHalfCount halfEdges+  writeSTRef mdFaceCount faces+  when (inserted > 0 && faces > 1) (writeSTRef mdLastFace (faces - 1))+{-# INLINE commitReservedSweepConnections #-}+ 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@@ -102,24 +205,67 @@             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+-- | Replace one selected outer edge @a->b@ by @a->v, v->b@ and materialize+-- the covered triangle. This is the circle sweep's actual local section: the+-- ordinary outside-hull path continues to own arbitrary visible ranges, while+-- the sweep no longer collects a singleton range into shared scratch merely to+-- rediscover its first and last edge.+insertOutsideHullAtEdge+  :: ReservedSweepCells s vertex directed undirected face+  -> SweepCellCursor+  -> LegalizationArena 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+  -> Int+  -> ST s (SweepInsertion s)+insertOutsideHullAtEdge (ReservedSweepCells dense _) (SweepCellCursor nextHalf nextFace) arena outerEdge from to vertex = do+  incident <- denseReadFace dense outerEdge+  if incident /= 0+    then+      pure+        ( SweepInsertionFailure+            ( OuterRangeContainsInnerEdge+                (DirectedEdgeId (fromIntegral outerEdge))+                (FaceId (fromIntegral incident))+            )+        )+    else do+      oldPrevious <- denseReadPrevious dense outerEdge+      oldNext <- denseReadNext dense outerEdge+      denseInitializeUnconstrainedEdgeBlock dense nextHalf 2+      let !edgeBase = nextHalf+          !face = nextFace+          !firstOuterSpoke = edgeBase+          !firstInnerSpoke = edgeBase + 1+          !secondInnerSpoke = edgeBase + 2+          !lastOuterSpoke = edgeBase + 3+      denseWriteOrigin dense firstOuterSpoke from+      denseWriteOrigin dense firstInnerSpoke vertex+      denseWriteOrigin dense secondInnerSpoke to+      denseWriteOrigin dense lastOuterSpoke vertex+      denseSetCycle3 dense face outerEdge secondInnerSpoke firstInnerSpoke+      denseWriteFace dense firstOuterSpoke 0+      denseWriteFace dense lastOuterSpoke 0+      denseLinkEdges dense oldPrevious firstOuterSpoke+      denseLinkEdges dense firstOuterSpoke lastOuterSpoke+      denseLinkEdges dense lastOuterSpoke oldNext+      denseWriteFaceEdge dense 0 firstOuterSpoke+      denseWriteVertexOut dense from outerEdge+      denseWriteVertexOut dense to secondInnerSpoke+      denseMarkFreshConnected dense vertex lastOuterSpoke+      LegalizationDrain flips maxDepth () finalArena <-+        legalizeDenseStarEdgeInArena dense arena vertex outerEdge+      pure+        ( SweepInsertion+            firstOuterSpoke+            lastOuterSpoke+            flips+            maxDepth+            finalArena+            (SweepCellCursor (nextHalf + 4) (nextFace + 1))+        )+{-# INLINE insertOutsideHullAtEdge #-}  collectOuterChain   :: MutableDcel s vertex directed undirected face@@ -228,24 +374,94 @@   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)+    Right () -> Right <$> closeOuterTurnWithCapacity mutable first {-# INLINE closeOuterTurn #-} +-- | The circle-sweep form of 'closeOuterTurn'. Its capacity obstruction was+-- discharged by 'reserveSweepCells'; topology mutation is otherwise identical+-- to the checked public-internal operation used by joins.+closeOuterTurnReserved+  :: ReservedSweepCells s vertex directed undirected face+  -> SweepCellCursor+  -> Int+  -> ST s (Int, SweepCellCursor)+closeOuterTurnReserved+  (ReservedSweepCells dense _)+  (SweepCellCursor nextHalf nextFace)+  first = do+    denseInitializeUnconstrainedEdgeBlock dense nextHalf 1+    replacement <- closeOuterTurnDenseAt dense nextHalf nextFace first+    pure (replacement, SweepCellCursor (nextHalf + 2) (nextFace + 1))+{-# INLINE closeOuterTurnReserved #-}++-- | Materialize one turn closure at cells already owned by the caller's+-- allocation section. Ordinary edits obtain those cells from the checked+-- allocator; the reserved sweep obtains them from its immutable cursor.+closeOuterTurnDenseAt+  :: DenseMutableDcel s vertex directed undirected face+  -> Int+  -> Int+  -> Int+  -> ST s Int+closeOuterTurnDenseAt dense edgeBase newFace first = do+  second <- denseReadNext dense first+  oldPrevious <- denseReadPrevious dense first+  oldNext <- denseReadNext dense second+  from <- denseReadOrigin dense first+  to <- denseReadOrigin dense (reverseIndex second)+  let !outer = edgeBase+      !inner = edgeBase + 1+  denseWriteOrigin dense outer from+  denseWriteOrigin dense inner to+  denseWriteFace dense outer 0+  -- @first -> second@ is the authoritative outer adjacency that licensed this+  -- closure. Preserve those two already-correct cells and write only the six+  -- changed links plus the new face section.+  denseWriteNext dense second inner+  denseWritePrevious dense inner second+  denseWriteNext dense inner first+  denseWritePrevious dense first inner+  denseWriteFace dense first newFace+  denseWriteFace dense second newFace+  denseWriteFace dense inner newFace+  denseWriteFaceEdge dense newFace first+  denseLinkEdges dense oldPrevious outer+  denseLinkEdges dense outer oldNext+  denseWriteFaceEdge dense 0 outer+  denseWriteVertexOut dense from outer+  denseWriteVertexOut dense to inner+  pure outer+{-# INLINE closeOuterTurnDenseAt #-}++closeOuterTurnWithCapacity+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> ST s Int+closeOuterTurnWithCapacity mutable first = 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+  writeNext mutable second inner+  writePrevious mutable inner second+  writeNext mutable inner first+  writePrevious mutable first inner+  writeFace mutable first newFace+  writeFace mutable second newFace+  writeFace mutable inner newFace+  writeFaceEdge mutable newFace first+  linkEdges mutable oldPrevious outer+  linkEdges mutable outer oldNext+  writeFaceEdge mutable 0 outer+  writeVertexOut mutable from outer+  writeVertexOut mutable to inner+  pure outer+{-# INLINE closeOuterTurnWithCapacity #-}+ -- | 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@@ -255,25 +471,25 @@ -- 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+  :: ReservedSweepCells s vertex directed undirected face+  -> SweepCellCursor   -> OperationState s-  -> ST s (Either BuildError (Int, Int, Int))-fixHullConvexity mutable operation = do-  start <- readFaceEdge mutable 0+  -> LegalizationArena s+  -> ST s (Either BuildError (Int, Int, Int, LegalizationArena s, SweepCellCursor))+fixHullConvexity reserved@(ReservedSweepCells dense _) initialCursor operation initialArena = do+  start <- denseReadFaceEdge dense 0   if start < 0-    then pure (Right (0, 0, 0))+    then pure (Right (0, 0, 0, initialArena, initialCursor))     else do-      walked <- walk start start 0 0 0 0+      walked <- walk start start 0 0 0 0 initialArena initialCursor       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))+        Right (top, closures, seededArena, finalCursor) -> do+          LegalizationDrain flips maxDepth () finalArena <-+            drainDenseUnconstrainedGenericLegalization dense seededArena top+          pure (Right (closures, flips, maxDepth, finalArena, finalCursor))  where-  walk !start !current !stackSize !steps !top !closures = do-    halfEdges <- directedEdgeCount mutable+  walk !start !current !stackSize !steps !top !closures !arena cursor@(SweepCellCursor halfEdges _) = do     if steps > halfEdges + 2       then         pure@@ -285,44 +501,41 @@               )           )       else do-        following <- readNext mutable current+        following <- denseReadNext dense current         writeScratch operation stackSize current-        reduction <- reduce (stackSize + 1) top closures+        reduction <- reduce (stackSize + 1) top closures arena cursor         case reduction of           Left obstruction -> pure (Left obstruction)-          Right (reduced, nextTop, nextClosures) -> do+          Right (reduced, nextTop, nextClosures, nextArena, nextCursor) -> 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+              then pure (Right (nextTop, nextClosures, nextArena, nextCursor))+              else walk start following reduced (steps + 1) nextTop nextClosures nextArena nextCursor -  reduce !count !top !closures-    | count < 2 = pure (Right (count, top, closures))+  reduce !count !top !closures !arena !cursor+    | count < 2 = pure (Right (count, top, closures, arena, cursor))     | 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+        fromVertex <- denseReadOrigin dense first+        middleVertex <- denseReadOrigin dense (reverseIndex first)+        targetVertex <- denseReadOrigin dense (reverseIndex second)+        fromX <- denseReadPointX dense fromVertex+        fromY <- denseReadPointY dense fromVertex+        middleX <- denseReadPointX dense middleVertex+        middleY <- denseReadPointY dense middleVertex+        targetX <- denseReadPointX dense targetVertex+        targetY <- denseReadPointY dense 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))+            (replacement, nextCursor) <- closeOuterTurnReserved reserved cursor first+            writeScratch operation (count - 2) replacement+            (nextArena, nextTop) <- seedGenericPairInArena arena top first second+            reduce (count - 1) nextTop (closures + 1) nextArena nextCursor+          else pure (Right (count, top, closures, arena, cursor))  visibleOuter :: MutableDcel s vertex directed undirected face -> Int -> Point -> ST s Bool visibleOuter mutable edge query = do
src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Legalize.hs view
@@ -4,10 +4,13 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fllvm -optlo-O3 -optlc-O3 #-}  -- | The seeding entry points that drive one legalization epoch. module Moonlight.Triangulation.Internal.DcelOperations.Legalize   ( legalizeScratch+  , legalizeStarEdge+  , legalizeDenseStarEdgeInArena   , legalizeEdges   , legalizeCavityFanScratch   ) where@@ -17,17 +20,25 @@ import Data.Foldable (traverse_) import qualified Data.Vector.Unboxed.Mutable as MUV import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena-  ( genericCandidate+  ( CandidateDiscipline (..)   , 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.DcelOperations.Normalize+  ( LegalizationDrain+  , drainDenseUnconstrainedStarLegalization+  , drainLegalization+  )+import Moonlight.Triangulation.Internal.Mutable+  ( DenseMutableDcel+  , MutableDcel+  , MutableTopology+  ) import Moonlight.Triangulation.Internal.OperationState   ( Counter (..)+  , LegalizationArena (..)   , OperationState   , addCounter   , legalizationArena@@ -41,7 +52,7 @@ 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+  (flips, maxDepth) <- drainLegalization @'ProbeOff mutable operation top GenericCandidates ValidMesh   addCounter operation CounterEdgeFlips flips   maxCounter operation CounterLegalizationMaxStack maxDepth @@ -64,11 +75,12 @@ legalizeCavityFanScratch mutable operation cavityFloor scratchOffset candidateCount = do   initialArena <- legalizationArena operation   arena <- growLegalizationArena initialArena candidateCount-  when (MUV.length arena /= MUV.length initialArena) (storeLegalizationArena operation arena)+  when (legalizationArenaLength arena /= legalizationArenaLength initialArena) (storeLegalizationArena operation arena)+  let LegalizationArena values = arena   traverse_     (\index -> do        edge <- readScratch operation (scratchOffset + index)-       MUV.unsafeWrite arena index (packIndex (genericCandidate edge))+       MUV.unsafeWrite values index (packIndex edge)     )     [0 .. candidateCount - 1]   (flips, maxDepth) <-@@ -77,7 +89,7 @@       mutable       operation       candidateCount-      noStarVertex+      GenericCandidates       (CavityRepair cavityFloor)   addCounter operation CounterEdgeFlips flips   maxCounter operation CounterLegalizationMaxStack maxDepth@@ -85,6 +97,44 @@ 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+  (flips, maxDepth) <- drainLegalization @p mutable operation top (StarCandidates vertex) ValidMesh   addCounter operation CounterEdgeFlips flips   maxCounter operation CounterLegalizationMaxStack maxDepth++-- | Normalize one newly covered outer edge against the inserted star vertex.+-- The circle sweep always covers exactly one edge; routing that singleton+-- through the shared scratch section merely materializes a one-element range+-- before immediately copying it into this arena. This is the same star-law+-- section written at its actual arity.+legalizeStarEdge+  :: forall p mutable s vertex directed undirected face+   . (KnownProbe p, MutableTopology mutable)+  => mutable s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> ST s (Int, Int)+legalizeStarEdge mutable operation vertex edge = do+  arena <- legalizationArena operation+  let LegalizationArena values = arena+  MUV.unsafeWrite values 0 (packIndex edge)+  drainLegalization @p mutable operation 1 (StarCandidates vertex) ValidMesh+{-# INLINE legalizeStarEdge #-}++-- | The monomorphic fresh-build interpreter for the singleton star epoch,+-- consuming and returning the sweep's borrowed candidate section.+legalizeDenseStarEdgeInArena+  :: DenseMutableDcel s vertex directed undirected face+  -> LegalizationArena s+  -> Int+  -> Int+  -> ST s (LegalizationDrain s ())+legalizeDenseStarEdgeInArena dense arena vertex edge = do+  let LegalizationArena values = arena+  MUV.unsafeWrite values 0 (packIndex edge)+  drainDenseUnconstrainedStarLegalization dense arena 1 vertex+{-# NOINLINE legalizeDenseStarEdgeInArena #-}++legalizationArenaLength :: LegalizationArena s -> Int+legalizationArenaLength (LegalizationArena values) = MUV.length values+{-# INLINE legalizationArenaLength #-}
src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Normalize.hs view
@@ -4,47 +4,62 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fllvm -optlo-O3 -optlc-O3 #-}  -- | The normalization procedure of the flip rewrite system. module Moonlight.Triangulation.Internal.DcelOperations.Normalize   ( drainLegalization+  , LegalizationDrain (..)+  , drainDenseUnconstrainedStarLegalization+  , drainDenseUnconstrainedGenericLegalization   ) where  import Control.Monad (when) import Control.Monad.ST (ST)-import Data.Bits ((.&.), shiftR)+import Data.Bits (shiftR) import Data.STRef (readSTRef) import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32) import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena-  ( genericCandidate+  ( CandidateDiscipline (..)   , growLegalizationArena-  , starCandidate   ) import Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite (applyFlip) import Moonlight.Triangulation.Internal.DcelOperations.FlipRule   ( LegalizationLaw (..)   , diagonalFires+  , illegalDiagonal   ) import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex) import Moonlight.Triangulation.Internal.Mutable-  ( MutableDcel (..)-  , readConstraint-  , readFace-  , readNext-  , readOrigin-  , readPointX-  , readPointY-  , readPrevious+  ( DenseMutableDcel+  , MutableDcel (..)+  , MutableTopology (..)   ) import Moonlight.Triangulation.Internal.OperationState   ( Counter (..)+  , LegalizationArena (..)   , OperationState   , legalizationArena   , storeLegalizationArena   ) import Moonlight.Triangulation.Internal.PackedIndex (packIndex)-import Moonlight.Triangulation.Internal.Probe (KnownProbe (..))+import Moonlight.Triangulation.Internal.Probe+  ( KnownProbe (..)+  , Probe (..)+  , ProbeCounter+  ) +-- | The authoritative result of one normalization section. The arena is part+-- of the result because an adversarial frontier may grow it; callers that+-- borrow the section for several local rewrites can therefore compose those+-- rewrites without bouncing through the operation's reference between them.+data LegalizationDrain s counter = LegalizationDrain+  {-# UNPACK #-} !Int+  {-# UNPACK #-} !Int+  !counter+  !(LegalizationArena s)+ -- | The normalization procedure of a confluent terminating rewrite system, and -- one canonical legalization engine because a normalization procedure is what -- it is.@@ -85,27 +100,51 @@ -- 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+  :: forall p mutable s vertex directed undirected face+   . (KnownProbe p, MutableTopology mutable)+  => mutable s vertex directed undirected face   -> OperationState s   -> Int-  -> Int+  -> CandidateDiscipline   -> LegalizationLaw   -> ST s (Int, Int)-drainLegalization mutable operation seededTop starVertex law = do+drainLegalization topology operation seededTop discipline law = do+  let !mutable = topologyOwner topology   -- 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+  LegalizationDrain flips maxTop candidates finalArena <-+    drainLegalizationInArena+      @p+      topology+      initialArena+      (constrained /= 0)+      seededTop+      discipline+      law+  when (legalizationArenaLength finalArena /= legalizationArenaLength initialArena) $+    storeLegalizationArena operation finalArena+  probeCharge @p operation CounterDiagLegalizationCandidates candidates+  pure (flips, maxTop)+{-# INLINE drainLegalization #-}++-- | Interpret the single normalization law in an explicitly borrowed arena.+-- The boolean is the already-established constraint obstruction: a fresh+-- unconstrained build passes 'False', while the general entry derives it once+-- from the mutable owner above.+drainLegalizationInArena+  :: forall p mutable s vertex directed undirected face+   . (KnownProbe p, MutableTopology mutable)+  => mutable s vertex directed undirected face+  -> LegalizationArena s+  -> Bool+  -> Int+  -> CandidateDiscipline+  -> LegalizationLaw+  -> ST s (LegalizationDrain s (ProbeCounter p))+drainLegalizationInArena topology (LegalizationArena initialArena) guarded seededTop discipline law = do+  let -- 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@@ -114,109 +153,201 @@         ValidMesh -> 0         CavityRepair floorEdge -> floorEdge -      loop !arena !top !maxTop !flips !candidates+      eligible rawEdge+        | rawEdge `shiftR` 1 < floorPair = pure False+        | guarded = not <$> topologyReadConstraint topology rawEdge+        | otherwise = pure True++      loopStar !starVertex !starX !starY !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)+            let !rawEdge = fromIntegral packedWord :: Int+            mayFire <- eligible rawEdge+            if not mayFire+              then loopStar starVertex starX starY arena nextTop maxTop flips (probeBump @p candidates)               else do                 let !rawTwin = reverseIndex rawEdge-                rawFace <- readFace mutable rawEdge-                rawTwinFace <- readFace mutable rawTwin+                rawFace <- topologyReadFace topology rawEdge+                rawTwinFace <- topologyReadFace topology rawTwin                 if rawFace == 0 || rawTwinFace == 0-                  then loop arena nextTop maxTop flips (probeBump @p candidates)+                  then loopStar starVertex starX starY 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)+                    rawBefore <- topologyReadPrevious topology rawEdge+                    rawTwinBefore <- topologyReadPrevious topology rawTwin+                    rawTwinApex <- topologyReadOrigin topology rawTwinBefore+                    a <- topologyReadOrigin topology rawEdge+                    b <- topologyReadOrigin topology rawTwin+                    ax <- topologyReadPointX topology a+                    ay <- topologyReadPointY topology a+                    bx <- topologyReadPointX topology b+                    by <- topologyReadPointY topology b+                    dx <- topologyReadPointX topology rawTwinApex+                    dy <- topologyReadPointY topology rawTwinApex+                    -- A star candidate is oriented against the inserted apex,+                    -- exactly the premise used by the ordinary insertion+                    -- legalizer. The two convexity predicates in the generic+                    -- valid-mesh law merely re-prove that premise for every+                    -- pop; the in-circle rule alone owns this section.+                    if not (illegalDiagonal ax ay bx by starX starY dx dy)+                      then loopStar starVertex starX starY 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 #-}+                        -- Star seeding is directional: the inserted vertex is+                        -- the previous-origin apex of every candidate. A flip+                        -- preserves that proof for precisely these two+                        -- directed neighbours, so neither an undirected tag nor+                        -- a rediscovery read belongs in this epoch.+                        rawNext <- topologyReadNext topology rawEdge+                        rawTwinNext <- topologyReadNext topology rawTwin+                        applyFlip+                          topology+                          rawEdge+                          rawTwin+                          rawNext+                          rawBefore+                          rawTwinNext+                          rawTwinBefore+                          rawFace+                          rawTwinFace+                          a+                          b+                          starVertex+                          rawTwinApex+                        let !addedTop = nextTop + 2+                        grown <- growValues arena addedTop+                        MUV.unsafeWrite grown nextTop (packIndex rawTwinBefore)+                        MUV.unsafeWrite grown (nextTop + 1) (packIndex rawTwinNext)+                        loopStar+                          starVertex+                          starX+                          starY+                          grown+                          addedTop+                          (max maxTop addedTop)+                          (flips + 1)+                          (probeBump @p candidates)++      loopGeneric !arena !top !maxTop !flips !candidates+        | top <= 0 = pure (flips, maxTop, candidates, arena)+        | otherwise = do+            let !nextTop = top - 1+            packedWord <- MUV.unsafeRead arena nextTop+            let !edge = fromIntegral packedWord :: Int+            mayFire <- eligible edge+            if not mayFire+              then loopGeneric arena nextTop maxTop flips (probeBump @p candidates)+              else do+                let !twin = reverseIndex edge+                leftFace <- topologyReadFace topology edge+                rightFace <- topologyReadFace topology twin+                if leftFace == 0 || rightFace == 0+                  then loopGeneric arena nextTop maxTop flips (probeBump @p candidates)+                  else do+                    edgePrevious <- topologyReadPrevious topology edge+                    twinPrevious <- topologyReadPrevious topology twin+                    c <- topologyReadOrigin topology edgePrevious+                    d <- topologyReadOrigin topology twinPrevious+                    a <- topologyReadOrigin topology edge+                    b <- topologyReadOrigin topology twin+                    ax <- topologyReadPointX topology a+                    ay <- topologyReadPointY topology a+                    bx <- topologyReadPointX topology b+                    by <- topologyReadPointY topology b+                    cx <- topologyReadPointX topology c+                    cy <- topologyReadPointY topology c+                    dx <- topologyReadPointX topology d+                    dy <- topologyReadPointY topology d+                    if not (diagonalFires law ax ay bx by cx cy dx dy)+                      then loopGeneric arena nextTop maxTop flips (probeBump @p candidates)+                      else do+                        edgeNext <- topologyReadNext topology edge+                        twinNext <- topologyReadNext topology twin+                        applyFlip+                          topology+                          edge+                          twin+                          edgeNext+                          edgePrevious+                          twinNext+                          twinPrevious+                          leftFace+                          rightFace+                          a+                          b+                          c+                          d+                        let !addedTop = nextTop + 4+                        grown <- growValues arena addedTop+                        MUV.unsafeWrite grown nextTop (packIndex edgeNext)+                        MUV.unsafeWrite grown (nextTop + 1) (packIndex edgePrevious)+                        MUV.unsafeWrite grown (nextTop + 2) (packIndex twinNext)+                        MUV.unsafeWrite grown (nextTop + 3) (packIndex twinPrevious)+                        loopGeneric+                          grown+                          addedTop+                          (max maxTop addedTop)+                          (flips + 1)+                          (probeBump @p candidates)+  drained <-+    case discipline of+      StarCandidates starVertex -> do+        starX <- topologyReadPointX topology starVertex+        starY <- topologyReadPointY topology starVertex+        loopStar starVertex starX starY initialArena seededTop seededTop 0 (probeZero @p)+      GenericCandidates ->+        loopGeneric initialArena seededTop seededTop 0 (probeZero @p)+  let (!flips, !maxTop, !candidates, !finalArena) = drained+  pure (LegalizationDrain flips maxTop candidates (LegalizationArena finalArena))+ where+  growValues :: MUV.MVector s Word32 -> Int -> ST s (MUV.MVector s Word32)+  growValues values required = do+    LegalizationArena grown <-+      growLegalizationArena (LegalizationArena values) required+    pure grown+{-# INLINE drainLegalizationInArena #-}++-- | The dense, fresh-build interpreter for a star epoch. Fresh construction+-- proves the absence of constrained edges; the borrowed arena is returned so+-- the surrounding sweep can glue several epochs before restoring operation+-- ownership.+drainDenseUnconstrainedStarLegalization+  :: DenseMutableDcel s vertex directed undirected face+  -> LegalizationArena s+  -> Int+  -> Int+  -> ST s (LegalizationDrain s ())+drainDenseUnconstrainedStarLegalization dense arena top starVertex =+  drainLegalizationInArena+    @'ProbeOff+    dense+    arena+    False+    top+    (StarCandidates starVertex)+    ValidMesh+{-# INLINE drainDenseUnconstrainedStarLegalization #-}++-- | The matching dense interpreter for a generic legalization epoch. Keeping+-- both monomorphic boundaries out of the circle-sweep worker prevents the+-- normalizer and flip rewrite from being copied into every insertion+-- continuation; both still descend through 'drainLegalizationInArena'.+drainDenseUnconstrainedGenericLegalization+  :: DenseMutableDcel s vertex directed undirected face+  -> LegalizationArena s+  -> Int+  -> ST s (LegalizationDrain s ())+drainDenseUnconstrainedGenericLegalization dense arena top =+  drainLegalizationInArena+    @'ProbeOff+    dense+    arena+    False+    top+    GenericCandidates+    ValidMesh+{-# INLINE drainDenseUnconstrainedGenericLegalization #-}++legalizationArenaLength :: LegalizationArena s -> Int+legalizationArenaLength (LegalizationArena values) = MUV.length values+{-# INLINE legalizationArenaLength #-}
+ src-dcel/Moonlight/Triangulation/Internal/ExactSegmentEvents.hs view
@@ -0,0 +1,889 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | One exact owner for non-disjoint relations and split points in a finite+-- segment family. Collinear intervals descend by supporting-line sections;+-- non-collinear intersections descend through an immutable Bentley--Ottmann+-- status tree. Callers attach provenance only after this geometry glues.+module Moonlight.Triangulation.Internal.ExactSegmentEvents+  ( ExactSweepSegmentId (..)+  , ExactSegmentEvent (..)+  , ExactSegmentEventObstruction (..)+  , ExactSegmentEventPlan+  , exactSegmentEventPlan+  , exactSegmentEvents+  , exactSegmentSplitPoints+  , exactSegmentRelationMap+  , exactSegmentPairChecks+  , exactSegmentSweepMaximumHeight+  ) where++import Control.DeepSeq (NFData)+import Control.Applicative ((<|>))+import Control.Monad (filterM, foldM)+import Data.List (sortBy)+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Vector as V+import GHC.Generics (Generic)+import Moonlight.Triangulation.Exact+  ( ExactIntersectionError+  , ExactPoint+  , ExactSegment+  , SegmentRelation (..)+  , exactOnClosedSegment+  , exactPointCoordinates+  , exactSegmentEndpoints+  , exactSegmentRelation+  , exactSupportingLineIntersection+  )+import Moonlight.Triangulation.Internal.BoundaryCycle+  ( orderedPair+  , unorderedPairs+  )+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactRational+  , exactRationalDenominator+  , exactRationalNumerator+  )++newtype ExactSweepSegmentId = ExactSweepSegmentId Int+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data ExactSegmentEvent+  = ExactProperCrossing !ExactSweepSegmentId !ExactSweepSegmentId !ExactPoint+  | ExactEndpointTouch !ExactSweepSegmentId !ExactSweepSegmentId !ExactPoint+  | ExactSharedEndpoint !ExactSweepSegmentId !ExactSweepSegmentId !ExactPoint+  | ExactDuplicateSegments !ExactSweepSegmentId !ExactSweepSegmentId+  | ExactCollinearOverlap+      !ExactSweepSegmentId+      !ExactSweepSegmentId+      !ExactPoint+      !ExactPoint+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data ExactSegmentEventObstruction+  = ExactSweepIntersectionObstruction+      !ExactSweepSegmentId+      !ExactSweepSegmentId+      !ExactIntersectionError+  | ExactSweepRelationWitnessMissing+      !ExactSweepSegmentId+      !ExactSweepSegmentId+      !SegmentRelation+  | ExactSweepSegmentMissing !ExactSweepSegmentId+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++data ExactSegmentEventPlan = ExactSegmentEventPlan+  { plannedEvents :: !(Map (ExactSweepSegmentId, ExactSweepSegmentId) ExactSegmentEvent)+  , plannedSplitPoints :: !(V.Vector [ExactPoint])+  , plannedPairChecks :: !Int+  , plannedMaximumHeight :: !Int+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++data SegmentMeta = SegmentMeta+  { metaId :: !ExactSweepSegmentId+  , metaSegment :: !ExactSegment+  , metaLow :: !ExactPoint+  , metaHigh :: !ExactPoint+  , metaVertical :: !Bool+  }++data SupportingLine = SupportingLine !Integer !Integer !Integer+  deriving stock (Eq, Ord, Show)++data EventBundle = EventBundle+  { eventStarts :: !(Set ExactSweepSegmentId)+  , eventEnds :: !(Set ExactSweepSegmentId)+  , eventScheduled :: !(Set (ExactSweepSegmentId, ExactSweepSegmentId))+  }++emptyEventBundle :: EventBundle+emptyEventBundle = EventBundle Set.empty Set.empty Set.empty++mergeEventBundle :: EventBundle -> EventBundle -> EventBundle+mergeEventBundle left right =+  EventBundle+    { eventStarts = eventStarts left <> eventStarts right+    , eventEnds = eventEnds left <> eventEnds right+    , eventScheduled = eventScheduled left <> eventScheduled right+    }++data EventAccumulation = EventAccumulation+  { accumulatedEvents :: !(Map (ExactSweepSegmentId, ExactSweepSegmentId) ExactSegmentEvent)+  , accumulatedSplits :: !(IntMap.IntMap (Set ExactPoint))+  , accumulatedPairChecks :: !Int+  , accumulatedMaximumHeight :: !Int+  }++data StatusTree+  = StatusEmpty+  | StatusNode !Int !StatusTree !SegmentMeta !StatusTree++data PointChange = PointChange+  { changedPoint :: !ExactPoint+  , changedContinuing :: !(Set ExactSweepSegmentId)+  }++data StatusSide = StatusBefore | StatusAfter+  deriving stock (Eq)++-- | Build the complete exact event plan. The private sweep reports its maximum+-- AVL height and relation checks so benchmarks can distinguish output growth+-- from residual orchestration.+exactSegmentEventPlan+  :: V.Vector ExactSegment+  -> Either ExactSegmentEventObstruction ExactSegmentEventPlan+exactSegmentEventPlan segments = do+  let metas = V.imap segmentMeta segments+      initialAccumulation =+        EventAccumulation+          { accumulatedEvents = Map.empty+          , accumulatedSplits = IntMap.empty+          , accumulatedPairChecks = 0+          , accumulatedMaximumHeight = 0+          }+  let lineGroups = supportingLineGroups metas+  afterCollinear <- foldM recordCollinearGroup initialAccumulation (Map.elems lineGroups)+  let initialQueue = V.foldl' insertEndpointEvents Map.empty metas+  completed <- sweep metas initialQueue StatusEmpty afterCollinear+  pure+    ExactSegmentEventPlan+      { plannedEvents = accumulatedEvents completed+      , plannedSplitPoints = finalizeSplitPoints segments (accumulatedSplits completed)+      , plannedPairChecks = accumulatedPairChecks completed+      , plannedMaximumHeight = accumulatedMaximumHeight completed+      }++finalizeSplitPoints+  :: V.Vector ExactSegment+  -> IntMap.IntMap (Set ExactPoint)+  -> V.Vector [ExactPoint]+finalizeSplitPoints segments splitPoints =+  V.imap+    (\index segment ->+       let (from, to) = exactSegmentEndpoints segment+           eventPoints = IntMap.findWithDefault Set.empty index splitPoints+        in sortAlong segment (Set.toList (Set.insert from (Set.insert to eventPoints))))+    segments++segmentMeta :: Int -> ExactSegment -> SegmentMeta+segmentMeta index segment =+  let (firstPoint, secondPoint) = exactSegmentEndpoints segment+      low = min firstPoint secondPoint+      high = max firstPoint secondPoint+      (lowX, _) = exactPointCoordinates low+      (highX, _) = exactPointCoordinates high+   in SegmentMeta+        { metaId = ExactSweepSegmentId index+        , metaSegment = segment+        , metaLow = low+        , metaHigh = high+        , metaVertical = lowX == highX+        }++supportingLineGroups+  :: V.Vector SegmentMeta+  -> Map SupportingLine [SegmentMeta]+supportingLineGroups =+  V.foldl'+    (\groups meta -> Map.insertWith (<>) (supportingLine meta) [meta] groups)+    Map.empty++supportingLine :: SegmentMeta -> SupportingLine+supportingLine meta =+  let (from, to) = exactSegmentEndpoints (metaSegment meta)+      (fromX, fromY) = exactPointCoordinates from+      (toX, toY) = exactPointCoordinates to+      deltaX = toX - fromX+      deltaY = toY - fromY+      a = deltaY+      b = negate deltaX+      c = deltaX * fromY - deltaY * fromX+      denominators = map exactRationalDenominator [a, b, c]+      commonDenominator = foldl' lcm 1 denominators+      integerCoefficient coefficient =+        exactRationalNumerator coefficient+          * (commonDenominator `quot` exactRationalDenominator coefficient)+      integerA = integerCoefficient a+      integerB = integerCoefficient b+      integerC = integerCoefficient c+      commonDivisor = gcd (abs integerA) (gcd (abs integerB) (abs integerC))+      sign+        | integerA < 0 = -1+        | integerA == 0 && integerB < 0 = -1+        | otherwise = 1+      normalize coefficient = sign * (coefficient `quot` commonDivisor)+   in SupportingLine (normalize integerA) (normalize integerB) (normalize integerC)++recordCollinearGroup+  :: EventAccumulation+  -> [SegmentMeta]+  -> Either ExactSegmentEventObstruction EventAccumulation+recordCollinearGroup initial metas =+  fst <$> foldM descend (initial, []) ordered+ where+  ordered = sortBy compareInterval metas+  compareInterval left right =+    compare (metaLow left, metaHigh left, metaId left) (metaLow right, metaHigh right, metaId right)+  descend (accumulation, active) current = do+    let retained = filter (\candidate -> metaHigh candidate >= metaLow current) active+    updated <-+      foldM+        (\accumulated candidate -> recordRelation accumulated candidate current)+        accumulation+        retained+    pure (updated, current : retained)++insertEndpointEvents+  :: Map ExactPoint EventBundle+  -> SegmentMeta+  -> Map ExactPoint EventBundle+insertEndpointEvents queue meta =+  insertBundle (metaHigh meta) (emptyEventBundle{eventEnds = Set.singleton (metaId meta)})+    (insertBundle (metaLow meta) (emptyEventBundle{eventStarts = Set.singleton (metaId meta)}) queue)++insertBundle+  :: ExactPoint+  -> EventBundle+  -> Map ExactPoint EventBundle+  -> Map ExactPoint EventBundle+insertBundle = Map.insertWith mergeEventBundle++sweep+  :: V.Vector SegmentMeta+  -> Map ExactPoint EventBundle+  -> StatusTree+  -> EventAccumulation+  -> Either ExactSegmentEventObstruction EventAccumulation+sweep metas queue status accumulation =+  case Map.lookupMin queue of+    Nothing -> Right accumulation+    Just (firstPoint, _) -> do+      let (currentX, _) = exactPointCoordinates firstPoint+          (batch, laterQueue) =+            Map.spanAntitone+              (\point -> fst (exactPointCoordinates point) == currentX)+              queue+          startedIds =+            Set.toAscList+              (Map.foldl' (\ids bundle -> ids <> eventStarts bundle) Set.empty batch)+      started <- traverse (requireMeta metas) startedIds+      let startingIds = map metaId (filter (not . metaVertical) started)+          verticalIds = map metaId (filter metaVertical started)+      withVerticals <-+        recordVerticalRelations+          metas+          currentX+          startingIds+          verticalIds+          status+          accumulation+      (withEvents, removals, insertions, changes) <-+        foldM+          (processPoint metas status)+          (withVerticals, Set.empty, Set.empty, [])+          (Map.toAscList batch)+      statusWithout <-+        foldM+          (deleteStatus metas StatusBefore currentX)+          status+          (Set.toAscList removals)+      statusAfter <-+        foldM+          (insertStatus metas StatusAfter currentX)+          statusWithout+          (Set.toAscList insertions)+      (scheduledQueue, scheduledAccumulation) <-+        foldM+          (scheduleAroundChange metas currentX statusAfter)+          (laterQueue, withEvents)+          changes+      let measured =+            scheduledAccumulation+              { accumulatedMaximumHeight =+                  max+                    (accumulatedMaximumHeight scheduledAccumulation)+                    (statusHeight statusAfter)+              }+      sweep metas scheduledQueue statusAfter measured++recordVerticalRelations+  :: V.Vector SegmentMeta+  -> ExactRational+  -> [ExactSweepSegmentId]+  -> [ExactSweepSegmentId]+  -> StatusTree+  -> EventAccumulation+  -> Either ExactSegmentEventObstruction EventAccumulation+recordVerticalRelations metas currentX startingIds verticalIds status accumulation = do+  temporaryStatus <-+    foldM (insertStatus metas StatusAfter currentX) status startingIds+  foldM (recordVertical temporaryStatus) accumulation verticalIds+ where+  recordVertical temporaryStatus accumulated verticalId = do+    vertical <- requireMeta metas verticalId+    let (_, lowY) = exactPointCoordinates (metaLow vertical)+        (_, highY) = exactPointCoordinates (metaHigh vertical)+        candidates = statusRangeByY currentX lowY highY temporaryStatus+    foldM+      (\current candidateId -> do+         candidate <- requireMeta metas candidateId+         recordRelation current vertical candidate)+      accumulated+      candidates++processPoint+  :: V.Vector SegmentMeta+  -> StatusTree+  -> ( EventAccumulation+     , Set ExactSweepSegmentId+     , Set ExactSweepSegmentId+     , [PointChange]+     )+  -> (ExactPoint, EventBundle)+  -> Either+      ExactSegmentEventObstruction+      ( EventAccumulation+      , Set ExactSweepSegmentId+      , Set ExactSweepSegmentId+      , [PointChange]+      )+processPoint metas status (accumulation, removals, insertions, changes) (point, bundle) = do+  let (x, y) = exactPointCoordinates point+      activeAtPoint = Set.fromList (statusAtY x y status)+      scheduledIds =+        Set.fromList+          [ segmentId+          | (leftId, rightId) <- Set.toList (eventScheduled bundle)+          , segmentId <- [leftId, rightId]+          ]+      candidates = eventStarts bundle <> eventEnds bundle <> activeAtPoint <> scheduledIds+  incident <-+    Set.fromList+      <$> filterM+        (\segmentId -> do+           meta <- requireMeta metas segmentId+           let (from, to) = exactSegmentEndpoints (metaSegment meta)+           pure (exactOnClosedSegment from to point))+        (Set.toAscList candidates)+  withRelations <- recordIncidentPairs metas accumulation incident+  metasAtPoint <- traverse (requireMeta metas) (Set.toAscList incident)+  let removable =+        Set.fromList+          [ metaId meta+          | meta <- metasAtPoint+          , not (metaVertical meta)+          , Set.member (metaId meta) activeAtPoint+              || Set.member (metaId meta) (eventEnds bundle)+          ]+      continuing =+        Set.fromList+          [ metaId meta+          | meta <- metasAtPoint+          , not (metaVertical meta)+          , fst (exactPointCoordinates (metaHigh meta)) > x+          ]+  pure+    ( withRelations+    , removals <> removable+    , insertions <> continuing+    , PointChange point continuing : changes+    )++recordIncidentPairs+  :: V.Vector SegmentMeta+  -> EventAccumulation+  -> Set ExactSweepSegmentId+  -> Either ExactSegmentEventObstruction EventAccumulation+recordIncidentPairs metas initial incident =+  foldM+    (\accumulation (leftId, rightId) -> do+       left <- requireMeta metas leftId+       right <- requireMeta metas rightId+       recordRelation accumulation left right)+    initial+    (unorderedPairs (Set.toAscList incident))++recordRelation+  :: EventAccumulation+  -> SegmentMeta+  -> SegmentMeta+  -> Either ExactSegmentEventObstruction EventAccumulation+recordRelation accumulation firstMeta secondMeta =+  let (leftMeta, rightMeta) =+        if metaId firstMeta <= metaId secondMeta+          then (firstMeta, secondMeta)+          else (secondMeta, firstMeta)+      leftId = metaId leftMeta+      rightId = metaId rightMeta+      relation = relationOf (metaSegment leftMeta) (metaSegment rightMeta)+      checked = accumulation{accumulatedPairChecks = accumulatedPairChecks accumulation + 1}+   in case relation of+        SegmentsDisjoint -> Right checked+        _ -> do+          (event, splitPoints) <-+            relationEvent leftId rightId (metaSegment leftMeta) (metaSegment rightMeta) relation+          let ExactSweepSegmentId leftIndex = leftId+              ExactSweepSegmentId rightIndex = rightId+              splitSet = Set.fromList splitPoints+              withLeft =+                IntMap.insertWith Set.union leftIndex splitSet (accumulatedSplits checked)+              withBoth = IntMap.insertWith Set.union rightIndex splitSet withLeft+          Right+            checked+              { accumulatedEvents =+                  Map.insert+                    (leftId, rightId)+                    event+                    (accumulatedEvents checked)+              , accumulatedSplits = withBoth+              }++relationOf :: ExactSegment -> ExactSegment -> SegmentRelation+relationOf left right =+  let (a, b) = exactSegmentEndpoints left+      (c, d) = exactSegmentEndpoints right+   in exactSegmentRelation a b c d++relationEvent+  :: ExactSweepSegmentId+  -> ExactSweepSegmentId+  -> ExactSegment+  -> ExactSegment+  -> SegmentRelation+  -> Either ExactSegmentEventObstruction (ExactSegmentEvent, [ExactPoint])+relationEvent leftId rightId left right relation =+  case relation of+    SegmentsDisjoint -> missing+    SegmentsDuplicate -> Right (ExactDuplicateSegments leftId rightId, [])+    SegmentsProperlyCross -> do+      crossing <-+        either+          (Left . ExactSweepIntersectionObstruction leftId rightId)+          Right+          (exactSupportingLineIntersection left right)+      Right (ExactProperCrossing leftId rightId crossing, [crossing])+    SegmentsShareEndpoint ->+      uniqueWitness (ExactSharedEndpoint leftId rightId) (uniqueShared left right)+    SegmentEndpointTouchesInterior ->+      uniqueWitness (ExactEndpointTouch leftId rightId) (uniqueTouch left right)+    SegmentsCollinearlyOverlap ->+      let lower = max (min a b) (min c d)+          upper = min (max a b) (max c d)+       in if lower < upper+            then Right (ExactCollinearOverlap leftId rightId lower upper, [lower, upper])+            else missing+ where+  (a, b) = exactSegmentEndpoints left+  (c, d) = exactSegmentEndpoints right+  uniqueWitness make witness =+    case witness of+      Just point -> Right (make point, [point])+      Nothing -> missing+  missing = Left (ExactSweepRelationWitnessMissing leftId rightId relation)++scheduleAroundChange+  :: V.Vector SegmentMeta+  -> ExactRational+  -> StatusTree+  -> (Map ExactPoint EventBundle, EventAccumulation)+  -> PointChange+  -> Either+      ExactSegmentEventObstruction+      (Map ExactPoint EventBundle, EventAccumulation)+scheduleAroundChange metas currentX status state change =+  case Set.toAscList (changedContinuing change) of+    [] ->+      let (_, y) = exactPointCoordinates (changedPoint change)+          (below, above) = statusBelowAbove currentX y status+       in scheduleMaybePair metas currentX below above state+    continuingIds -> do+      continuing <- traverse (requireMeta metas) continuingIds+      let ordered = sortBy (statusCompare StatusAfter currentX) continuing+      case ordered of+        [] -> Right state+        lowest : remaining ->+          let highest = foldl' (\_ current -> current) lowest remaining+              below = statusPredecessor currentX lowest status+              above = statusSuccessor currentX highest status+           in scheduleMaybePair metas currentX below (Just (metaId lowest)) state+                >>= scheduleMaybePair metas currentX (Just (metaId highest)) above++scheduleMaybePair+  :: V.Vector SegmentMeta+  -> ExactRational+  -> Maybe ExactSweepSegmentId+  -> Maybe ExactSweepSegmentId+  -> (Map ExactPoint EventBundle, EventAccumulation)+  -> Either+      ExactSegmentEventObstruction+      (Map ExactPoint EventBundle, EventAccumulation)+scheduleMaybePair _ _ Nothing _ state = Right state+scheduleMaybePair _ _ _ Nothing state = Right state+scheduleMaybePair metas currentX (Just firstId) (Just secondId) (queue, accumulation)+  | firstId == secondId = Right (queue, accumulation)+  | otherwise = do+      firstMeta <- requireMeta metas firstId+      secondMeta <- requireMeta metas secondId+      let relation = relationOf (metaSegment firstMeta) (metaSegment secondMeta)+          checked = accumulation{accumulatedPairChecks = accumulatedPairChecks accumulation + 1}+      witness <-+        either+          (Left . ExactSweepIntersectionObstruction firstId secondId)+          Right+          (relationWitnessPoint (metaSegment firstMeta) (metaSegment secondMeta) relation)+      case witness of+        Just point+          | fst (exactPointCoordinates point) > currentX ->+              let pair = orderedPair firstId secondId+                  bundle = emptyEventBundle{eventScheduled = Set.singleton pair}+               in Right (insertBundle point bundle queue, checked)+        _ -> Right (queue, checked)++relationWitnessPoint+  :: ExactSegment+  -> ExactSegment+  -> SegmentRelation+  -> Either ExactIntersectionError (Maybe ExactPoint)+relationWitnessPoint left right relation =+  case relation of+    SegmentsProperlyCross -> Just <$> exactSupportingLineIntersection left right+    SegmentEndpointTouchesInterior -> Right (uniqueTouch left right)+    SegmentsShareEndpoint -> Right (uniqueShared left right)+    _ -> Right Nothing++uniqueShared :: ExactSegment -> ExactSegment -> Maybe ExactPoint+uniqueShared left right =+  let (a, b) = exactSegmentEndpoints left+      (c, d) = exactSegmentEndpoints right+   in case Set.toAscList (Set.intersection (Set.fromList [a, b]) (Set.fromList [c, d])) of+        [point] -> Just point+        _ -> Nothing++uniqueTouch :: ExactSegment -> ExactSegment -> Maybe ExactPoint+uniqueTouch left right =+  let (a, b) = exactSegmentEndpoints left+      (c, d) = exactSegmentEndpoints right+      points =+        Set.toAscList+          ( Set.fromList+              ( [point | point <- [a, b], exactOnClosedSegment c d point]+                  <> [point | point <- [c, d], exactOnClosedSegment a b point]+              )+          )+   in case points of+        [point] -> Just point+        _ -> Nothing++statusCompare+  :: StatusSide+  -> ExactRational+  -> SegmentMeta+  -> SegmentMeta+  -> Ordering+statusCompare side x left right =+  case compareOrdinateAt x left right of+    EQ ->+      case compareSlope left right of+        EQ -> compare (metaId left) (metaId right)+        slopeOrder -> if side == StatusAfter then slopeOrder else invertOrdering slopeOrder+    order -> order++compareOrdinateAt :: ExactRational -> SegmentMeta -> SegmentMeta -> Ordering+compareOrdinateAt x left right =+  let (leftNumerator, leftDenominator) = ordinateFraction x left+      (rightNumerator, rightDenominator) = ordinateFraction x right+   in compare+        (leftNumerator * rightDenominator)+        (rightNumerator * leftDenominator)++compareSlope :: SegmentMeta -> SegmentMeta -> Ordering+compareSlope left right =+  let (leftRise, leftRun) = slopeFraction left+      (rightRise, rightRun) = slopeFraction right+   in compare+        (leftRise * rightRun)+        (rightRise * leftRun)++ordinateFraction :: ExactRational -> SegmentMeta -> (ExactRational, ExactRational)+ordinateFraction x meta =+  let (fromX, fromY) = exactPointCoordinates (metaLow meta)+      (toX, toY) = exactPointCoordinates (metaHigh meta)+      run = toX - fromX+      numerator = fromY * run + (x - fromX) * (toY - fromY)+   in (numerator, run)++slopeFraction :: SegmentMeta -> (ExactRational, ExactRational)+slopeFraction meta =+  let (fromX, fromY) = exactPointCoordinates (metaLow meta)+      (toX, toY) = exactPointCoordinates (metaHigh meta)+   in (toY - fromY, toX - fromX)++invertOrdering :: Ordering -> Ordering+invertOrdering LT = GT+invertOrdering EQ = EQ+invertOrdering GT = LT++insertStatus+  :: V.Vector SegmentMeta+  -> StatusSide+  -> ExactRational+  -> StatusTree+  -> ExactSweepSegmentId+  -> Either ExactSegmentEventObstruction StatusTree+insertStatus metas side x tree segmentId = do+  meta <- requireMeta metas segmentId+  pure (statusInsert (statusCompare side x) meta tree)++deleteStatus+  :: V.Vector SegmentMeta+  -> StatusSide+  -> ExactRational+  -> StatusTree+  -> ExactSweepSegmentId+  -> Either ExactSegmentEventObstruction StatusTree+deleteStatus metas side x tree segmentId = do+  meta <- requireMeta metas segmentId+  pure (statusDelete (statusCompare side x) meta tree)++statusInsert+  :: (SegmentMeta -> SegmentMeta -> Ordering)+  -> SegmentMeta+  -> StatusTree+  -> StatusTree+statusInsert compareIds value tree =+  case tree of+    StatusEmpty -> statusNode StatusEmpty value StatusEmpty+    StatusNode _ left current right ->+      case compareIds value current of+        LT -> statusBalance (statusNode (statusInsert compareIds value left) current right)+        GT -> statusBalance (statusNode left current (statusInsert compareIds value right))+        EQ -> tree++statusDelete+  :: (SegmentMeta -> SegmentMeta -> Ordering)+  -> SegmentMeta+  -> StatusTree+  -> StatusTree+statusDelete compareIds value tree =+  case tree of+    StatusEmpty -> StatusEmpty+    StatusNode _ left current right ->+      case compareIds value current of+        LT -> statusBalance (statusNode (statusDelete compareIds value left) current right)+        GT -> statusBalance (statusNode left current (statusDelete compareIds value right))+        EQ -> statusMerge left right++statusMerge :: StatusTree -> StatusTree -> StatusTree+statusMerge left StatusEmpty = left+statusMerge left right =+  case statusDeleteLeast right of+    Nothing -> left+    Just (least, remaining) -> statusBalance (statusNode left least remaining)++statusDeleteLeast :: StatusTree -> Maybe (SegmentMeta, StatusTree)+statusDeleteLeast StatusEmpty = Nothing+statusDeleteLeast (StatusNode _ StatusEmpty value right) = Just (value, right)+statusDeleteLeast (StatusNode _ left value right) = do+  (least, remaining) <- statusDeleteLeast left+  pure (least, statusBalance (statusNode remaining value right))++statusHeight :: StatusTree -> Int+statusHeight StatusEmpty = 0+statusHeight (StatusNode height _ _ _) = height++statusNode :: StatusTree -> SegmentMeta -> StatusTree -> StatusTree+statusNode left value right =+  StatusNode+    (1 + max (statusHeight left) (statusHeight right))+    left+    value+    right++statusBalance :: StatusTree -> StatusTree+statusBalance tree =+  case tree of+    StatusEmpty -> StatusEmpty+    StatusNode _ left value right+      | statusHeight left - statusHeight right > 1 -> balanceLeft left value right+      | statusHeight right - statusHeight left > 1 -> balanceRight left value right+      | otherwise -> statusNode left value right++balanceLeft :: StatusTree -> SegmentMeta -> StatusTree -> StatusTree+balanceLeft left value right =+  case left of+    StatusNode _ leftLeft leftValue leftRight+      | statusHeight leftLeft >= statusHeight leftRight ->+          statusNode leftLeft leftValue (statusNode leftRight value right)+      | otherwise ->+          case leftRight of+            StatusNode _ middleLeft middleValue middleRight ->+              statusNode+                (statusNode leftLeft leftValue middleLeft)+                middleValue+                (statusNode middleRight value right)+            StatusEmpty -> statusNode left value right+    StatusEmpty -> statusNode left value right++balanceRight :: StatusTree -> SegmentMeta -> StatusTree -> StatusTree+balanceRight left value right =+  case right of+    StatusNode _ rightLeft rightValue rightRight+      | statusHeight rightRight >= statusHeight rightLeft ->+          statusNode (statusNode left value rightLeft) rightValue rightRight+      | otherwise ->+          case rightLeft of+            StatusNode _ middleLeft middleValue middleRight ->+              statusNode+                (statusNode left value middleLeft)+                middleValue+                (statusNode middleRight rightValue rightRight)+            StatusEmpty -> statusNode left value right+    StatusEmpty -> statusNode left value right++statusAtY+  :: ExactRational+  -> ExactRational+  -> StatusTree+  -> [ExactSweepSegmentId]+statusAtY x y = descend+ where+  descend StatusEmpty = []+  descend (StatusNode _ left meta right) =+    case compareMetaToY x y meta of+      LT -> descend right+      GT -> descend left+      EQ -> descend left <> [metaId meta] <> descend right++statusRangeByY+  :: ExactRational+  -> ExactRational+  -> ExactRational+  -> StatusTree+  -> [ExactSweepSegmentId]+statusRangeByY x lower upper = descend+ where+  descend StatusEmpty = []+  descend (StatusNode _ left meta right) =+    let below = compareMetaToY x lower meta == LT+        above = compareMetaToY x upper meta == GT+     in if below+          then descend right+          else+            if above+              then descend left+              else descend left <> [metaId meta] <> descend right++compareMetaToY :: ExactRational -> ExactRational -> SegmentMeta -> Ordering+compareMetaToY x y meta =+  let (numerator, denominator) = ordinateFraction x meta+   in compare numerator (y * denominator)++statusBelowAbove+  :: ExactRational+  -> ExactRational+  -> StatusTree+  -> (Maybe ExactSweepSegmentId, Maybe ExactSweepSegmentId)+statusBelowAbove x y = descend Nothing Nothing+ where+  descend below above StatusEmpty = (below, above)+  descend below above (StatusNode _ left meta right) =+    case compareMetaToY x y meta of+      LT -> descend (Just (metaId meta)) above right+      GT -> descend below (Just (metaId meta)) left+      EQ -> (statusGreatest left <|> below, statusLeast right <|> above)++statusPredecessor+  :: ExactRational+  -> SegmentMeta+  -> StatusTree+  -> Maybe ExactSweepSegmentId+statusPredecessor x target = descend Nothing+ where+  descend candidate StatusEmpty = candidate+  descend candidate (StatusNode _ left current right) =+    case statusCompare StatusAfter x target current of+      LT -> descend candidate left+      GT -> descend (Just (metaId current)) right+      EQ -> statusGreatest left <|> candidate++statusSuccessor+  :: ExactRational+  -> SegmentMeta+  -> StatusTree+  -> Maybe ExactSweepSegmentId+statusSuccessor x target = descend Nothing+ where+  descend candidate StatusEmpty = candidate+  descend candidate (StatusNode _ left current right) =+    case statusCompare StatusAfter x target current of+      LT -> descend (Just (metaId current)) left+      GT -> descend candidate right+      EQ -> statusLeast right <|> candidate++statusLeast :: StatusTree -> Maybe ExactSweepSegmentId+statusLeast StatusEmpty = Nothing+statusLeast (StatusNode _ StatusEmpty value _) = Just (metaId value)+statusLeast (StatusNode _ left _ _) = statusLeast left++statusGreatest :: StatusTree -> Maybe ExactSweepSegmentId+statusGreatest StatusEmpty = Nothing+statusGreatest (StatusNode _ _ value StatusEmpty) = Just (metaId value)+statusGreatest (StatusNode _ _ _ right) = statusGreatest right++lookupMeta :: V.Vector SegmentMeta -> ExactSweepSegmentId -> Maybe SegmentMeta+lookupMeta metas (ExactSweepSegmentId index) = metas V.!? index++requireMeta+  :: V.Vector SegmentMeta+  -> ExactSweepSegmentId+  -> Either ExactSegmentEventObstruction SegmentMeta+requireMeta metas segmentId =+  case lookupMeta metas segmentId of+    Just meta -> Right meta+    Nothing -> Left (ExactSweepSegmentMissing segmentId)++exactSegmentEvents :: ExactSegmentEventPlan -> [ExactSegmentEvent]+exactSegmentEvents = Map.elems . plannedEvents++exactSegmentSplitPoints+  :: ExactSegmentEventPlan+  -> ExactSweepSegmentId+  -> [ExactPoint]+exactSegmentSplitPoints plan (ExactSweepSegmentId segmentIndex) =+  maybe [] id (plannedSplitPoints plan V.!? segmentIndex)++exactSegmentRelationMap+  :: ExactSegmentEventPlan+  -> Map (ExactSweepSegmentId, ExactSweepSegmentId) SegmentRelation+exactSegmentRelationMap = Map.map eventRelation . plannedEvents++eventRelation :: ExactSegmentEvent -> SegmentRelation+eventRelation event =+  case event of+    ExactProperCrossing {} -> SegmentsProperlyCross+    ExactEndpointTouch {} -> SegmentEndpointTouchesInterior+    ExactSharedEndpoint {} -> SegmentsShareEndpoint+    ExactDuplicateSegments {} -> SegmentsDuplicate+    ExactCollinearOverlap {} -> SegmentsCollinearlyOverlap++exactSegmentPairChecks :: ExactSegmentEventPlan -> Int+exactSegmentPairChecks = plannedPairChecks++exactSegmentSweepMaximumHeight :: ExactSegmentEventPlan -> Int+exactSegmentSweepMaximumHeight = plannedMaximumHeight++sortAlong :: ExactSegment -> [ExactPoint] -> [ExactPoint]+sortAlong segment =+  let (from, to) = exactSegmentEndpoints segment+   in if from <= to then Set.toAscList . Set.fromList else Set.toDescList . Set.fromList
src-dcel/Moonlight/Triangulation/Internal/Mutable.hs view
@@ -6,7 +6,18 @@  module Moonlight.Triangulation.Internal.Mutable   ( MutableDcel (..)+  , DenseMutableDcel+  , MutableTopology (..)+  , denseMutableDcel+  , denseMutableOwner+  , DcelCapacity+  , generalDcelCapacity+  , planarDcelCapacity+  , exactDcelCapacity   , newMutableDcel+  , DefaultedVertexDcel+  , newMutableDcelWithVertexDefault+  , defaultedVertexDcel   , thawTriangulation   , thawTriangulationDense   , freezeTriangulation@@ -33,6 +44,11 @@   , edgeOriginPoint   , appendVertex   , appendVertexCoordinates+  , appendDefaultVertexCoordinates+  , NextVertexSlot+  , nextVertexSlot+  , nextVertexSlotIndex+  , appendVertexCoordinatesAtSlot   , ensurePointCapacity   , markConnected   , isConnected@@ -40,6 +56,9 @@   , addEdgeBlock   , addFace   , addFaceBlock+  , denseAddEdgeBlock+  , denseAddFaceBlock+  , denseInitializeUnconstrainedEdgeBlock   , ensureCellCapacity   , truncatePoints   , truncateDirectedEdges@@ -63,6 +82,25 @@   , readFaceEdge   , writeFaceEdge   , readConstraint+  , denseReadPointX+  , denseReadPointY+  , denseReadOrigin+  , denseWriteOrigin+  , denseReadNext+  , denseWriteNext+  , denseReadPrevious+  , denseWritePrevious+  , denseReadFace+  , denseWriteFace+  , denseWriteVertexOut+  , denseMarkFreshConnected+  , denseCommitFreshConnections+  , denseReadFaceEdge+  , denseWriteFaceEdge+  , denseReadConstraint+  , denseLinkEdges+  , denseSetCycle3+  , denseFaceEdges   , setConstraint   , clearConstraint   ) where@@ -153,9 +191,193 @@   , 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+-- | Physical bounds for one fresh mutable DCEL. Vertex, directed-edge and+-- face sections are stated independently because a known planar construction+-- and an arbitrary append program obey different allocation laws. Keeping the+-- law in the constructor input prevents every fresh caller from silently+-- inheriting the loosest reservation and then copying its dead tail at freeze.+data DcelCapacity = DcelCapacity+  {-# UNPACK #-} !Int+  {-# UNPACK #-} !Int+  {-# UNPACK #-} !Int +-- | Conservative append-program capacity, preserving the historical slack+-- for operations whose intermediate cells may outlive their final topology.+generalDcelCapacity :: Int -> DcelCapacity+generalDcelCapacity maximumVertices =+  let !vertices = max 1 maximumVertices+   in DcelCapacity vertices (max 2 (8 * vertices + 16)) (max 1 (3 * vertices + 8))++-- | Tight fresh planar capacity. Circle sweep allocates monotonically and no+-- rewrite abandons a cell, so Euler's bounds plus seed slack are authoritative:+-- at most @6n@ directed edges and @2n@ faces.+planarDcelCapacity :: Int -> DcelCapacity+planarDcelCapacity maximumVertices =+  let !vertices = max 1 maximumVertices+   in DcelCapacity vertices (max 2 (6 * vertices + 16)) (max 1 (2 * vertices + 8))++-- | Exact section bounds for reconstruction programs that already know the+-- published cardinalities they will materialize.+exactDcelCapacity :: Int -> Int -> Int -> DcelCapacity+exactDcelCapacity vertices directedEdges faces =+  DcelCapacity (max 1 vertices) (max 2 directedEdges) (max 1 faces)++-- | The contiguous physical section of one mutable DCEL. It is a refinement+-- of the canonical owner, not a second mesh: every plane below is the exact+-- flat vector already held by 'denseMutableOwner'. Circle sweep and dense+-- sessions discharge this section once, then interpret their hot local+-- rewrites without re-testing each 'MutablePaged' sum at every cell.+data DenseMutableDcel s vertex directed undirected face = DenseMutableDcel+  { dmdOwner :: !(MutableDcel s vertex directed undirected face)+  , dmdPointX :: !(FlatMutablePaged s Double)+  , dmdPointY :: !(FlatMutablePaged s Double)+  , dmdVertexOut :: !(FlatMutablePaged s Word32)+  , dmdNewConnected :: !(FlatMutablePaged s Word8)+  , dmdHalfTopology :: !(FlatMutablePaged s Word32)+  , dmdConstraint :: !(FlatMutablePaged s Word8)+  , dmdFaceEdge :: !(FlatMutablePaged s Word32)+  }++denseMutableDcel+  :: MutableDcel s vertex directed undirected face+  -> Maybe (DenseMutableDcel s vertex directed undirected face)+denseMutableDcel owner@MutableDcel{mdPointX, mdPointY, mdVertexOut, mdNewConnected, mdHalfTopology, mdConstraint, mdFaceEdge} =+  DenseMutableDcel owner+    <$> flatMutableSection mdPointX+    <*> flatMutableSection mdPointY+    <*> flatMutableSection mdVertexOut+    <*> flatMutableSection mdNewConnected+    <*> flatMutableSection mdHalfTopology+    <*> flatMutableSection mdConstraint+    <*> flatMutableSection mdFaceEdge+{-# INLINE denseMutableDcel #-}++denseMutableOwner+  :: DenseMutableDcel s vertex directed undirected face+  -> MutableDcel s vertex directed undirected face+denseMutableOwner = dmdOwner+{-# INLINE denseMutableOwner #-}++-- | The physical interpretation required by local topology rewrites. The+-- semantic owner remains 'MutableDcel'; this algebra merely preserves the+-- storage refinement a caller has already proved, so one normalization law+-- specializes to either paged or flat cells instead of growing a sibling+-- rewrite engine.+class MutableTopology mutable where+  topologyOwner+    :: mutable s vertex directed undirected face+    -> MutableDcel s vertex directed undirected face+  topologyReadPointX+    :: mutable s vertex directed undirected face -> Int -> ST s Double+  topologyReadPointY+    :: mutable s vertex directed undirected face -> Int -> ST s Double+  topologyReadOrigin+    :: mutable s vertex directed undirected face -> Int -> ST s Int+  topologyReadNext+    :: mutable s vertex directed undirected face -> Int -> ST s Int+  topologyReadPrevious+    :: mutable s vertex directed undirected face -> Int -> ST s Int+  topologyReadFace+    :: mutable s vertex directed undirected face -> Int -> ST s Int+  topologyReadConstraint+    :: mutable s vertex directed undirected face -> Int -> ST s Bool+  topologyWriteOrigin+    :: mutable s vertex directed undirected face -> Int -> Int -> ST s ()+  topologyWriteNext+    :: mutable s vertex directed undirected face -> Int -> Int -> ST s ()+  topologyWritePrevious+    :: mutable s vertex directed undirected face -> Int -> Int -> ST s ()+  topologyWriteFace+    :: mutable s vertex directed undirected face -> Int -> Int -> ST s ()+  topologyWriteFaceEdge+    :: mutable s vertex directed undirected face -> Int -> Int -> ST s ()+  topologyWriteVertexOut+    :: mutable s vertex directed undirected face -> Int -> Int -> ST s ()++instance MutableTopology MutableDcel where+  topologyOwner = id+  topologyReadPointX = readPointX+  topologyReadPointY = readPointY+  topologyReadOrigin = readOrigin+  topologyReadNext = readNext+  topologyReadPrevious = readPrevious+  topologyReadFace = readFace+  topologyReadConstraint = readConstraint+  topologyWriteOrigin = writeOrigin+  topologyWriteNext = writeNext+  topologyWritePrevious = writePrevious+  topologyWriteFace = writeFace+  topologyWriteFaceEdge = writeFaceEdge+  topologyWriteVertexOut = writeVertexOut+  {-# INLINE topologyOwner #-}+  {-# INLINE topologyReadPointX #-}+  {-# INLINE topologyReadPointY #-}+  {-# INLINE topologyReadOrigin #-}+  {-# INLINE topologyReadNext #-}+  {-# INLINE topologyReadPrevious #-}+  {-# INLINE topologyReadFace #-}+  {-# INLINE topologyReadConstraint #-}+  {-# INLINE topologyWriteOrigin #-}+  {-# INLINE topologyWriteNext #-}+  {-# INLINE topologyWritePrevious #-}+  {-# INLINE topologyWriteFace #-}+  {-# INLINE topologyWriteFaceEdge #-}+  {-# INLINE topologyWriteVertexOut #-}++instance MutableTopology DenseMutableDcel where+  topologyOwner = denseMutableOwner+  topologyReadPointX = denseReadPointX+  topologyReadPointY = denseReadPointY+  topologyReadOrigin = denseReadOrigin+  topologyReadNext = denseReadNext+  topologyReadPrevious = denseReadPrevious+  topologyReadFace = denseReadFace+  topologyReadConstraint = denseReadConstraint+  topologyWriteOrigin = denseWriteOrigin+  topologyWriteNext = denseWriteNext+  topologyWritePrevious = denseWritePrevious+  topologyWriteFace = denseWriteFace+  topologyWriteFaceEdge = denseWriteFaceEdge+  topologyWriteVertexOut = denseWriteVertexOut+  {-# INLINE topologyOwner #-}+  {-# INLINE topologyReadPointX #-}+  {-# INLINE topologyReadPointY #-}+  {-# INLINE topologyReadOrigin #-}+  {-# INLINE topologyReadNext #-}+  {-# INLINE topologyReadPrevious #-}+  {-# INLINE topologyReadFace #-}+  {-# INLINE topologyReadConstraint #-}+  {-# INLINE topologyWriteOrigin #-}+  {-# INLINE topologyWriteNext #-}+  {-# INLINE topologyWritePrevious #-}+  {-# INLINE topologyWriteFace #-}+  {-# INLINE topologyWriteFaceEdge #-}+  {-# INLINE topologyWriteVertexOut #-}++newMutableDcel :: ElementDefaults directed undirected face -> DcelCapacity -> ST s (MutableDcel s vertex directed undirected face)+newMutableDcel defaults capacity = newMutableDcelFrom DenseTransaction Nothing defaults capacity Nothing++-- | A fresh mutable DCEL whose vertex payload plane is uniformly filled.+-- The witness is what permits geometry-only ingress to extend that plane+-- without materializing one boxed unit value per site.+newtype DefaultedVertexDcel s vertex directed undirected face = DefaultedVertexDcel+  { defaultedVertexDcel :: MutableDcel s vertex directed undirected face+  }++newMutableDcelWithVertexDefault+  :: vertex+  -> ElementDefaults directed undirected face+  -> DcelCapacity+  -> ST s (DefaultedVertexDcel s vertex directed undirected face)+newMutableDcelWithVertexDefault vertexDefault defaults capacity =+  DefaultedVertexDcel+    <$> newMutableDcelFrom+          DenseTransaction+          (Just vertexDefault)+          defaults+          capacity+          Nothing+ -- | Open a local-edit transaction: copy-on-write pages, publication -- proportional to dirtied pages. The section for singleton persistent verbs. thawTriangulation@@ -165,8 +387,9 @@ thawTriangulation maximumVertices triangulation =   newMutableDcelFrom     LocalTransaction+    Nothing     (triElementDefaults triangulation)-    maximumVertices+    (generalDcelCapacity maximumVertices)     (Just triangulation)  -- | Open a batch transaction: one dense copy up front, flat reads and writes@@ -178,32 +401,26 @@ thawTriangulationDense maximumVertices triangulation =   newMutableDcelFrom     DenseTransaction+    Nothing     (triElementDefaults triangulation)-    maximumVertices+    (generalDcelCapacity maximumVertices)     (Just triangulation)  newMutableDcelFrom   :: TransactionShape+  -> Maybe vertex   -> ElementDefaults directed undirected face-  -> Int+  -> DcelCapacity   -> Maybe (Triangulation mode vertex directed undirected face)   -> ST s (MutableDcel s vertex directed undirected face)-newMutableDcelFrom shape mdElementDefaults maximumVertices source = do+newMutableDcelFrom shape vertexDefault mdElementDefaults (DcelCapacity requestedVertices requestedHalfEdges requestedFaces) 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+      !vertexCapacity = max existingVertices requestedVertices+      !halfCapacity = max existingHalfEdges requestedHalfEdges+      !faceCapacity = max existingFaces requestedFaces+      vertexDataBase = maybe (emptyBoxedPaged vertexDefault) 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@@ -527,6 +744,22 @@     Point x y -> appendVertexCoordinates mutable x y vertexData {-# INLINE appendVertex #-} +-- | The next unmaterialized vertex record in one mutable DCEL. The constructor+-- stays private: a caller may transport the candidate to a derived identity+-- index, but cannot fabricate a different arena position for the append that+-- follows. The slot remains lawful only while no intervening append occurs.+newtype NextVertexSlot s = NextVertexSlot Int++nextVertexSlot+  :: MutableDcel s vertex directed undirected face+  -> ST s (NextVertexSlot s)+nextVertexSlot MutableDcel{mdPointCount} = NextVertexSlot <$> readSTRef mdPointCount+{-# INLINE nextVertexSlot #-}++nextVertexSlotIndex :: NextVertexSlot s -> Int+nextVertexSlotIndex (NextVertexSlot vertex) = vertex+{-# INLINE nextVertexSlotIndex #-}+ -- | 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@@ -537,35 +770,73 @@   -> Double   -> vertex   -> ST s Int-appendVertexCoordinates mutable@MutableDcel{mdPointCount, mdPointX, mdPointY, mdPointIndex, mdNewConnected, mdRecycledNew} x y vertexData = do-  vertex <- readSTRef mdPointCount+appendVertexCoordinates mutable x y vertexData = do+  slot <- nextVertexSlot mutable+  appendVertexCoordinatesAtSlot mutable slot x y vertexData+{-# INLINE appendVertexCoordinates #-}++-- | Append the uniform vertex payload carried by a defaulted-vertex witness.+-- No boxed page is written: extending the authoritative point count extends+-- the defaulted payload plane at freeze.+appendDefaultVertexCoordinates+  :: DefaultedVertexDcel s vertex directed undirected face+  -> Double+  -> Double+  -> ST s Int+appendDefaultVertexCoordinates (DefaultedVertexDcel mutable) x y = do+  slot <- nextVertexSlot mutable+  initializeVertexCoordinatesAtSlot mutable slot x y+{-# INLINE appendDefaultVertexCoordinates #-}++-- | Materialize the exact fresh record named by a previously acquired slot.+-- Keeping the slot typed and adjacent to identity resolution lets bulk ingress+-- share one point-count read between the identity candidate and the append.+appendVertexCoordinatesAtSlot+  :: MutableDcel s vertex directed undirected face+  -> NextVertexSlot s+  -> Double+  -> Double+  -> vertex+  -> ST s Int+appendVertexCoordinatesAtSlot mutable slot@(NextVertexSlot vertex) x y vertexData = do+  writeVertexData mutable vertex vertexData+  initializeVertexCoordinatesAtSlot mutable slot x y+{-# INLINE appendVertexCoordinatesAtSlot #-}++initializeVertexCoordinatesAtSlot+  :: MutableDcel s vertex directed undirected face+  -> NextVertexSlot s+  -> Double+  -> Double+  -> ST s Int+initializeVertexCoordinatesAtSlot mutable@MutableDcel{mdPointCount, mdPointX, mdPointY, mdPointIndex, mdNewConnected, mdRecycledNew} (NextVertexSlot vertex) x y = do   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-    )+  pointIndexState <- readSTRef mdPointIndex+  case pointIndexState of+    ActivePersistentPointIndex pointIndex ->+      writeSTRef mdPointIndex (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 _ -> writeSTRef mdPointIndex 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 ->+      writeSTRef mdPointIndex (DormantPointIndex (insertPointIndex x y vertex pointIndex))+    -- A missing derived view stays missing without writing its cell once per+    -- bulk vertex. Freeze already descends from the coordinate authority when+    -- a future identity query demands the view.+    MissingPointIndex -> pure ()   writeSTRef mdPointCount (vertex + 1)   pure vertex+{-# INLINE initializeVertexCoordinatesAtSlot #-}  -- | Check the point arena before a local rewrite materializes vertices. The -- caller performs this before the first write, so refusal needs no rollback.@@ -630,6 +901,33 @@   pure base {-# INLINE addEdgeBlock #-} +-- | Append initialized cells through the already-proved contiguous section.+-- The semantic allocator and its tail invariant are identical to+-- 'addEdgeBlock'; only the physical interpreter is selected once rather than+-- once per topology slot.+denseAddEdgeBlock :: DenseMutableDcel s vertex directed undirected face -> Int -> ST s Int+denseAddEdgeBlock dense@DenseMutableDcel{dmdOwner = MutableDcel{mdHalfCount}} pairs = do+  base <- readSTRef mdHalfCount+  let !required = base + 2 * pairs+  denseInitializeUnconstrainedEdgeBlock dense base pairs+  writeSTRef mdHalfCount required+  pure base+{-# INLINE denseAddEdgeBlock #-}++-- | Initialize the constraint section of a proved fresh directed-edge block+-- without advancing the global arena count. A reserved bulk program threads+-- its allocation cursor immutably and commits the count once after gluing;+-- the ordinary allocator above shares this exact record initializer.+denseInitializeUnconstrainedEdgeBlock+  :: DenseMutableDcel s vertex directed undirected face+  -> Int+  -> Int+  -> ST s ()+denseInitializeUnconstrainedEdgeBlock DenseMutableDcel{dmdConstraint} directedBase pairs =+  forM_ [directedBase `quot` 2 .. directedBase `quot` 2 + pairs - 1] $ \edge ->+    writeFlatMutable dmdConstraint edge 0+{-# INLINE denseInitializeUnconstrainedEdgeBlock #-}+ addFace :: MutableDcel s vertex directed undirected face -> Int -> ST s Int addFace mutable anchor = do   base <- addFaceBlock mutable 1@@ -646,6 +944,14 @@   pure base {-# INLINE addFaceBlock #-} +denseAddFaceBlock :: DenseMutableDcel s vertex directed undirected face -> Int -> ST s Int+denseAddFaceBlock DenseMutableDcel{dmdOwner = MutableDcel{mdFaceCount}} count = do+  base <- readSTRef mdFaceCount+  let !required = base + count+  writeSTRef mdFaceCount required+  pure base+{-# INLINE denseAddFaceBlock #-}+ -- | 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.@@ -980,6 +1286,110 @@   e2 <- readNext mutable e1   pure (e0, e1, e2) {-# INLINE faceEdges #-}++denseLinkEdges :: DenseMutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+denseLinkEdges dense left right = do+  denseWriteNext dense left right+  denseWritePrevious dense right left+{-# INLINE denseLinkEdges #-}++denseSetCycle3 :: DenseMutableDcel s vertex directed undirected face -> Int -> Int -> Int -> Int -> ST s ()+denseSetCycle3 dense face e0 e1 e2 = do+  denseWriteNext dense e0 e1+  denseWriteNext dense e1 e2+  denseWriteNext dense e2 e0+  denseWritePrevious dense e0 e2+  denseWritePrevious dense e1 e0+  denseWritePrevious dense e2 e1+  denseWriteFace dense e0 face+  denseWriteFace dense e1 face+  denseWriteFace dense e2 face+  denseWriteFaceEdge dense face e0+{-# INLINE denseSetCycle3 #-}++denseFaceEdges :: DenseMutableDcel s vertex directed undirected face -> Int -> ST s (Int, Int, Int)+denseFaceEdges dense face = do+  e0 <- denseReadFaceEdge dense face+  e1 <- denseReadNext dense e0+  e2 <- denseReadNext dense e1+  pure (e0, e1, e2)+{-# INLINE denseFaceEdges #-}++denseReadPointX :: DenseMutableDcel s vertex directed undirected face -> Int -> ST s Double+denseReadPointX DenseMutableDcel{dmdPointX} = readFlatMutable dmdPointX+denseReadPointY :: DenseMutableDcel s vertex directed undirected face -> Int -> ST s Double+denseReadPointY DenseMutableDcel{dmdPointY} = readFlatMutable dmdPointY+{-# INLINE denseReadPointX #-}+{-# INLINE denseReadPointY #-}++denseReadOrigin :: DenseMutableDcel s vertex directed undirected face -> Int -> ST s Int+denseReadOrigin DenseMutableDcel{dmdHalfTopology} index = fromIntegral <$> readFlatMutable dmdHalfTopology (4 * index)+denseReadNext :: DenseMutableDcel s vertex directed undirected face -> Int -> ST s Int+denseReadNext DenseMutableDcel{dmdHalfTopology} index = fromIntegral <$> readFlatMutable dmdHalfTopology (4 * index + 1)+denseReadPrevious :: DenseMutableDcel s vertex directed undirected face -> Int -> ST s Int+denseReadPrevious DenseMutableDcel{dmdHalfTopology} index = fromIntegral <$> readFlatMutable dmdHalfTopology (4 * index + 2)+denseReadFace :: DenseMutableDcel s vertex directed undirected face -> Int -> ST s Int+denseReadFace DenseMutableDcel{dmdHalfTopology} index = fromIntegral <$> readFlatMutable dmdHalfTopology (4 * index + 3)+{-# INLINE denseReadOrigin #-}+{-# INLINE denseReadNext #-}+{-# INLINE denseReadPrevious #-}+{-# INLINE denseReadFace #-}++denseWriteOrigin :: DenseMutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+denseWriteOrigin DenseMutableDcel{dmdHalfTopology} index value = writeFlatMutable dmdHalfTopology (4 * index) (packIndex value)+denseWriteNext :: DenseMutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+denseWriteNext DenseMutableDcel{dmdHalfTopology} index value = writeFlatMutable dmdHalfTopology (4 * index + 1) (packIndex value)+denseWritePrevious :: DenseMutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+denseWritePrevious DenseMutableDcel{dmdHalfTopology} index value = writeFlatMutable dmdHalfTopology (4 * index + 2) (packIndex value)+denseWriteFace :: DenseMutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+denseWriteFace DenseMutableDcel{dmdHalfTopology} index value = writeFlatMutable dmdHalfTopology (4 * index + 3) (packIndex value)+{-# INLINE denseWriteOrigin #-}+{-# INLINE denseWriteNext #-}+{-# INLINE denseWritePrevious #-}+{-# INLINE denseWriteFace #-}++denseWriteVertexOut :: DenseMutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+denseWriteVertexOut DenseMutableDcel{dmdVertexOut} index value =+  writeFlatMutable dmdVertexOut index (if value < 0 then noIndex else packIndex value)+{-# INLINE denseWriteVertexOut #-}++-- | Materialize the connectivity section for a vertex proven fresh by the+-- circle-sweep reservation. Arbitrary insertion retains 'markConnected'; this+-- refined write has no resident case to rediscover, and its aggregate count is+-- committed once after the sweep's local sections glue.+denseMarkFreshConnected+  :: DenseMutableDcel s vertex directed undirected face+  -> Int+  -> Int+  -> ST s ()+denseMarkFreshConnected dense@DenseMutableDcel{dmdOwner = MutableDcel{mdInitialPointCount}, dmdNewConnected} vertex outgoing = do+  writeFlatMutable dmdNewConnected (vertex - mdInitialPointCount) 1+  denseWriteVertexOut dense vertex outgoing+{-# INLINE denseMarkFreshConnected #-}++denseCommitFreshConnections+  :: DenseMutableDcel s vertex directed undirected face+  -> Int+  -> ST s ()+denseCommitFreshConnections DenseMutableDcel{dmdOwner = MutableDcel{mdConnectedCount}} count =+  modifySTRef' mdConnectedCount (+ count)+{-# INLINE denseCommitFreshConnections #-}++denseReadFaceEdge :: DenseMutableDcel s vertex directed undirected face -> Int -> ST s Int+denseReadFaceEdge DenseMutableDcel{dmdFaceEdge} index = do+  value <- readFlatMutable dmdFaceEdge index+  pure (if value == noIndex then -1 else fromIntegral value)+{-# INLINE denseReadFaceEdge #-}++denseWriteFaceEdge :: DenseMutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+denseWriteFaceEdge DenseMutableDcel{dmdFaceEdge} index value =+  writeFlatMutable dmdFaceEdge index (if value < 0 then noIndex else packIndex value)+{-# INLINE denseWriteFaceEdge #-}++denseReadConstraint :: DenseMutableDcel s vertex directed undirected face -> Int -> ST s Bool+denseReadConstraint DenseMutableDcel{dmdConstraint} directed =+  (/= 0) <$> readFlatMutable dmdConstraint (directed `quot` 2)+{-# INLINE denseReadConstraint #-}  readOrigin :: MutableDcel s vertex directed undirected face -> Int -> ST s Int readOrigin MutableDcel{mdHalfTopology} index = fromIntegral <$> readPaged mdHalfTopology (4 * index)
src-dcel/Moonlight/Triangulation/Internal/OperationState.hs view
@@ -11,6 +11,7 @@ -- probe) charge them where they happen. module Moonlight.Triangulation.Internal.OperationState   ( Counter (..)+  , LegalizationArena (..)   , OperationState   , newOperationState   , legalizationArena@@ -38,6 +39,12 @@ import Moonlight.Triangulation.Internal.PackedIndex (packIndex) import Moonlight.Triangulation.Internal.Types (BuildStats (..)) +-- | The typed candidate section owned by one operation. The newtype prevents+-- unrelated scratch vectors from being handed to the normalizer while+-- erasing to the same contiguous Word32 arena in the hot path.+newtype LegalizationArena s = LegalizationArena+  (MUV.MVector s Word32)+ -- | 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@@ -79,7 +86,7 @@ -- 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))+  { osLegalizationArena :: !(STRef s (LegalizationArena s))   , osScratchArena :: !(GrowableWord32 s)   , osCounters :: !(MUV.MVector s Word64)   }@@ -100,7 +107,7 @@ -- magnitude larger than the edit. newOperationState :: Int -> ST s (OperationState s) newOperationState halfEdgeCapacity = do-  initialArena <- MUV.new (min (2 * halfEdgeCapacity + 64) initialLegalizationReservation)+  initialArena <- LegalizationArena <$> MUV.new (min (2 * halfEdgeCapacity + 64) initialLegalizationReservation)   arena <- newSTRef initialArena   scratch <- newGrowableWord32 (min 64 (halfEdgeCapacity + 8))   counters <- MUV.replicate (fromEnum CounterCount) 0@@ -117,11 +124,11 @@ initialLegalizationReservation :: Int initialLegalizationReservation = 64 -legalizationArena :: OperationState s -> ST s (MUV.MVector s Word32)+legalizationArena :: OperationState s -> ST s (LegalizationArena s) legalizationArena = readSTRef . osLegalizationArena {-# INLINE legalizationArena #-} -storeLegalizationArena :: OperationState s -> MUV.MVector s Word32 -> ST s ()+storeLegalizationArena :: OperationState s -> LegalizationArena s -> ST s () storeLegalizationArena = writeSTRef . osLegalizationArena {-# INLINE storeLegalizationArena #-}
+ src-dcel/Moonlight/Triangulation/Internal/Region/Bounds.hs view
@@ -0,0 +1,205 @@+-- | Exact axis-aligned candidate bounds for admitted region geometry. Bounds+-- prune impossible overlap obligations; exact predicates remain authoritative.+module Moonlight.Triangulation.Internal.Region.Bounds+  ( ExactBounds+  , exactLoopBounds+  , componentBounds+  , regionBounds+  , boundsOverlap+  , pointInBounds+  , overlappingPairs+  , overlappingOptionalPairs+  , overlappingPairsBetween+  , overlappingPredecessors+  ) where++import Data.List (sortOn, tails)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.IntMap.Strict as IntMap+import Moonlight.Triangulation.Exact+  ( ExactPoint+  , exactPointCoordinates+  )+import Moonlight.Triangulation.Internal.ExactRational (ExactRational)+import Moonlight.Triangulation.Internal.Region.Types+  ( ExactLoop (..)+  , PlanarRegion (..)+  , PolygonComponent (..)+  )++data ExactBounds = ExactBounds+  !ExactRational+  !ExactRational+  !ExactRational+  !ExactRational++exactLoopBounds :: ExactLoop -> ExactBounds+exactLoopBounds (ExactLoop (firstPoint :| remaining)) =+  foldl' extend (pointBounds firstPoint) remaining+ where+  extend bounds point = boundsUnion bounds (pointBounds point)++componentBounds :: PolygonComponent -> ExactBounds+componentBounds = exactLoopBounds . polygonOuterLoop++regionBounds :: PlanarRegion -> Maybe ExactBounds+regionBounds (PlanarRegion components) =+  case components of+    [] -> Nothing+    firstComponent : remaining ->+      Just+        ( foldl'+            (\bounds component -> boundsUnion bounds (componentBounds component))+            (componentBounds firstComponent)+            remaining+        )++pointBounds :: ExactPoint -> ExactBounds+pointBounds point =+  let (x, y) = exactPointCoordinates point+   in ExactBounds x y x y++boundsUnion :: ExactBounds -> ExactBounds -> ExactBounds+boundsUnion+  (ExactBounds leftMinimumX leftMinimumY leftMaximumX leftMaximumY)+  (ExactBounds rightMinimumX rightMinimumY rightMaximumX rightMaximumY) =+    ExactBounds+      (min leftMinimumX rightMinimumX)+      (min leftMinimumY rightMinimumY)+      (max leftMaximumX rightMaximumX)+      (max leftMaximumY rightMaximumY)++boundsOverlap :: ExactBounds -> ExactBounds -> Bool+boundsOverlap+  (ExactBounds leftMinimumX leftMinimumY leftMaximumX leftMaximumY)+  (ExactBounds rightMinimumX rightMinimumY rightMaximumX rightMaximumY) =+    not+      ( leftMaximumX < rightMinimumX+          || rightMaximumX < leftMinimumX+          || leftMaximumY < rightMinimumY+          || rightMaximumY < leftMinimumY+      )++pointInBounds :: ExactPoint -> ExactBounds -> Bool+pointInBounds point (ExactBounds minimumX minimumY maximumX maximumY) =+  let (x, y) = exactPointCoordinates point+   in minimumX <= x && x <= maximumX && minimumY <= y && y <= maximumY++overlappingPairs :: (value -> ExactBounds) -> [value] -> [(value, value)]+overlappingPairs boundsOf =+  overlappingIndexedValuePairs+    . zipWith (\index value -> (index, boundsOf value, value)) [0 ..]++overlappingOptionalPairs+  :: (value -> Maybe ExactBounds)+  -> [value]+  -> [(value, value)]+overlappingOptionalPairs boundsOf =+  overlappingIndexedValuePairs+    . concatMap+      (\(index, value) ->+         case boundsOf value of+           Nothing -> []+           Just bounds -> [(index, bounds, value)])+    . zip [0 ..]++overlappingPairsBetween+  :: (value -> ExactBounds)+  -> [value]+  -> [value]+  -> [(value, value)]+overlappingPairsBetween boundsOf leftValues rightValues =+  [ pair+  | (firstBounds, firstValue) : remaining <- tails ordered+  , (secondBounds, secondValue) <-+      takeWhile+        (\(bounds, _) -> boundsMinimumX bounds <= boundsMaximumX firstBounds)+        remaining+  , pair <- crossPair firstValue secondValue+  , boundsOverlap firstBounds secondBounds+  ]+ where+  ordered =+    sortOn+      (boundsMinimumX . fst)+      ( map+          (\value -> (either boundsOf boundsOf value, value))+          (map Left leftValues <> map Right rightValues)+      )+  crossPair :: Either value value -> Either value value -> [(value, value)]+  crossPair (Left leftValue) (Right rightValue) = [(leftValue, rightValue)]+  crossPair (Right rightValue) (Left leftValue) = [(leftValue, rightValue)]+  crossPair _ _ = []++-- | Each value together with only the earlier input values whose exact bounds+-- overlap it. This is the local cover used when a fold glues one component at+-- a time and needs the complete overlap section accumulated so far.+overlappingPredecessors+  :: (value -> ExactBounds)+  -> [value]+  -> [(value, [value])]+overlappingPredecessors boundsOf values =+  [ ( value+    , map snd+        ( sortOn fst+            (IntMap.findWithDefault [] index predecessorsByIndex)+        )+    )+  | (index, value) <- zip [0 ..] values+  ]+ where+  indexed = zipWith (\index value -> (index, boundsOf value, value)) [0 ..] values+  predecessorsByIndex =+    IntMap.fromListWith (<>)+      [ (rightIndex, [(leftIndex, leftValue)])+      | (leftIndex, rightIndex, leftValue, _) <- overlappingIndexedEntries indexed+      ]++-- The authoring path retains its nested result pair because the flattened+-- four-field candidate increased allocation on the registered 1,024-component+-- workload. The predecessor path below needs the indices after selection and+-- therefore carries the indexed specialization separately.+overlappingIndexedValuePairs+  :: [(Int, ExactBounds, value)]+  -> [(value, value)]+overlappingIndexedValuePairs indexed =+  map (\(_, _, pair) -> pair)+    ( sortOn (\(leftIndex, rightIndex, _) -> (leftIndex, rightIndex))+        [ if leftIndex <= rightIndex+            then (leftIndex, rightIndex, (leftValue, rightValue))+            else (rightIndex, leftIndex, (rightValue, leftValue))+        | (leftIndex, leftBounds, leftValue) : remaining <- tails ordered+        , (rightIndex, rightBounds, rightValue) <-+            takeWhile+              (\(_, bounds, _) -> boundsMinimumX bounds <= boundsMaximumX leftBounds)+              remaining+        , boundsOverlap leftBounds rightBounds+        ]+    )+ where+  ordered = sortOn (\(_, bounds, _) -> boundsMinimumX bounds) indexed++overlappingIndexedEntries+  :: [(Int, ExactBounds, value)]+  -> [(Int, Int, value, value)]+overlappingIndexedEntries indexed =+  sortOn+    (\(leftIndex, rightIndex, _, _) -> (leftIndex, rightIndex))+    [ if leftIndex <= rightIndex+        then (leftIndex, rightIndex, leftValue, rightValue)+        else (rightIndex, leftIndex, rightValue, leftValue)+    | (leftIndex, leftBounds, leftValue) : remaining <- tails ordered+    , (rightIndex, rightBounds, rightValue) <-+        takeWhile+          (\(_, bounds, _) -> boundsMinimumX bounds <= boundsMaximumX leftBounds)+          remaining+    , boundsOverlap leftBounds rightBounds+    ]+ where+  ordered = sortOn (\(_, bounds, _) -> boundsMinimumX bounds) indexed++boundsMinimumX :: ExactBounds -> ExactRational+boundsMinimumX (ExactBounds minimumX _ _ _) = minimumX++boundsMaximumX :: ExactBounds -> ExactRational+boundsMaximumX (ExactBounds _ _ maximumX _) = maximumX
+ src-dcel/Moonlight/Triangulation/Internal/Region/Publication.hs view
@@ -0,0 +1,153 @@+-- | Trusted exact-coordinate publication from the one resident DCEL boundary+-- owner. The callback-bearing entrances are internal because only a sealed+-- downstream carrier may prove that its exact coordinate section belongs to+-- the supplied topology.+module Moonlight.Triangulation.Internal.Region.Publication+  ( labelledPlanarLayer+  , labelledPlanarLayerFromExactCoordinates+  , planarLayerFromAdmittedComponents+  , polygonComponentFromBoundaryCoordinates+  ) where++import Data.Bifunctor (first)+import Data.List (sort)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import Moonlight.Triangulation.Dcel (vertexPoint)+import Moonlight.Triangulation.Exact+  ( ExactPoint+  , exactOnClosedSegment+  , exactOrient2d+  , exactPointFromPoint+  )+import Moonlight.Triangulation.FloodFillIterator+  ( BoundaryLoop+  , RegionBoundary+  , boundaryLoopVertices+  , componentBoundary+  , faceComponents+  , labelledRegionBoundaries+  , regionBoundaryHoleLoops+  , regionBoundaryOuterLoop+  )+import Moonlight.Triangulation.Handles.HandleDefs (FaceId, VertexId)+import Moonlight.Triangulation.Internal.BoundaryCycle+  ( rotateCycleLeast+  , simplifyBoundaryCycle+  )+import Moonlight.Triangulation.Internal.Region.Types+  ( ExactLoop (..)+  , PlanarLayer (..)+  , PlanarRegion (..)+  , PolygonComponent (..)+  , RegionPublicationError (..)+  , RegionValidationError (..)+  )+import Moonlight.Triangulation.Internal.Representation (Triangulation)++-- | Publish bounded resident face labels through the existing component and+-- boundary owners, then lift only traced boundary coordinates exactly.+labelledPlanarLayer+  :: Ord label+  => label+  -> Triangulation mode vertex directed undirected face+  -> (FaceId -> label)+  -> Either RegionPublicationError (PlanarLayer label)+labelledPlanarLayer outside triangulation labelFace = do+  labelledBoundaries <-+    first RegionBoundaryObstruction+      (labelledRegionBoundaries triangulation labelFace)+  labelledComponents <-+    traverse+      (\(label, boundary) ->+         (label,) <$> polygonComponentFromBoundaryCoordinates exactPointAt boundary)+      [ pair+      | pair@(label, _) <- labelledBoundaries+      , label /= outside+      ]+  pure (planarLayerFromAdmittedComponents outside labelledComponents)+ where+  exactPointAt vertex =+    first (RegionCoordinateObstruction vertex)+      (exactPointFromPoint (vertexPoint triangulation vertex))++-- | Publish bounded face labels using the exact-coordinate section belonging+-- to the resident carrier. Topology has already been proved by+-- 'labelledRegionBoundaries'; this path performs exact simplification but does+-- not send derived loops back through authoring event sweeps.+labelledPlanarLayerFromExactCoordinates+  :: Ord label+  => label+  -> Triangulation mode vertex directed undirected face+  -> (VertexId -> Either RegionPublicationError ExactPoint)+  -> (FaceId -> Either RegionPublicationError label)+  -> Either RegionPublicationError (PlanarLayer label)+labelledPlanarLayerFromExactCoordinates outside triangulation exactPointAt labelFace = do+  labelledComponents <-+    traverse+      (\(labelResult, component) -> do+         label <- labelResult+         boundary <-+           first RegionBoundaryObstruction+             (componentBoundary triangulation component)+         (label,) <$> polygonComponentFromBoundaryCoordinates exactPointAt boundary)+      [ pair+      | pair@(labelResult, _) <- faceComponents triangulation labelFace+      , labelResult /= Right outside+      ]+  pure (planarLayerFromAdmittedComponents outside labelledComponents)++-- | Glue already-admitted, pairwise interior-disjoint components by label.+-- Both DCEL publication and exact overlay cells reach this point only after+-- their topology owner has proved those obligations.+planarLayerFromAdmittedComponents+  :: Ord label+  => label+  -> [(label, PolygonComponent)]+  -> PlanarLayer label+planarLayerFromAdmittedComponents outside labelledComponents =+  PlanarLayer+    outside+    ( Map.map+        (PlanarRegion . sort)+        ( Map.fromListWith (<>)+            [(label, [component]) | (label, component) <- labelledComponents]+        )+    )++-- | Convert one already-traced resident component boundary against the exact+-- coordinate carrier admitted for that same resident topology.+polygonComponentFromBoundaryCoordinates+  :: (VertexId -> Either RegionPublicationError ExactPoint)+  -> RegionBoundary+  -> Either RegionPublicationError PolygonComponent+polygonComponentFromBoundaryCoordinates exactPointAt boundary = do+  outer <- convertLoop (regionBoundaryOuterLoop boundary)+  holes <- traverse convertLoop (regionBoundaryHoleLoops boundary)+  pure (PolygonComponent outer (sort holes))+ where+  convertLoop :: BoundaryLoop -> Either RegionPublicationError ExactLoop+  convertLoop loop = do+    points <- traverse exactPointAt (boundaryLoopVertices loop)+    admittedDerivedLoop points++-- | Boundary descent already proves simplicity, winding, and component+-- compatibility. Exact simplification remains necessary because the exact+-- carrier may expose a collinearity that the embedded boundary retained.+admittedDerivedLoop+  :: NonEmpty ExactPoint+  -> Either RegionPublicationError ExactLoop+admittedDerivedLoop points = do+  (_, simplified) <-+    first RegionValidationObstruction+      ( simplifyBoundaryCycle+          RegionLoopDegenerate+          (\previous current next ->+             exactOrient2d previous current next == EQ+               && exactOnClosedSegment previous next current)+          exactOrient2d+          id+          (NonEmpty.toList points)+      )+  pure (ExactLoop (rotateCycleLeast simplified))
+ src-dcel/Moonlight/Triangulation/Internal/Region/Types.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | The invariant-bearing exact region carriers. Public construction and+-- validation remain in "Moonlight.Triangulation.Region"; downstream build-tier+-- algorithms import this owner only when their algebra proves the constructors'+-- obligations directly.+module Moonlight.Triangulation.Internal.Region.Types+  ( ExactLoop (..)+  , PolygonComponent (..)+  , PlanarRegion (..)+  , RegionPointLocation (..)+  , PlanarLayer (..)+  , RegionValidationError (..)+  , RegionPublicationError (..)+  ) where++import Control.DeepSeq (NFData)+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict (Map)+import GHC.Generics (Generic)+import Moonlight.Triangulation.Exact+  ( ExactPoint+  , SegmentRelation+  )+import Moonlight.Triangulation.FloodFillIterator (BoundaryObstruction)+import Moonlight.Triangulation.Handles.HandleDefs (FaceId, VertexId)+import Moonlight.Triangulation.Internal.ExactSegmentEvents+  ( ExactSegmentEventObstruction+  )+import Moonlight.Triangulation.Internal.Types (PointValidationError)++-- | One admitted, simple exact cycle. Its first point is the least exact point+-- on the cycle, so equality does not retain an authoring rotation.+newtype ExactLoop = ExactLoop (NonEmpty ExactPoint)+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | One connected polygonal component: a counter-clockwise outer cycle and+-- zero or more clockwise holes.+data PolygonComponent = PolygonComponent+  { polygonOuterLoop :: !ExactLoop+  , polygonHoleLoops :: ![ExactLoop]+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A finite union of components with pairwise-disjoint interiors.+newtype PlanarRegion = PlanarRegion [PolygonComponent]+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Exact point position relative to a closed region.+data RegionPointLocation+  = RegionExterior+  | RegionOnBoundary+  | RegionInterior+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A finite labelled planar layer. The outside label is implicit and may not+-- also own a bounded region.+data PlanarLayer label = PlanarLayer+  { planarLayerOutsideLabel :: !label+  , planarLayerRegions :: !(Map label PlanarRegion)+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Typed authoring obstructions. Indices are cycle/component positions in the+-- submitted value and every geometric relation preserves its exact witness.+data RegionValidationError+  = RegionLoopDegenerate ![ExactPoint]+  | RegionLoopSelfRelation !Int !Int !SegmentRelation+  | RegionOuterLoopWinding !Ordering+  | RegionHoleLoopWinding !Int !Ordering+  | RegionHoleLocation !Int !RegionPointLocation+  | RegionBoundaryRelation !Int !Int !SegmentRelation+  | RegionComponentInteriorOverlap !Int !Int+  | RegionLayerInteriorOverlap !Int !Int+  | RegionOutsideLabelUsed+  | RegionSegmentEventsInvalid !ExactSegmentEventObstruction+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Typed failures while publishing an existing triangulation as exact region+-- values. The handle is retained when a resident coordinate is inadmissible.+data RegionPublicationError+  = RegionBoundaryObstruction !BoundaryObstruction+  | RegionCoordinateObstruction !VertexId !PointValidationError+  | RegionCoordinateMissing !VertexId+  | RegionFaceLabelMissing !FaceId+  | RegionValidationObstruction !RegionValidationError+  | RegionUnboundedSelection+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)
src-dcel/Moonlight/Triangulation/Internal/Representation.hs view
@@ -22,6 +22,8 @@   , mapDirectedEdges   , mapUndirectedEdges   , mapFaces+  , imapUndirectedEdges+  , imapFaces   , DelaunayTriangulation   , ConstrainedDelaunayTriangulation   , BuildResult (..)@@ -37,7 +39,11 @@ 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.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)@@ -292,6 +298,42 @@   -> Triangulation mode vertex' directed undirected face mapVertices f triangulation =   triangulation{triVertexData = fmap f (triVertexData triangulation)}++-- | Materialize every resident undirected-edge annotation in handle order+-- while installing the declared fallback for edges created by a later edit.+imapUndirectedEdges+  :: undirected'+  -> (UndirectedEdgeId -> undirected -> undirected')+  -> Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex directed undirected' face+imapUndirectedEdges fallback relabel triangulation =+  triangulation+    { triUndirectedData =+        boxedFromVector (Just fallback)+          (V.imap (\index -> relabel (UndirectedEdgeId (fromIntegral index))) payloads)+    , triElementDefaults = defaults{defaultUndirectedEdgeData = fallback}+    }+ where+  payloads = boxedToVector (triUndirectedData triangulation)+  defaults = triElementDefaults triangulation++-- | Materialize every resident face annotation in handle order while+-- installing the declared fallback for faces created by a later edit.+imapFaces+  :: face'+  -> (FaceId -> face -> face')+  -> Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex directed undirected face'+imapFaces fallback relabel triangulation =+  triangulation+    { triFaceData =+        boxedFromVector (Just fallback)+          (V.imap (\index -> relabel (FaceId (fromIntegral index))) payloads)+    , triElementDefaults = defaults{defaultFaceData = fallback}+    }+ where+  payloads = boxedToVector (triFaceData triangulation)+  defaults = triElementDefaults triangulation  -- | Geometry-only unconstrained Delaunay triangulation. type DelaunayTriangulation vertex = Triangulation 'Unconstrained vertex () () ()
+ src-dcel/Moonlight/Triangulation/Internal/SegmentRelation.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | The complete closed-segment relation vocabulary and its one policy owner.+module Moonlight.Triangulation.Internal.SegmentRelation+  ( SegmentRelation (..)+  , allSegmentRelations+  , segmentRelationWith+  ) where++import Control.DeepSeq (NFData)+import GHC.Generics (Generic)++-- | 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)++-- | Every segment relation in constructor order.+allSegmentRelations :: [SegmentRelation]+allSegmentRelations = [minBound .. maxBound]++-- | Classify two closed segments using the supplied point observations.+segmentRelationWith+  :: (point -> point -> Bool)+  -- ^ Point equality.+  -> (point -> point -> Ordering)+  -- ^ Lexicographic point ordering.+  -> (point -> point -> point -> Ordering)+  -- ^ Orientation of an ordered triple.+  -> (point -> point -> point -> Bool)+  -- ^ Membership of the third point in the closed segment.+  -> point+  -> point+  -> point+  -> point+  -> SegmentRelation+segmentRelationWith equalPoint comparePoint orientation onSegment 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 = orientation a b c+  !abD = orientation a b d+  !cdA = orientation c d a+  !cdB = orientation c d b+  sameUndirectedSegment =+    (equalPoint a c && equalPoint b d)+      || (equalPoint a d && equalPoint b c)+  sharesEndpoint =+    equalPoint a c+      || equalPoint a d+      || equalPoint b c+      || equalPoint b d+  endpointTouches =+    (abC == EQ && onSegment a b c)+      || (abD == EQ && onSegment a b d)+      || (cdA == EQ && onSegment c d a)+      || (cdB == EQ && onSegment c d b)+  collinearRelation =+    let !overlapLower = maximumPoint (minimumPoint a b) (minimumPoint c d)+        !overlapUpper = minimumPoint (maximumPoint a b) (maximumPoint c d)+     in case comparePoint overlapLower overlapUpper of+          LT -> SegmentsCollinearlyOverlap+          EQ -> SegmentEndpointTouchesInterior+          GT -> SegmentsDisjoint+  opposite left right =+    (left == LT && right == GT) || (left == GT && right == LT)+  minimumPoint left right =+    case comparePoint left right of+      GT -> right+      _ -> left+  maximumPoint left right =+    case comparePoint left right of+      LT -> right+      _ -> left+{-# INLINE segmentRelationWith #-}
src-dcel/Moonlight/Triangulation/Internal/Types.hs view
@@ -260,6 +260,7 @@       !VertexId       !DirectedEdgeId       {-# UNPACK #-} !Int+  | CircleSweepRequiresDenseStorage   | CircleSweepHullEmpty   | OuterCycleDidNotTerminate       !DirectedEdgeId
src-dcel/Moonlight/Triangulation/Math.hs view
@@ -1,7 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}  -- | Robust planar predicates and derived Euclidean constructions. module Moonlight.Triangulation.Math@@ -39,17 +36,21 @@   , isFinite   ) where -import Control.DeepSeq (NFData)-import GHC.Generics (Generic) import Moonlight.Triangulation.Internal.Dyadic   ( exactBarycentricDeterminants   , exactDiametralDot   , integerRatioToDouble   )+import Moonlight.Triangulation.Internal.SegmentRelation+  ( SegmentRelation (..)+  , allSegmentRelations+  , segmentRelationWith+  ) import Moonlight.Triangulation.LineSideInfo (LineSideInfo, fromOrdering) import Moonlight.Triangulation.Scalar   ( canonicalScalarZero   , inCircleCoordinates+  , isFinite   , maximumAllowedCoordinate   , minimumAllowedCoordinate   , orient2dCoordinates@@ -63,24 +64,6 @@   , 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)---- | Every segment relation in constructor order.-allSegmentRelations :: [SegmentRelation]-allSegmentRelations = [minBound .. maxBound]- -- | Exact relation between two closed segments. segmentRelation   :: Point@@ -88,34 +71,8 @@   -> 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)+segmentRelation a b c d =+  segmentRelationWith (==) compare orient2d onClosedSegment a b c d  -- | Whether two closed segments share any point. segmentsIntersect@@ -191,16 +148,6 @@ 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.--- | Whether a scalar is neither infinite nor NaN.-isFinite :: Double -> Bool-isFinite value = value - value == 0-{-# INLINE isFinite #-}  -- | Fast approximate signed orientation determinant. orientDetApprox :: Point -> Point -> Point -> Double
+ src-dcel/Moonlight/Triangulation/Region.hs view
@@ -0,0 +1,426 @@+-- | Exact polygon authoring and grouped publication through the resident DCEL+-- region traversal. Construction validates topology once; downstream overlay+-- consumes only admitted layers.+module Moonlight.Triangulation.Region+  ( ExactLoop+  , exactLoop+  , exactLoopPoints+  , PolygonComponent+  , polygonComponent+  , polygonOuterLoop+  , polygonHoleLoops+  , PlanarRegion+  , planarRegion+  , planarRegionComponents+  , emptyPlanarRegion+  , RegionPointLocation (..)+  , regionPointLocation+  , PlanarLayer+  , planarLayerOutsideLabel+  , planarLayerRegions+  , planarLayer+  , planarLayerLabelAt+  , RegionValidationError (..)+  , RegionPublicationError (..)+  , labelledPlanarLayer+  ) where++import Data.Bifunctor (first)+import Data.Foldable (traverse_)+import Data.List (sort)+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Vector as V+import Moonlight.Triangulation.Exact+  ( ExactPoint+  , ExactSegment+  , SegmentRelation (..)+  , exactOnClosedSegment+  , exactOrient2d+  , exactPointCross+  , exactPointCoordinates+  , exactSegment+  , exactSegmentEndpoints+  )+import Moonlight.Triangulation.Internal.BoundaryCycle+  ( cyclePairs+  , rotateCycleLeast+  , simplifyBoundaryCycle+  )+import Moonlight.Triangulation.Internal.ExactSegmentEvents+  ( ExactSegmentEventObstruction (..)+  , ExactSweepSegmentId (..)+  , exactSegmentEventPlan+  , exactSegmentRelationMap+  )+import Moonlight.Triangulation.Internal.ExactRational+  ( exactSignum )+import Moonlight.Triangulation.Internal.Region.Publication (labelledPlanarLayer)+import Moonlight.Triangulation.Internal.Region.Bounds+  ( boundsOverlap+  , componentBounds+  , exactLoopBounds+  , overlappingOptionalPairs+  , overlappingPairs+  , overlappingPairsBetween+  , pointInBounds+  , regionBounds+  )+import Moonlight.Triangulation.Internal.Region.Types+  ( ExactLoop (..)+  , PlanarLayer (..)+  , PlanarRegion (..)+  , PolygonComponent (..)+  , RegionPointLocation (..)+  , RegionPublicationError (..)+  , RegionValidationError (..)+  )++data LoopRelationWitness = LoopRelationWitness+  !Int+  !Int+  !ExactSegment+  !ExactSegment+  !SegmentRelation++-- | Admit and canonicalize one simple exact cycle.+exactLoop :: NonEmpty ExactPoint -> Either RegionValidationError ExactLoop+exactLoop submitted = do+  let withoutRepeatedTerminal = removeRepeatedTerminal (NonEmpty.toList submitted)+  (_, simplified) <-+    simplifyBoundaryCycle+      RegionLoopDegenerate+      exactRedundant+      exactOrient2d+      id+      withoutRepeatedTerminal+  let canonical = rotateCycleLeast simplified+  validateSimpleLoop canonical+  pure (ExactLoop canonical)++-- | Read the canonical cycle points.+exactLoopPoints :: ExactLoop -> NonEmpty ExactPoint+exactLoopPoints (ExactLoop points) = points++-- | Admit one component after checking orientation, containment, boundary+-- relations, and pairwise-disjoint hole interiors.+polygonComponent+  :: ExactLoop+  -> [ExactLoop]+  -> Either RegionValidationError PolygonComponent+polygonComponent outer holes = do+  let outerWinding = loopWinding outer+  if outerWinding == GT+    then Right ()+    else Left (RegionOuterLoopWinding outerWinding)+  traverse_ validateHoleWinding (zip [0 ..] holes)+  traverse_ validateHole (zip [0 ..] holes)+  traverse_+    validateHolePair+    (overlappingPairs (exactLoopBounds . snd) (zip [0 ..] holes))+  pure (PolygonComponent outer (sort holes))+ where+  validateHoleWinding (holeIndex, hole) =+    let winding = loopWinding hole+     in if winding == LT+          then Right ()+          else Left (RegionHoleLoopWinding holeIndex winding)+  validateHole (holeIndex, hole) = do+    relations <- crossLoopRelations outer hole+    case relations of+      LoopRelationWitness outerEdge holeEdge _ _ relation : _ ->+        Left (RegionBoundaryRelation outerEdge holeEdge relation)+      [] -> Right ()+    let location = pointLocationInLoop outer (firstExactLoopPoint hole)+    if location == RegionInterior+      then Right ()+      else Left (RegionHoleLocation holeIndex location)+  validateHolePair ((leftIndex, left), (rightIndex, right)) =+    do+      relations <- crossLoopRelations left right+      case relations of+        LoopRelationWitness _ _ _ _ relation : _ ->+          Left (RegionBoundaryRelation leftIndex rightIndex relation)+        []+          | loopContainsInteriorPoint left right || loopContainsInteriorPoint right left ->+              Left (RegionComponentInteriorOverlap leftIndex rightIndex)+          | otherwise -> Right ()++-- | Admit a finite region after checking that component interiors do not+-- overlap. Boundary-only contact remains lawful.+planarRegion+  :: [PolygonComponent]+  -> Either RegionValidationError PlanarRegion+planarRegion components = do+  traverse_+    validatePair+    (overlappingPairs (componentBounds . snd) (zip [0 ..] components))+  pure (PlanarRegion (sort components))+ where+  validatePair ((leftIndex, left), (rightIndex, right)) = do+    overlaps <- componentInteriorsOverlap left right+    if overlaps+      then Left (RegionComponentInteriorOverlap leftIndex rightIndex)+      else Right ()++-- | Observe the canonically ordered components.+planarRegionComponents :: PlanarRegion -> [PolygonComponent]+planarRegionComponents (PlanarRegion components) = components++-- | The empty finite region.+emptyPlanarRegion :: PlanarRegion+emptyPlanarRegion = PlanarRegion []++-- | Locate an exact point against all components. Boundary membership has+-- priority over interior membership.+regionPointLocation :: PlanarRegion -> ExactPoint -> RegionPointLocation+regionPointLocation (PlanarRegion components) query =+  foldr+    (combineLocation . (`componentPointLocation` query))+    RegionExterior+    components++-- | Admit one labelled layer. Different labels may touch but their interiors+-- may not overlap, and the outside label cannot also name a bounded region.+planarLayer+  :: Ord label+  => label+  -> Map label PlanarRegion+  -> Either RegionValidationError (PlanarLayer label)+planarLayer outside regions+  | Map.member outside regions = Left RegionOutsideLabelUsed+  | otherwise = do+      let indexed = zip [0 ..] (Map.toAscList regions)+      traverse_+        (\((leftIndex, (_, left)), (rightIndex, (_, right))) -> do+           overlaps <- regionsInteriorsOverlap left right+           if overlaps+             then Left (RegionLayerInteriorOverlap leftIndex rightIndex)+             else Right ())+        (overlappingOptionalPairs (regionBounds . snd . snd) indexed)+      pure (PlanarLayer outside regions)++-- | Label an exact point known to lie in a relatively open two-cell. Boundary+-- points conservatively retain the outside label.+planarLayerLabelAt :: PlanarLayer label -> ExactPoint -> label+planarLayerLabelAt layer query =+  case+    [ label+    | (label, region) <- Map.toAscList (planarLayerRegions layer)+    , regionPointLocation region query == RegionInterior+    ] of+    label : _ -> label+    [] -> planarLayerOutsideLabel layer++removeRepeatedTerminal :: Eq value => [value] -> [value]+removeRepeatedTerminal values =+  case values of+    [] -> []+    firstValue : remaining ->+      case reverse remaining of+        finalValue : reversedMiddle+          | firstValue == finalValue -> firstValue : reverse reversedMiddle+        _ -> values++exactRedundant :: ExactPoint -> ExactPoint -> ExactPoint -> Bool+exactRedundant previous current next =+  exactOrient2d previous current next == EQ+    && exactOnClosedSegment previous next current++validateSimpleLoop :: NonEmpty ExactPoint -> Either RegionValidationError ()+validateSimpleLoop points = do+  segments <- loopSegments points+  plan <- first RegionSegmentEventsInvalid (exactSegmentEventPlan segments)+  case+    [ (leftIndex, rightIndex, relation)+    | ((ExactSweepSegmentId leftIndex, ExactSweepSegmentId rightIndex), relation) <-+        Map.toAscList (exactSegmentRelationMap plan)+    , not (adjacentSegment segmentCount leftIndex rightIndex && relation == SegmentsShareEndpoint)+    ] of+    (leftIndex, rightIndex, relation) : _ ->+      Left (RegionLoopSelfRelation leftIndex rightIndex relation)+    [] -> Right ()+ where+  segmentCount = NonEmpty.length points++loopSegments+  :: NonEmpty ExactPoint+  -> Either RegionValidationError (V.Vector ExactSegment)+loopSegments points =+  V.fromList+    <$> traverse+      (\(from, to) ->+         first (const (RegionLoopDegenerate (NonEmpty.toList points)))+           (exactSegment from to))+      (cyclePairs points)++adjacentSegment :: Int -> Int -> Int -> Bool+adjacentSegment count left right =+  right == left + 1 || (left == 0 && right == count - 1)++loopWinding :: ExactLoop -> Ordering+loopWinding (ExactLoop points) =+  exactSignum+    ( foldl'+        (\signedArea (from, to) ->+           signedArea + exactPointCross from to)+        0+        (cyclePairs points)+    )++pointLocationInLoop :: ExactLoop -> ExactPoint -> RegionPointLocation+pointLocationInLoop loop query+  | not (pointInBounds query (exactLoopBounds loop)) = RegionExterior+  | any (\(from, to) -> exactOnClosedSegment from to query) edges = RegionOnBoundary+  | odd (length (filter crossesRay edges)) = RegionInterior+  | otherwise = RegionExterior+ where+  edges = cyclePairs (exactLoopPoints loop)+  (_, py) = exactPointCoordinates query+  crossesRay (from, to) =+    let (_, ay) = exactPointCoordinates from+        (_, by) = exactPointCoordinates to+        orientation = exactOrient2d from to query+     in (ay <= py && py < by && orientation == GT)+          || (by <= py && py < ay && orientation == LT)++componentPointLocation :: PolygonComponent -> ExactPoint -> RegionPointLocation+componentPointLocation component query =+  case pointLocationInLoop (polygonOuterLoop component) query of+    RegionExterior -> RegionExterior+    RegionOnBoundary -> RegionOnBoundary+    RegionInterior -> foldr classifyHole RegionInterior (polygonHoleLoops component)+ where+  classifyHole hole remaining =+    case pointLocationInLoop hole query of+      RegionExterior -> remaining+      RegionOnBoundary -> RegionOnBoundary+      RegionInterior -> RegionExterior++crossLoopRelations+  :: ExactLoop+  -> ExactLoop+  -> Either RegionValidationError [LoopRelationWitness]+crossLoopRelations left right+  | not (boundsOverlap (exactLoopBounds left) (exactLoopBounds right)) = Right []+  | otherwise = do+      leftSegments <- loopSegments (exactLoopPoints left)+      rightSegments <- loopSegments (exactLoopPoints right)+      let leftCount = V.length leftSegments+          relationWitness (leftIndex, rightIndex, relation) =+            LoopRelationWitness leftIndex rightIndex+              <$> requireLoopSegment leftSegments leftIndex+              <*> requireLoopSegment rightSegments rightIndex+              <*> pure relation+      plan <-+        first RegionSegmentEventsInvalid+          (exactSegmentEventPlan (leftSegments <> rightSegments))+      traverse relationWitness+        [ (leftIndex, rightIndex - leftCount, relation)+        | ((ExactSweepSegmentId leftIndex, ExactSweepSegmentId rightIndex), relation) <-+            Map.toAscList (exactSegmentRelationMap plan)+        , leftIndex < leftCount+        , rightIndex >= leftCount+        ]++requireLoopSegment+  :: V.Vector ExactSegment+  -> Int+  -> Either RegionValidationError ExactSegment+requireLoopSegment segments index =+  maybe+    ( Left+        (RegionSegmentEventsInvalid (ExactSweepSegmentMissing (ExactSweepSegmentId index)))+    )+    Right+    (segments V.!? index)++loopContainsInteriorPoint :: ExactLoop -> ExactLoop -> Bool+loopContainsInteriorPoint container candidate =+  pointLocationInLoop container (firstExactLoopPoint candidate) == RegionInterior++componentInteriorsOverlap+  :: PolygonComponent+  -> PolygonComponent+  -> Either RegionValidationError Bool+componentInteriorsOverlap left right =+  boundariesProperlyCross left right+    >>= \crossing ->+      pure+        ( crossing+            || componentContainsInteriorPoint left right+            || componentContainsInteriorPoint right left+        )++boundariesProperlyCross+  :: PolygonComponent+  -> PolygonComponent+  -> Either RegionValidationError Bool+boundariesProperlyCross left right =+  anyEither+    (uncurry loopPairInteriorsOverlap)+    ( overlappingPairsBetween+        exactLoopBounds+        (componentLoops left)+        (componentLoops right)+    )+ where+  componentLoops component =+    polygonOuterLoop component : polygonHoleLoops component++loopPairInteriorsOverlap+  :: ExactLoop+  -> ExactLoop+  -> Either RegionValidationError Bool+loopPairInteriorsOverlap leftLoop rightLoop = do+  relations <- crossLoopRelations leftLoop rightLoop+  pure (any relationOverlapsInteriors relations)+ where+  relationOverlapsInteriors+    (LoopRelationWitness _ _ leftSegment rightSegment relation) =+    case relation of+      SegmentsProperlyCross -> True+      SegmentsDuplicate -> collinearInteriorsCoincide leftSegment rightSegment+      SegmentsCollinearlyOverlap -> collinearInteriorsCoincide leftSegment rightSegment+      _ -> False+  collinearInteriorsCoincide leftSegment rightSegment =+    canonicalDirection leftSegment == canonicalDirection rightSegment+  canonicalDirection segment =+    uncurry (<=) (exactSegmentEndpoints segment)++componentContainsInteriorPoint :: PolygonComponent -> PolygonComponent -> Bool+componentContainsInteriorPoint container candidate =+  any+    ((== RegionInterior) . componentPointLocation container)+    (NonEmpty.toList (exactLoopPoints (polygonOuterLoop candidate)))++firstExactLoopPoint :: ExactLoop -> ExactPoint+firstExactLoopPoint (ExactLoop (point :| _)) = point++regionsInteriorsOverlap+  :: PlanarRegion+  -> PlanarRegion+  -> Either RegionValidationError Bool+regionsInteriorsOverlap (PlanarRegion left) (PlanarRegion right) =+  anyEither+    (uncurry componentInteriorsOverlap)+    (overlappingPairsBetween componentBounds left right)++combineLocation :: RegionPointLocation -> RegionPointLocation -> RegionPointLocation+combineLocation RegionOnBoundary _ = RegionOnBoundary+combineLocation RegionExterior accumulated = accumulated+combineLocation RegionInterior RegionOnBoundary = RegionOnBoundary+combineLocation RegionInterior _ = RegionInterior++anyEither+  :: (value -> Either obstruction Bool)+  -> [value]+  -> Either obstruction Bool+anyEither predicate =+  foldr+    (\value remaining -> do+       matches <- predicate value+       if matches then Right True else remaining)+    (Right False)
+ src-dcel/Moonlight/Triangulation/Valuation.hs view
@@ -0,0 +1,645 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}++-- | Intrinsic valuations of exact closed cell selections and admitted planar+-- regions. Euler characteristic and area remain exact; Euclidean length is an+-- exact radical expression accompanied by outward-rounded binary64 bounds.+module Moonlight.Triangulation.Valuation+  ( EulerCharacteristic+  , eulerCharacteristicValue+  , ExactArea+  , exactAreaValue+  , ExactLengthTerm+  , lengthCoefficient+  , squaredLength+  , ExactLengthExpression+  , exactLengthTerms+  , CertifiedInterval (..)+  , ExactLengthMeasurement+  , exactLengthExpression+  , exactLengthBounds+  , PlanarValuations+  , valuationEuler+  , valuationArea+  , valuationIntrinsic1+  , ValuationError (..)+  , cellValuations+  , regionValuations+  , cellSetPerimeter+  , regionPerimeter+  ) where++import Control.DeepSeq (NFData)+import Data.Bifunctor (first)+import Data.Bits (shiftL)+import Data.Foldable (foldlM)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.IntMap.Strict as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes)+import qualified Data.Ratio as Ratio+import qualified Data.Set as Set+import qualified Data.Vector as V+import GHC.Float (castDoubleToWord64, castWord64ToDouble)+import GHC.Generics (Generic)+import Moonlight.Triangulation.Dcel+  ( faceVertices+  , incidentFace+  , undirectedEndpoints+  )+import Moonlight.Triangulation.Exact+  ( ExactGeometryError+  , ExactPoint+  , ExactSegment+  , exactOnClosedSegment+  , exactPointCross+  , exactPointCoordinates+  , exactSegment+  , exactSegmentEndpoints+  )+import Moonlight.Triangulation.Handles.HandleDefs+  ( FaceId (..)+  , UndirectedEdgeId (..)+  , VertexId (..)+  , directedPair+  )+import Moonlight.Triangulation.Internal.CellSet+  ( ExactCellSet (..)+  , exactCellSetIsFaceClosure+  )+import Moonlight.Triangulation.Internal.BoundaryCycle+  ( consecutivePairs+  , cyclePairs+  , orderedPair+  )+import Moonlight.Triangulation.Internal.Dyadic (integerBitLength)+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactRational+  , exactRationalDenominator+  , exactRationalFromDyadic+  , exactRationalFromFiniteDouble+  , exactRationalIsZero+  , exactRationalNumerator+  , exactSignum+  )+import Moonlight.Triangulation.Internal.ExactSegmentEvents+  ( ExactSegmentEvent (..)+  , ExactSegmentEventObstruction+  , ExactSweepSegmentId (..)+  , exactSegmentEventPlan+  , exactSegmentEvents+  , exactSegmentSplitPoints+  )+import Moonlight.Triangulation.Internal.Region.Types+  ( ExactLoop (..)+  , PlanarRegion (..)+  , PolygonComponent (..)+  )+import Moonlight.Triangulation.Internal.Region.Bounds+  ( ExactBounds+  , componentBounds+  , overlappingPredecessors+  )+import Moonlight.Triangulation.Internal.Representation (Triangulation)++newtype EulerCharacteristic = EulerCharacteristic Int+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++eulerCharacteristicValue :: EulerCharacteristic -> Int+eulerCharacteristicValue (EulerCharacteristic value) = value++newtype ExactArea = ExactArea ExactRational+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++exactAreaValue :: ExactArea -> ExactRational+exactAreaValue (ExactArea value) = value++data ExactLengthTerm = ExactLengthTerm+  { lengthCoefficient :: !ExactRational+  , squaredLength :: !ExactRational+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A normalized sum of rational coefficients times square roots of rational+-- squared lengths. It intentionally has no 'Eq' instance: syntactic radical+-- normalization is not algebraic-number equality.+newtype ExactLengthExpression = ExactLengthExpression [ExactLengthTerm]+  deriving stock (Show, Generic)+  deriving anyclass (NFData)++exactLengthTerms :: ExactLengthExpression -> [ExactLengthTerm]+exactLengthTerms (ExactLengthExpression terms) = terms++data CertifiedInterval = CertifiedInterval+  { intervalLower :: !Double+  , intervalUpper :: !Double+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data ExactLengthMeasurement = ExactLengthMeasurement+  { exactLengthExpression :: !ExactLengthExpression+  , exactLengthBounds :: !CertifiedInterval+  }+  deriving stock (Show, Generic)+  deriving anyclass (NFData)++data PlanarValuations = PlanarValuations+  { valuationEuler :: !EulerCharacteristic+  , valuationArea :: !ExactArea+  , valuationIntrinsic1 :: !ExactLengthMeasurement+  }+  deriving stock (Show, Generic)+  deriving anyclass (NFData)++data ValuationError+  = ValuationCoordinateMissing !VertexId+  | ValuationFaceArity !FaceId !Int+  | ValuationInvalidRegionSegment !ExactGeometryError+  | ValuationSegmentEventsInvalid !ExactSegmentEventObstruction+  | ValuationSegmentMissing !ExactSweepSegmentId+  | ValuationBoundaryMultiplicity !ExactPoint !ExactPoint !Int+  | ValuationNegativeSquaredLength !ExactRational+  | ValuationCellSetNotPureRegion+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++cellValuations :: ExactCellSet -> Either ValuationError PlanarValuations+cellValuations (ExactCellSet triangulation points selectedEdges selectedFaces) = do+  faceDoubleAreas <-+    traverse+      (cellFaceDoubleArea triangulation points . FaceId . fromIntegral)+      (IntSet.toAscList selectedFaces)+  edgeContributions <-+    traverse+      ( cellEdgeLengthContribution triangulation points selectedFaces+          . UndirectedEdgeId+          . fromIntegral+      )+      (IntSet.toAscList selectedEdges)+  assembleValuations+    (IntMap.size points - IntSet.size selectedEdges + IntSet.size selectedFaces)+    (foldl' (+) 0 faceDoubleAreas)+    (normalizeLengthContributions id edgeContributions)++regionValuations :: PlanarRegion -> Either ValuationError PlanarValuations+regionValuations (PlanarRegion components) = do+  componentBoundaries <- traverse componentBoundaryData components+  let boundaryCover =+        overlappingPredecessors componentBoundaryBounds componentBoundaries+      hasPotentialBoundaryContacts = any (not . null . snd) boundaryCover+  euler <- regionEuler boundaryCover+  boundaryAtoms <-+    normalizedRegionBoundaryAtoms+      hasPotentialBoundaryContacts+      componentBoundaries+  let doubleArea =+        foldl'+          (\area component -> area + componentDoubleArea component)+          0+          components+  assembleValuations+    euler+    doubleArea+    ( normalizeLengthContributions+        (\(from, to) -> (oneHalf, segmentSquaredLength from to))+        boundaryAtoms+    )++assembleValuations+  :: Int+  -> ExactRational+  -> ExactLengthExpression+  -> Either ValuationError PlanarValuations+assembleValuations euler doubleArea lengthExpression =+  PlanarValuations (EulerCharacteristic euler) (ExactArea (oneHalf * doubleArea))+    <$> measureLength lengthExpression+cellSetPerimeter+  :: ExactCellSet+  -> Either ValuationError ExactLengthMeasurement+cellSetPerimeter cellSet+  | exactCellSetIsFaceClosure cellSet =+      cellValuations cellSet >>= conventionalPerimeter+  | otherwise = Left ValuationCellSetNotPureRegion++regionPerimeter+  :: PlanarRegion+  -> Either ValuationError ExactLengthMeasurement+regionPerimeter region = regionValuations region >>= conventionalPerimeter++conventionalPerimeter+  :: PlanarValuations+  -> Either ValuationError ExactLengthMeasurement+conventionalPerimeter valuations =+  measureLength+    (scaleLengthExpression 2 (exactLengthExpression (valuationIntrinsic1 valuations)))++cellFaceDoubleArea+  :: Triangulation mode vertex directed undirected face+  -> IntMap.IntMap ExactPoint+  -> FaceId+  -> Either ValuationError ExactRational+cellFaceDoubleArea triangulation points face =+  case faceVertices triangulation face of+    [firstVertex, secondVertex, thirdVertex] -> do+      firstPoint <- cellPoint points firstVertex+      secondPoint <- cellPoint points secondVertex+      thirdPoint <- cellPoint points thirdVertex+      pure (triangleDoubleArea firstPoint secondPoint thirdPoint)+    vertices -> Left (ValuationFaceArity face (length vertices))++cellEdgeLengthContribution+  :: Triangulation mode vertex directed undirected face+  -> IntMap.IntMap ExactPoint+  -> IntSet.IntSet+  -> UndirectedEdgeId+  -> Either ValuationError (ExactRational, ExactRational)+cellEdgeLengthContribution triangulation points selectedFaces edge = do+  let (fromVertex, toVertex) = undirectedEndpoints triangulation edge+      (forward, backward) = directedPair edge+      selected face =+        let FaceId raw = face+         in IntSet.member (fromIntegral raw) selectedFaces+      coefficient = case (selected (incidentFace triangulation forward), selected (incidentFace triangulation backward)) of+        (False, False) -> 1+        (True, True) -> 0+        _ -> oneHalf+  from <- cellPoint points fromVertex+  to <- cellPoint points toVertex+  pure (coefficient, segmentSquaredLength from to)++cellPoint+  :: IntMap.IntMap ExactPoint+  -> VertexId+  -> Either ValuationError ExactPoint+cellPoint points vertex@(VertexId raw) =+  maybe+    (Left (ValuationCoordinateMissing vertex))+    Right+    (IntMap.lookup (fromIntegral raw) points)++triangleDoubleArea :: ExactPoint -> ExactPoint -> ExactPoint -> ExactRational+triangleDoubleArea firstPoint secondPoint thirdPoint =+  exactPointCross firstPoint secondPoint+    + exactPointCross secondPoint thirdPoint+    + exactPointCross thirdPoint firstPoint++componentDoubleArea :: PolygonComponent -> ExactRational+componentDoubleArea component =+  foldl'+    (\area loop -> area + loopDoubleArea loop)+    0+    (polygonOuterLoop component : polygonHoleLoops component)++loopDoubleArea :: ExactLoop -> ExactRational+loopDoubleArea (ExactLoop points) =+  foldl'+    (\area (from, to) -> area + exactPointCross from to)+    0+    (cyclePairs points)++segmentSquaredLength :: ExactPoint -> ExactPoint -> ExactRational+segmentSquaredLength from to =+  let (fromX, fromY) = exactPointCoordinates from+      (toX, toY) = exactPointCoordinates to+      deltaX = toX - fromX+      deltaY = toY - fromY+   in deltaX * deltaX + deltaY * deltaY++normalizeLengthContributions+  :: Foldable collection+  => (value -> (ExactRational, ExactRational))+  -> collection value+  -> ExactLengthExpression+normalizeLengthContributions contribution contributions =+  ExactLengthExpression+    [ ExactLengthTerm coefficient square+    | (square, coefficient) <- Map.toAscList coefficientsBySquare+    , not (exactRationalIsZero coefficient)+    ]+ where+  coefficientsBySquare =+    foldl' accumulateContribution Map.empty contributions+  accumulateContribution coefficients value =+    case contribution value of+      (coefficient, square)+        | exactRationalIsZero coefficient -> coefficients+        | otherwise -> Map.insertWith (+) square coefficient coefficients++scaleLengthExpression+  :: Integer+  -> ExactLengthExpression+  -> ExactLengthExpression+scaleLengthExpression scalar (ExactLengthExpression terms) =+  let exactScalar = fromInteger scalar+   in ExactLengthExpression+        [ term+            { lengthCoefficient =+                exactScalar * lengthCoefficient term+            }+        | term <- terms+        ]++measureLength+  :: ExactLengthExpression+  -> Either ValuationError ExactLengthMeasurement+measureLength expression@(ExactLengthExpression terms) = do+  (lower, upper) <-+    foldlM+      addTermBounds+      (0, 0)+      terms+  pure+    ExactLengthMeasurement+      { exactLengthExpression = expression+      , exactLengthBounds =+          CertifiedInterval+            { intervalLower = directedLowerDouble lower+            , intervalUpper = directedUpperDouble upper+            }+      }+ where+  addTermBounds (lowerTotal, upperTotal) term = do+    (lowerRoot, upperRoot) <- exactSquareRootBounds (squaredLength term)+    let coefficient = lengthCoefficient term+    pure+      ( lowerTotal + coefficient * lowerRoot+      , upperTotal + coefficient * upperRoot+      )++exactSquareRootBounds+  :: ExactRational+  -> Either ValuationError (ExactRational, ExactRational)+exactSquareRootBounds value =+  case exactSignum value of+    LT -> Left (ValuationNegativeSquaredLength value)+    _ ->+      let numerator = exactRationalNumerator value+          denominator = exactRationalDenominator value+          scale = 1 `shiftL` radicalPrecisionBits+          scaledNumerator = numerator * scale * scale+          root = integerSquareRoot (scaledNumerator `div` denominator)+          exact = root * root * denominator == scaledNumerator+          dyadicPower = negate radicalPrecisionBits+       in Right+            ( exactRationalFromDyadic root dyadicPower+            , exactRationalFromDyadic (if exact then root else root + 1) dyadicPower+            )++radicalPrecisionBits :: Int+radicalPrecisionBits = 128++integerSquareRoot :: Integer -> Integer+integerSquareRoot value+  | value < 2 = value+  | otherwise = descend initial+ where+  initial = 1 `shiftL` ((integerBitLength value + 1) `div` 2)+  descend estimate =+    let refined = (estimate + value `div` estimate) `div` 2+     in if refined >= estimate then estimate else descend refined++directedLowerDouble :: ExactRational -> Double+directedLowerDouble value =+  let candidate = rationalToDouble value+   in if isInfinite candidate+        then maximumFiniteDouble+        else+          if exactRationalFromFiniteDouble candidate <= value+            then candidate+            else previousPositiveDouble candidate++directedUpperDouble :: ExactRational -> Double+directedUpperDouble value =+  let candidate = rationalToDouble value+   in if isInfinite candidate+        || exactRationalFromFiniteDouble candidate >= value+        then candidate+        else nextPositiveDouble candidate++rationalToDouble :: ExactRational -> Double+rationalToDouble value =+  fromRational+    ( exactRationalNumerator value+        Ratio.% exactRationalDenominator value+    )++previousPositiveDouble :: Double -> Double+previousPositiveDouble value+  | value <= 0 = 0+  | otherwise = castWord64ToDouble (castDoubleToWord64 value - 1)++nextPositiveDouble :: Double -> Double+nextPositiveDouble value+  | value == 0 = castWord64ToDouble 1+  | otherwise = castWord64ToDouble (castDoubleToWord64 value + 1)++maximumFiniteDouble :: Double+maximumFiniteDouble = castWord64ToDouble 0x7fefffffffffffff++data ComponentBoundaryData = ComponentBoundaryData+  { componentBoundaryEuler :: !Int+  , componentBoundaryBounds :: !ExactBounds+  , componentBoundarySegments :: !(V.Vector ExactSegment)+  }++componentBoundaryData+  :: PolygonComponent+  -> Either ValuationError ComponentBoundaryData+componentBoundaryData component = do+  segments <-+    V.fromList+      <$> traverse+        admittedSegment+        ( concatMap+            (cyclePairs . loopPoints)+            (polygonOuterLoop component : polygonHoleLoops component)+        )+  pure+    ComponentBoundaryData+      { componentBoundaryEuler = 1 - length (polygonHoleLoops component)+      , componentBoundaryBounds = componentBounds component+      , componentBoundarySegments = segments+      }++regionEuler+  :: [(ComponentBoundaryData, [ComponentBoundaryData])]+  -> Either ValuationError Int+regionEuler = foldlM attachComponent 0+ where+  attachComponent accumulatedEuler (current, priorCandidates) = do+    let priorSegments = V.concat (map componentBoundarySegments priorCandidates)+    intersectionEuler <-+      boundaryIntersectionEuler+        (componentBoundarySegments current)+        priorSegments+    pure+      ( accumulatedEuler+          + componentBoundaryEuler current+          - intersectionEuler+      )++boundaryIntersectionEuler+  :: V.Vector ExactSegment+  -> V.Vector ExactSegment+  -> Either ValuationError Int+boundaryIntersectionEuler current prior+  | V.null prior = Right 0+  | otherwise = do+      let currentCount = V.length current+          segments = current <> prior+      plan <- first ValuationSegmentEventsInvalid (exactSegmentEventPlan segments)+      contacts <-+        traverse+          (contactFromEvent segments)+          [ event+          | event <- exactSegmentEvents plan+          , crossPartition currentCount event+          ]+      let contactPoints =+            Set.fromList+              [ point+              | ContactPoint point <- contacts+              ]+          intervals =+            [ interval+            | ContactInterval interval <- contacts+            ]+          allSplitPoints =+            Set.fromList+              ( concatMap+                  (exactSegmentSplitPoints plan)+                  [ ExactSweepSegmentId index+                  | index <- [0 .. V.length segments - 1]+                  ]+              )+          contactEdges =+            Set.fromList+              [ orderedPair from to+              | interval <- intervals+              , let (lower, upper) = interval+                    points =+                      Set.toAscList+                        ( Set.filter+                            (exactOnClosedSegment lower upper)+                            allSplitPoints+                        )+              , (from, to) <- consecutivePairs points+              , from /= to+              ]+          vertices =+            Set.unions+              [ contactPoints+              , Set.fromList+                  [ point+                  | (from, to) <- Set.toAscList contactEdges+                  , point <- [from, to]+                  ]+              ]+      pure (Set.size vertices - Set.size contactEdges)++data BoundaryContact+  = ContactPoint !ExactPoint+  | ContactInterval !(ExactPoint, ExactPoint)++contactFromEvent+  :: V.Vector ExactSegment+  -> ExactSegmentEvent+  -> Either ValuationError BoundaryContact+contactFromEvent _ (ExactProperCrossing _ _ point) = Right (ContactPoint point)+contactFromEvent _ (ExactEndpointTouch _ _ point) = Right (ContactPoint point)+contactFromEvent _ (ExactSharedEndpoint _ _ point) = Right (ContactPoint point)+contactFromEvent segments (ExactDuplicateSegments leftId _) =+  ContactInterval . canonicalSegmentEndpoints+    <$> requireSegment segments leftId+contactFromEvent _ (ExactCollinearOverlap _ _ lower upper) =+  Right (ContactInterval (orderedPair lower upper))++crossPartition :: Int -> ExactSegmentEvent -> Bool+crossPartition boundary event =+  let (ExactSweepSegmentId left, ExactSweepSegmentId right) = eventIds event+   in (left < boundary) /= (right < boundary)++eventIds+  :: ExactSegmentEvent+  -> (ExactSweepSegmentId, ExactSweepSegmentId)+eventIds (ExactProperCrossing left right _) = (left, right)+eventIds (ExactEndpointTouch left right _) = (left, right)+eventIds (ExactSharedEndpoint left right _) = (left, right)+eventIds (ExactDuplicateSegments left right) = (left, right)+eventIds (ExactCollinearOverlap left right _ _) = (left, right)++normalizedRegionBoundaryAtoms+  :: Bool+  -> [ComponentBoundaryData]+  -> Either ValuationError (Set.Set (ExactPoint, ExactPoint))+normalizedRegionBoundaryAtoms hasPotentialBoundaryContacts boundaries+  | V.null segments = Right Set.empty+  | not hasPotentialBoundaryContacts =+      Right+        ( Set.fromList+            (map canonicalSegmentEndpoints (V.toList segments))+        )+  | otherwise = do+      plan <- first ValuationSegmentEventsInvalid (exactSegmentEventPlan segments)+      let orientedAtoms =+            concatMap+              segmentAtoms+              [ exactSegmentSplitPoints plan (ExactSweepSegmentId index)+              | index <- [0 .. V.length segments - 1]+              ]+      traverseMultiplicity+        (Map.toAscList (Map.fromListWith (+) orientedAtoms))+ where+  segments = V.concat (map componentBoundarySegments boundaries)+  segmentAtoms :: [ExactPoint] -> [((ExactPoint, ExactPoint), Int)]+  segmentAtoms points =+    [ ( orderedPair firstPoint secondPoint+      , if firstPoint <= secondPoint then 1 else -1+      )+    | (firstPoint, secondPoint) <- consecutivePairs points+    , firstPoint /= secondPoint+    ]+  traverseMultiplicity+    :: [((ExactPoint, ExactPoint), Int)]+    -> Either ValuationError (Set.Set (ExactPoint, ExactPoint))+  traverseMultiplicity entries = do+    retained <-+      traverse+        (\(edge@(from, to), multiplicity) ->+           case abs multiplicity of+             0 -> Right Nothing+             1 -> Right (Just edge)+             _ -> Left (ValuationBoundaryMultiplicity from to multiplicity))+        entries+    pure (Set.fromList (catMaybes retained))++admittedSegment+  :: (ExactPoint, ExactPoint)+  -> Either ValuationError ExactSegment+admittedSegment (from, to) = first ValuationInvalidRegionSegment (exactSegment from to)++requireSegment+  :: V.Vector ExactSegment+  -> ExactSweepSegmentId+  -> Either ValuationError ExactSegment+requireSegment segments segmentId@(ExactSweepSegmentId index) =+  maybe+    (Left (ValuationSegmentMissing segmentId))+    Right+    (segments V.!? index)++canonicalSegmentEndpoints :: ExactSegment -> (ExactPoint, ExactPoint)+canonicalSegmentEndpoints = uncurry orderedPair . exactSegmentEndpoints++loopPoints :: ExactLoop -> NonEmpty ExactPoint+loopPoints (ExactLoop points) = points++oneHalf :: ExactRational+oneHalf = exactRationalFromDyadic 1 (-1)
+ src-embedding/Moonlight/Triangulation/Internal/Overlay/Embedding.hs view
@@ -0,0 +1,501 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Bounded certification of local binary64 embedding obligations for a+-- declared exact arrangement draft.+module Moonlight.Triangulation.Internal.Overlay.Embedding+  ( DraftVertexId (..)+  , DraftSegmentId (..)+  , DraftSourceId (..)+  , DraftIncidence (..)+  , DraftNeighborhood (..)+  , ExactArrangementDraft (..)+  , DraftReference (..)+  , OverlayEmbeddingObstruction (..)+  , EmbeddingObligation (..)+  , EmbeddingResidual+  , residualUndischargedObligations+  , milestoneOneResidual+  , LocalEmbeddingCertificate (..)+  , certifyLocalEmbedding+  ) where++import Control.DeepSeq (NFData)+import Data.List (sort, tails)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import GHC.Generics (Generic)+import Moonlight.Triangulation.Exact+  ( ExactPoint+  , SegmentRelation+  , exactOrient2d+  , exactPointToEmbeddingCandidate+  , exactSegmentRelation+  )+import Moonlight.Triangulation.Internal.BoundaryCycle (cyclePairs)+import Moonlight.Triangulation.Internal.ExactRational (ExactRational)+import qualified Moonlight.Triangulation.Math as Math+  ( orient2d+  , segmentRelation+  )+import Moonlight.Triangulation.Types+  ( Point (..)+  , PointValidationError+  )++-- | Draft-local vertex label.+newtype DraftVertexId = DraftVertexId Int+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Draft-local atomic-segment label.+newtype DraftSegmentId = DraftSegmentId Int+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Draft-local source-segment label.+newtype DraftSourceId = DraftSourceId Int+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A declared relation between two atomic draft segments.+data DraftIncidence = DraftIncidence+  { -- | First declared atomic segment.+    draftIncidenceFirstSegment :: !DraftSegmentId+  , -- | Second declared atomic segment.+    draftIncidenceSecondSegment :: !DraftSegmentId+  , -- | Relation declared to hold in both exact and rounded geometry.+    draftIncidenceRelation :: !SegmentRelation+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | One exact vertex and the cyclic neighbor order declared around it.+data DraftNeighborhood = DraftNeighborhood+  { -- | Center of the declared local rotation.+    draftNeighborhoodCenter :: !DraftVertexId+  , -- | Neighbors in cyclic rotation order.+    draftNeighborhoodNeighbors :: !(NonEmpty DraftVertexId)+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A hand-built exact arrangement draft. It contains only declared local+-- structure; no arrangement or global crossing search is derived here.+data ExactArrangementDraft = ExactArrangementDraft+  { -- | Exact coordinates keyed by draft-local vertex identity.+    draftVertices :: !(Map DraftVertexId ExactPoint)+  , -- | Atomic segment endpoint identities.+    draftSegments :: !(Map DraftSegmentId (DraftVertexId, DraftVertexId))+  , -- | Exact split parameters and vertices in source-segment order.+    draftSourceMemberships :: !(Map DraftSourceId [(ExactRational, DraftVertexId)])+  , -- | Segment relations declared to remain invariant under projection.+    draftIncidences :: ![DraftIncidence]+  , -- | Cyclic local rotations declared to remain orientation-stable.+    draftNeighborhoods :: ![DraftNeighborhood]+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | The typed identity of a missing draft reference.+data DraftReference+  = DraftVertexReference !DraftVertexId+  | DraftSegmentReference !DraftSegmentId+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A witness that prevents local embedding certification.+data OverlayEmbeddingObstruction+  = DraftReferenceMissing !DraftReference+  | VertexProjectionRefused !DraftVertexId !PointValidationError+  | RoundedVerticesCollide !DraftVertexId !DraftVertexId !Point+  | SplitOrderNotPreserved !DraftSourceId !DraftVertexId !DraftVertexId+  | IncidenceRelationChanged+      !DraftSegmentId+      !DraftSegmentId+      !SegmentRelation+      !SegmentRelation+      !SegmentRelation+  | NeighborhoodOrientationChanged+      !DraftVertexId+      !DraftVertexId+      !DraftVertexId+      !Ordering+      !Ordering+  | GlobalRelationAdded+      !DraftSegmentId+      !DraftSegmentId+      !SegmentRelation+  | GlobalRelationRemoved+      !DraftSegmentId+      !DraftSegmentId+      !SegmentRelation+  | GlobalRelationChanged+      !DraftSegmentId+      !DraftSegmentId+      !SegmentRelation+      !SegmentRelation+  | ProjectedSegmentCollapsed+      !DraftSegmentId+      !DraftVertexId+      !DraftVertexId+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | An embedding obligation not discharged by the bounded local certifier.+data EmbeddingObligation+  = GlobalNoNewCrossing+  deriving stock (Bounded, Enum, Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A nonempty collection of obligations deferred to a later owner.+newtype EmbeddingResidual = EmbeddingResidual (NonEmpty EmbeddingObligation)+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Read the obligations that remain explicitly undischarged.+residualUndischargedObligations+  :: EmbeddingResidual+  -> NonEmpty EmbeddingObligation+residualUndischargedObligations (EmbeddingResidual obligations) = obligations++-- | The Milestone 1 residual: the arrangement sweep has not yet proved global+-- absence of new crossings.+milestoneOneResidual :: EmbeddingResidual+milestoneOneResidual = EmbeddingResidual (GlobalNoNewCrossing :| [])++-- | A certificate for exactly four local obligations on a declared draft:+-- vertex distinctness, source split order, declared incidences, and local+-- neighborhood orientation. Global absence of new crossings is unproved until+-- the Milestone 2 arrangement sweep supplies the complete obligation set.+data LocalEmbeddingCertificate = LocalEmbeddingCertificate+  { -- | Number of rounded vertex-pair distinctness checks discharged.+    certificateRoundedVertexDistinctnessCount :: !Int+  , -- | Number of adjacent source split-order checks discharged.+    certificateSplitOrderPreservationCount :: !Int+  , -- | Number of declared incidence checks discharged.+    certificateIncidenceRelationPreservationCount :: !Int+  , -- | Number of consecutive neighborhood orientation checks discharged.+    certificateNeighborhoodOrientationStabilityCount :: !Int+  , -- | The candidate projection certified by the four local obligations.+    certificateRoundedVertices :: !(Map DraftVertexId Point)+  , -- | The necessarily nonempty global obligation residual.+    certificateResidual :: !EmbeddingResidual+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Certify the four bounded local embedding obligations, collecting every+-- witness within each obligation and preserving obligation order.+certifyLocalEmbedding+  :: ExactArrangementDraft+  -> Either (NonEmpty OverlayEmbeddingObstruction) LocalEmbeddingCertificate+certifyLocalEmbedding draft =+  case NonEmpty.nonEmpty (structuralObstructions draft) of+    Just obstructions -> Left obstructions+    Nothing ->+      case projectVertices (draftVertices draft) of+        Invalid obstructions -> Left obstructions+        Valid projectedVertices ->+          certifyProjectedDraft draft projectedVertices++data Validation value+  = Invalid !(NonEmpty OverlayEmbeddingObstruction)+  | Valid value++instance Functor Validation where+  fmap _ (Invalid obstructions) = Invalid obstructions+  fmap transform (Valid value) = Valid (transform value)++instance Applicative Validation where+  pure = Valid+  Invalid left <*> Invalid right = Invalid (left <> right)+  Invalid obstructions <*> Valid _ = Invalid obstructions+  Valid _ <*> Invalid obstructions = Invalid obstructions+  Valid transform <*> Valid value = Valid (transform value)++invalid :: OverlayEmbeddingObstruction -> Validation value+invalid obstruction = Invalid (obstruction :| [])++data ProjectedVertex = ProjectedVertex+  { projectedExactPoint :: !ExactPoint+  , projectedRoundedPoint :: !Point+  }++data ResolvedSegment = ResolvedSegment+  { resolvedSegmentId :: !DraftSegmentId+  , resolvedSegmentFrom :: !ResolvedVertex+  , resolvedSegmentTo :: !ResolvedVertex+  }++data ResolvedVertex = ResolvedVertex+  { resolvedVertexId :: !DraftVertexId+  , resolvedProjectedVertex :: !ProjectedVertex+  }++data ResolvedMembership = ResolvedMembership+  { resolvedMembershipParameter :: !ExactRational+  , resolvedMembershipVertex :: !ResolvedVertex+  }++structuralObstructions+  :: ExactArrangementDraft+  -> [OverlayEmbeddingObstruction]+structuralObstructions draft =+  segmentEndpointObstructions+    <> sourceMembershipObstructions+    <> incidenceObstructions+    <> neighborhoodObstructions+ where+  vertices = draftVertices draft+  segments = draftSegments draft+  missingVertex vertexId =+    [ DraftReferenceMissing (DraftVertexReference vertexId)+    | Map.notMember vertexId vertices+    ]+  missingSegment segmentId =+    [ DraftReferenceMissing (DraftSegmentReference segmentId)+    | Map.notMember segmentId segments+    ]+  segmentEndpointObstructions =+    concatMap+      (\(_, (from, to)) -> missingVertex from <> missingVertex to)+      (Map.toAscList segments)+  sourceMembershipObstructions =+    concatMap+      (concatMap (missingVertex . snd) . snd)+      (Map.toAscList (draftSourceMemberships draft))+  incidenceObstructions =+    concatMap+      ( \incidence ->+          missingSegment (draftIncidenceFirstSegment incidence)+            <> missingSegment (draftIncidenceSecondSegment incidence)+      )+      (draftIncidences draft)+  neighborhoodObstructions =+    concatMap+      ( \neighborhood ->+          missingVertex (draftNeighborhoodCenter neighborhood)+            <> concatMap missingVertex (draftNeighborhoodNeighbors neighborhood)+      )+      (draftNeighborhoods draft)++projectVertices+  :: Map DraftVertexId ExactPoint+  -> Validation (Map DraftVertexId ProjectedVertex)+projectVertices =+  Map.traverseWithKey+    ( \vertexId point ->+        case exactPointToEmbeddingCandidate point of+          Left projectionError ->+            invalid (VertexProjectionRefused vertexId projectionError)+          Right roundedPoint -> Valid (ProjectedVertex point roundedPoint)+    )++certifyProjectedDraft+  :: ExactArrangementDraft+  -> Map DraftVertexId ProjectedVertex+  -> Either (NonEmpty OverlayEmbeddingObstruction) LocalEmbeddingCertificate+certifyProjectedDraft draft projectedVertices =+  case resolvedFailures of+    Left obstruction -> Left (obstruction :| [])+    Right localFailures ->+      case NonEmpty.nonEmpty (collisionFailures <> localFailures) of+        Just obstructions -> Left obstructions+        Nothing ->+          Right+            LocalEmbeddingCertificate+              { certificateRoundedVertexDistinctnessCount = distinctnessCount+              , certificateSplitOrderPreservationCount = splitOrderCount+              , certificateIncidenceRelationPreservationCount = incidenceCount+              , certificateNeighborhoodOrientationStabilityCount = neighborhoodCount+              , certificateRoundedVertices = Map.map projectedRoundedPoint projectedVertices+              , certificateResidual = milestoneOneResidual+              }+ where+  collisionFailures = roundedVertexCollisionObstructions projectedVertices+  resolvedFailures = do+    splitFailures <- traverse (uncurry resolveSource) (Map.toAscList (draftSourceMemberships draft))+    incidenceFailures <- traverse resolveIncidence (draftIncidences draft)+    neighborhoodFailures <- traverse resolveNeighborhood (draftNeighborhoods draft)+    pure (concat splitFailures <> concat incidenceFailures <> concat neighborhoodFailures)+  resolveVertex vertexId =+    case Map.lookup vertexId projectedVertices of+      Nothing -> Left (DraftReferenceMissing (DraftVertexReference vertexId))+      Just projectedVertex -> Right (ResolvedVertex vertexId projectedVertex)+  resolveSegment segmentId =+    case Map.lookup segmentId (draftSegments draft) of+      Nothing -> Left (DraftReferenceMissing (DraftSegmentReference segmentId))+      Just (from, to) ->+        ResolvedSegment segmentId+          <$> resolveVertex from+          <*> resolveVertex to+  resolveSource sourceId memberships =+    splitOrderObstructions sourceId+      <$> traverse+        ( \(parameter, vertexId) ->+            ResolvedMembership parameter <$> resolveVertex vertexId+        )+        memberships+  resolveIncidence incidence =+    incidenceRelationObstructions+      (draftIncidenceRelation incidence)+      <$> resolveSegment (draftIncidenceFirstSegment incidence)+      <*> resolveSegment (draftIncidenceSecondSegment incidence)+  resolveNeighborhood neighborhood =+    neighborhoodOrientationObstructions+      <$> resolveVertex (draftNeighborhoodCenter neighborhood)+      <*> traverse resolveVertex (draftNeighborhoodNeighbors neighborhood)+  vertexCount = Map.size projectedVertices+  distinctnessCount = vertexCount * (vertexCount - 1) `quot` 2+  splitOrderCount =+    sum+      ( map+          (max 0 . subtract 1 . length)+          (Map.elems (draftSourceMemberships draft))+      )+  incidenceCount = length (draftIncidences draft)+  neighborhoodCount =+    sum+      ( map+          (length . draftNeighborhoodNeighbors)+          (draftNeighborhoods draft)+      )++roundedVertexCollisionObstructions+  :: Map DraftVertexId ProjectedVertex+  -> [OverlayEmbeddingObstruction]+roundedVertexCollisionObstructions projectedVertices =+  [ RoundedVerticesCollide leftId rightId roundedPoint+  | (roundedPoint, vertexIds) <- Map.toAscList verticesByRoundedPoint+  , (leftId : remainingIds) <- tails (sort vertexIds)+  , rightId <- remainingIds+  ]+ where+  verticesByRoundedPoint =+    Map.fromListWith (<>)+      [ (projectedRoundedPoint projectedVertex, [vertexId])+      | (vertexId, projectedVertex) <- Map.toAscList projectedVertices+      ]++splitOrderObstructions+  :: DraftSourceId+  -> [ResolvedMembership]+  -> [OverlayEmbeddingObstruction]+splitOrderObstructions sourceId memberships =+  case memberships of+    firstMembership : secondMembership : remainingMemberships ->+      let finalMembership =+            foldl' (\_ current -> current) secondMembership remainingMemberships+          sourceFrom = roundedMembershipPoint firstMembership+          sourceTo = roundedMembershipPoint finalMembership+       in [ SplitOrderNotPreserved+              sourceId+              (resolvedVertexId (resolvedMembershipVertex leftMembership))+              (resolvedVertexId (resolvedMembershipVertex rightMembership))+          | (leftMembership, rightMembership) <-+              zip+                memberships+                (drop 1 memberships)+          , compare+              (resolvedMembershipParameter leftMembership)+              (resolvedMembershipParameter rightMembership)+              /= roundedOrderAlong+                sourceFrom+                sourceTo+                (roundedMembershipPoint leftMembership)+                (roundedMembershipPoint rightMembership)+          ]+    _ -> []++roundedMembershipPoint :: ResolvedMembership -> Point+roundedMembershipPoint =+  projectedRoundedPoint+    . resolvedProjectedVertex+    . resolvedMembershipVertex++roundedOrderAlong :: Point -> Point -> Point -> Point -> Ordering+roundedOrderAlong+  (Point sourceFromX sourceFromY)+  (Point sourceToX sourceToY)+  (Point leftX leftY)+  (Point rightX rightY) =+    let directionX = sourceToX - sourceFromX+        directionY = sourceToY - sourceFromY+     in if abs directionX >= abs directionY+          then+            if directionX >= 0+              then compare leftX rightX+              else compare rightX leftX+          else+            if directionY >= 0+              then compare leftY rightY+              else compare rightY leftY++incidenceRelationObstructions+  :: SegmentRelation+  -> ResolvedSegment+  -> ResolvedSegment+  -> [OverlayEmbeddingObstruction]+incidenceRelationObstructions declaredRelation firstSegment secondSegment =+  [ IncidenceRelationChanged+      (resolvedSegmentId firstSegment)+      (resolvedSegmentId secondSegment)+      declaredRelation+      exactRelation+      roundedRelation+ | exactRelation /= declaredRelation || roundedRelation /= declaredRelation+  ]+ where+  exactRelation =+    relationFor exactSegmentRelation projectedExactPoint firstSegment secondSegment+  roundedRelation =+    relationFor Math.segmentRelation projectedRoundedPoint firstSegment secondSegment++relationFor+  :: (point -> point -> point -> point -> SegmentRelation)+  -> (ProjectedVertex -> point)+  -> ResolvedSegment+  -> ResolvedSegment+  -> SegmentRelation+relationFor relation project firstSegment secondSegment =+  relation+    (project (resolvedProjectedVertex (resolvedSegmentFrom firstSegment)))+    (project (resolvedProjectedVertex (resolvedSegmentTo firstSegment)))+    (project (resolvedProjectedVertex (resolvedSegmentFrom secondSegment)))+    (project (resolvedProjectedVertex (resolvedSegmentTo secondSegment)))++neighborhoodOrientationObstructions+  :: ResolvedVertex+  -> NonEmpty ResolvedVertex+  -> [OverlayEmbeddingObstruction]+neighborhoodOrientationObstructions center neighbors =+  [ NeighborhoodOrientationChanged+      (resolvedVertexId center)+      (resolvedVertexId leftNeighbor)+      (resolvedVertexId rightNeighbor)+      exactOrientation+      roundedOrientation+  | (leftNeighbor, rightNeighbor) <-+      cyclePairs neighbors+  , let exactOrientation =+          exactOrient2d+            (exactVertexPoint center)+            (exactVertexPoint leftNeighbor)+            (exactVertexPoint rightNeighbor)+        roundedOrientation =+          Math.orient2d+            (roundedVertexPoint center)+            (roundedVertexPoint leftNeighbor)+            (roundedVertexPoint rightNeighbor)+  , exactOrientation /= roundedOrientation+  ]++exactVertexPoint :: ResolvedVertex -> ExactPoint+exactVertexPoint = projectedExactPoint . resolvedProjectedVertex++roundedVertexPoint :: ResolvedVertex -> Point+roundedVertexPoint = projectedRoundedPoint . resolvedProjectedVertex
src-ffi/Moonlight/Triangulation/Foreign/ABI.hs view
@@ -399,6 +399,7 @@     T.FaceCapacityExceeded requested capacity -> indices 52 requested capacity     T.PayloadStorageFailure _ -> codeOnly 53     T.CoordinatePayloadCountMismatch coordinates payloads -> indices 54 coordinates payloads+    T.CircleSweepRequiresDenseStorage -> codeOnly 55   )     {obstructionMessage = show failure}  where
src-public/Moonlight/Triangulation.hs view
@@ -125,7 +125,7 @@   , constraintSegments   , unionConstrainedWith   , unionConstrained-  , joinSeparatedConstrainedWith+  , joinSeparatedConstrained   , extendConstrainedWith      -- * Refinement — budget-bounded, composed after any operation above rather@@ -166,6 +166,7 @@   , outerFace   , faceDirectedEdges   , faceVertices+  , innerFaceDirectedEdgeTriples   , innerFaceVertexTriples   , vertexOutgoingEdges   , numUndirectedEdges@@ -182,6 +183,130 @@   , LocationHint (..)   , facesAtEvenBarrierDepth +    -- ** Face regions and alpha filtration+  , FaceComponent+  , faceComponentFaces+  , BoundaryLoop+  , boundaryLoopVertices+  , RegionBoundary+  , regionBoundaryOuterLoop+  , regionBoundaryHoleLoops+  , BoundaryObstruction (..)+  , faceComponents+  , componentBoundary+  , RadiusSquared+  , RadiusSquaredError (..)+  , mkRadiusSquared+  , alphaShapeContainsFace++    -- * Exact planar regions — authoritative rational geometry, labelled+    -- overlay, closed cell selections, valuations, and polygonal morphology+  , ExactRational+  , ExactArithmeticError (..)+  , exactRational+  , exactRationalNumerator+  , exactRationalDenominator+  , ExactPoint+  , exactPoint+  , exactPointCoordinates+  , ExactSegment+  , ExactGeometryError (..)+  , exactSegment+  , exactSegmentEndpoints+  , exactPointFromPoint+  , exactPointFromQueryPoint+  , exactPointToEmbeddingCandidate+  , exactOrient2d+  , exactOnClosedSegment+  , SegmentRelation (..)+  , exactSegmentRelation+  , ExactIntersectionError (..)+  , exactLineIntersection+  , ExactLoop+  , exactLoop+  , exactLoopPoints+  , PolygonComponent+  , polygonComponent+  , polygonOuterLoop+  , polygonHoleLoops+  , PlanarRegion+  , planarRegion+  , planarRegionComponents+  , emptyPlanarRegion+  , RegionPointLocation (..)+  , regionPointLocation+  , PlanarLayer+  , planarLayerOutsideLabel+  , planarLayerRegions+  , planarLayer+  , planarLayerLabelAt+  , RegionValidationError (..)+  , RegionPublicationError (..)+  , labelledPlanarLayer+  , ExactCellSet+  , CellSelectionError (..)+  , exactCellSet+  , closeFaceCellSet+  , exactCellSetVertexCount+  , exactCellSetEdgeCount+  , exactCellSetFaceCount+  , foldExactCellVertices+  , foldExactCellEdges+  , foldExactCellFaces+  , OverlayResult+  , OverlayReceipt (..)+  , OverlayError (..)+  , OverlaySelectionKind (..)+  , OverlaySelectionError (..)+  , overlayLayers+  , overlayEmbeddedTriangulation+  , overlayReceipt+  , overlayCells+  , overlayArrangementVertices+  , overlayArrangementEdges+  , overlayPlanarLayer+  , overlaySelectedRegion+  , overlayClosedUnion+  , overlayClosedIntersection+  , overlayRegularizedDifference+  , EulerCharacteristic+  , eulerCharacteristicValue+  , ExactArea+  , exactAreaValue+  , ExactLengthTerm+  , lengthCoefficient+  , squaredLength+  , ExactLengthExpression+  , exactLengthTerms+  , CertifiedInterval (..)+  , ExactLengthMeasurement+  , exactLengthExpression+  , exactLengthBounds+  , PlanarValuations+  , valuationEuler+  , valuationArea+  , valuationIntrinsic1+  , ValuationError (..)+  , cellValuations+  , regionValuations+  , cellSetPerimeter+  , regionPerimeter+  , ConvexPolygon+  , convexPolygon+  , convexPolygonPoints+  , StructuringElement+  , structuringElement+  , MinkowskiOperation (..)+  , MinkowskiError (..)+  , MinkowskiReceipt (..)+  , convexMinkowskiSum+  , minkowskiSum+  , erodeBy+  , openWith+  , closeWith+  , polygonOffset+  , polygonInset+     -- * Discharge — the invariants the constructors guarantee, checkable on a     -- value built by any route; every violation is a value carrying its witness   , validateTriangulation@@ -194,10 +319,23 @@   , delaunayFromCoordinates   , delaunayGeometry   )+import Moonlight.Triangulation.CellSet+  ( CellSelectionError (..)+  , ExactCellSet+  , closeFaceCellSet+  , exactCellSet+  , exactCellSetEdgeCount+  , exactCellSetFaceCount+  , exactCellSetVertexCount+  , foldExactCellEdges+  , foldExactCellFaces+  , foldExactCellVertices+  ) import Moonlight.Triangulation.Dcel   ( destination   , faceDirectedEdges   , faceVertices+  , innerFaceDirectedEdgeTriples   , innerFaceVertexTriples   , incidentFace   , isBoundaryEdge@@ -214,7 +352,41 @@   , vertexPoint   , vertexPoints   )-import Moonlight.Triangulation.FloodFillIterator (facesAtEvenBarrierDepth)+import Moonlight.Triangulation.FloodFillIterator+  ( BoundaryLoop+  , BoundaryObstruction (..)+  , FaceComponent+  , RadiusSquared+  , RegionBoundary+  , RadiusSquaredError (..)+  , alphaShapeContainsFace+  , boundaryLoopVertices+  , componentBoundary+  , faceComponentFaces+  , faceComponents+  , facesAtEvenBarrierDepth+  , mkRadiusSquared+  , regionBoundaryHoleLoops+  , regionBoundaryOuterLoop+  )+import Moonlight.Triangulation.Exact+  ( ExactGeometryError (..)+  , ExactIntersectionError (..)+  , ExactPoint+  , ExactSegment+  , SegmentRelation (..)+  , exactLineIntersection+  , exactOnClosedSegment+  , exactOrient2d+  , exactPoint+  , exactPointCoordinates+  , exactPointFromPoint+  , exactPointFromQueryPoint+  , exactPointToEmbeddingCandidate+  , exactSegment+  , exactSegmentEndpoints+  , exactSegmentRelation+  ) import Moonlight.Triangulation.Handles.HandleDefs   ( DirectedEdgeId (..)   , FaceId (..)@@ -276,10 +448,17 @@ import Moonlight.Triangulation.Internal.Cdt.Union   ( constraintSegments   , extendConstrainedWith-  , joinSeparatedConstrainedWith+  , joinSeparatedConstrained   , unionConstrained   , unionConstrainedWith   )+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactArithmeticError (..)+  , ExactRational+  , exactRational+  , exactRationalDenominator+  , exactRationalNumerator+  ) import Moonlight.Triangulation.Internal.Representation   ( BuildResult   , ConstrainedDelaunayTriangulation@@ -328,7 +507,42 @@   , interpolateNearest   , nearestNeighbor   )+import Moonlight.Triangulation.Minkowski+  ( ConvexPolygon+  , MinkowskiError (..)+  , MinkowskiOperation (..)+  , MinkowskiReceipt (..)+  , StructuringElement+  , closeWith+  , convexMinkowskiSum+  , convexPolygon+  , convexPolygonPoints+  , erodeBy+  , minkowskiSum+  , openWith+  , polygonInset+  , polygonOffset+  , structuringElement+  ) import Moonlight.Triangulation.Math (mkQueryPoint)+import Moonlight.Triangulation.Overlay+  ( OverlayError (..)+  , OverlayReceipt (..)+  , OverlayResult+  , OverlaySelectionError (..)+  , OverlaySelectionKind (..)+  , overlayArrangementEdges+  , overlayArrangementVertices+  , overlayCells+  , overlayClosedIntersection+  , overlayClosedUnion+  , overlayEmbeddedTriangulation+  , overlayLayers+  , overlayPlanarLayer+  , overlayReceipt+  , overlayRegularizedDifference+  , overlaySelectedRegion+  ) import Moonlight.Triangulation.Payload (mapVertices) import Moonlight.Triangulation.JoinSemilattice (JoinSemilattice (..)) import Moonlight.Triangulation.Refinement@@ -338,6 +552,29 @@   , validateRefinementParameters   , withMinimumAngle   )+import Moonlight.Triangulation.Region+  ( ExactLoop+  , PlanarLayer+  , PlanarRegion+  , PolygonComponent+  , RegionPointLocation (..)+  , RegionPublicationError (..)+  , RegionValidationError (..)+  , emptyPlanarRegion+  , exactLoop+  , exactLoopPoints+  , labelledPlanarLayer+  , planarLayer+  , planarLayerLabelAt+  , planarLayerOutsideLabel+  , planarLayerRegions+  , planarRegion+  , planarRegionComponents+  , polygonComponent+  , polygonHoleLoops+  , polygonOuterLoop+  , regionPointLocation+  ) import Moonlight.Triangulation.SetAlgebra   ( difference   , intersection@@ -348,3 +585,27 @@   , unions   ) import Moonlight.Triangulation.Validation (validateTriangulation)+import Moonlight.Triangulation.Valuation+  ( CertifiedInterval (..)+  , EulerCharacteristic+  , ExactArea+  , ExactLengthExpression+  , ExactLengthMeasurement+  , ExactLengthTerm+  , PlanarValuations+  , ValuationError (..)+  , cellSetPerimeter+  , cellValuations+  , eulerCharacteristicValue+  , exactAreaValue+  , exactLengthBounds+  , exactLengthExpression+  , exactLengthTerms+  , lengthCoefficient+  , regionPerimeter+  , regionValuations+  , squaredLength+  , valuationArea+  , valuationEuler+  , valuationIntrinsic1+  )
src-serialize/Moonlight/Triangulation/Serialization.hs view
@@ -1,23 +1,29 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# 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 (..)+  ( DecodingBudget (..)+  , TrustedPayloadDecoders+  , trustedBinaryPayloadDecoders+  , SerializedCountKind (..)+  , SerializationError (..)   , serializationVersion   , encodeTriangulation   , decodeTriangulation   ) where -import Control.Monad (replicateM, unless, when)+import Control.Monad (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+  , bytesRead   , getDoublebe   , getWord16be   , getWord32be@@ -26,8 +32,7 @@   , runGetOrFail   ) import Data.Binary.Put-  ( Put-  , putDoublebe+  ( putDoublebe   , putWord16be   , putWord32be   , putWord64be@@ -39,13 +44,18 @@ 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.Set as Set 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.BoxedPaged+  ( boxedFill+  , boxedFromVector+  , boxedToVector+  ) import Moonlight.Triangulation.Internal.Paged (fromLocalVector, fromVector, toVector)+import Moonlight.Triangulation.Internal.PackedIndex (indexLimit) import Moonlight.Triangulation.Internal.PointIndex (buildPointIndex) import Moonlight.Triangulation.Handles.HandleDefs import Moonlight.Triangulation.Internal.Representation@@ -73,6 +83,49 @@   put (UndirectedEdgeId value) = putWord32be value   get = UndirectedEdgeId <$> getWord32be +-- | The finite resource envelope admitted by the canonical decoder. The byte+-- budget bounds the complete input before parsing; the element budget bounds+-- the total number of library-owned serialized section elements before any+-- section is allocated.+data DecodingBudget = DecodingBudget+  { decodingMaximumInputBytes :: !Word64+  , decodingMaximumSectionElements :: !Word64+  }+  deriving stock (Eq, Show)++-- | Evidence that the caller accepts the internal resource behavior of all+-- four payload decoders. The structural budget governs only containers owned+-- by this module; executable payload decoders require this separate trust law.+data TrustedPayloadDecoders vertex directed undirected face where+  TrustedBinaryPayloadDecoders+    :: ( Binary vertex+       , Binary directed+       , Binary undirected+       , Binary face+       )+    => TrustedPayloadDecoders vertex directed undirected face++-- | Explicitly trust the selected 'Binary' payload instances. This witness is+-- required because arbitrary instances may allocate independently of input+-- bytes; constructing it declares that the caller has audited that behavior.+trustedBinaryPayloadDecoders+  :: ( Binary vertex+     , Binary directed+     , Binary undirected+     , Binary face+     )+  => TrustedPayloadDecoders vertex directed undirected face+trustedBinaryPayloadDecoders = TrustedBinaryPayloadDecoders++-- | The structural count whose encoded value was outside the resident index+-- or allocation domain.+data SerializedCountKind+  = SerializedVertexCount+  | SerializedDirectedEdgeCount+  | SerializedFaceCount+  | SerializedConstraintCount+  deriving stock (Eq, Ord, Show)+ -- | Every way serialization refuses, each naming its witness. data SerializationError   = BinaryDecodeFailure !Int64 !String@@ -81,19 +134,15 @@   | 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+  | InputByteBudgetExceeded !Word64 !Word64+  | DecodedSectionBudgetExceeded !Word64 !Word64+  | EncodedCountExceedsInt !SerializedCountKind !Word64+  | EncodedCountExceedsPackedIndex !SerializedCountKind !Word64 !Word64+  | SerializedDirectedEdgeCountOdd !Word64+  | SerializedConstraintCountExceedsEdges !Word64 !Word64+  | SerializedPlanarCardinalityMismatch !Word64 !Word64 !Word64+  | SerializedFixedBodyTooShort !Word64 !Word64   | SerializedMissingOuterFace-  | SerializedFacePayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int   | InvalidSerializedPoint {-# UNPACK #-} !Int !PointValidationError   | NonCanonicalSerializedConstraintFlag !UndirectedEdgeId !Word8   | SerializedConstraintCountMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int@@ -106,7 +155,7 @@  -- | The envelope version this module writes. serializationVersion :: Word16-serializationVersion = 4+serializationVersion = 6  formatMagic :: Word64 formatMagic = 0x5350414445485307 -- "SPADEHS" + canonical geometry-owned format family@@ -125,55 +174,87 @@   putWord8 (modeTag (constraintModeValue (modeProxy triangulation)))   putWord8 binary64EncodingTag   let ElementDefaults directedDefault undirectedDefault faceDefault = triElementDefaults triangulation+      pointXs = toVector (triPointX triangulation)+      pointYs = toVector (triPointY triangulation)+      vertexDefault = boxedFill (triVertexData triangulation)+      vertexDataVector = boxedToVector (triVertexData triangulation)+      vertexOut = toVector (triVertexOut triangulation)+      topology = toVector (triHalfTopology triangulation)+      directedDataVector = boxedToVector (triDirectedData triangulation)+      undirectedDataVector = boxedToVector (triUndirectedData triangulation)+      faceEdge = toVector (triFaceEdge triangulation)+      faceDataVector = boxedToVector (triFaceData triangulation)+      constraints = toVector (triConstraint triangulation)+      vertexCount = U.length pointXs+      directedEdgeCount = U.length topology `quot` 4+      faceCount = U.length faceEdge+  -- Version 6 commits every structural count in one prefix. The decoder can+  -- prove their relationships and resource bounds before defaults, payloads,+  -- or section bodies are evaluated.+  putWord64be (fromIntegral vertexCount)+  putWord64be (fromIntegral directedEdgeCount)+  putWord64be (fromIntegral faceCount)+  putWord64be (fromIntegral (triConstraintCount 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))+  U.mapM_ putDoublebe pointXs+  U.mapM_ putDoublebe pointYs+  put vertexDefault+  V.mapM_ put vertexDataVector+  U.mapM_ putWord32be vertexOut   -- 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))+  let plane field = U.generate directedEdgeCount (\edge -> topology U.! (4 * edge + field))+  U.mapM_ putWord32be (plane 0)+  U.mapM_ putWord32be (plane 1)+  U.mapM_ putWord32be (plane 2)+  U.mapM_ putWord32be (plane 3)+  V.mapM_ put directedDataVector+  V.mapM_ put undirectedDataVector+  U.mapM_ putWord32be faceEdge+  V.mapM_ put faceDataVector+  U.mapM_ putWord8 constraints --- | 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.+-- | Decode one exact, versioned finite DCEL inside an explicit resource+-- envelope. Structural counts are read and reconciled before any default,+-- payload, or section body is decoded. Coordinate uniqueness and the complete+-- topology, geometry, and Delaunay/CDT invariants are checked before the opaque+-- value is returned.+--+-- The budget bounds the input and the containers owned by this module. The+-- required 'TrustedPayloadDecoders' witness separately records the caller's+-- decision that every selected payload decoder is internally resource-safe. decodeTriangulation   :: forall mode vertex directed undirected face.-     ( KnownConstraintMode mode-     , Binary vertex-     , Binary directed-     , Binary undirected-     , Binary face-     )-  => BL.ByteString+     KnownConstraintMode mode+  => DecodingBudget+  -> TrustedPayloadDecoders vertex directed undirected 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))+decodeTriangulation budget TrustedBinaryPayloadDecoders bytes+  | inputByteCount > decodingMaximumInputBytes budget =+      Left+        ( InputByteBudgetExceeded+            inputByteCount+            (decodingMaximumInputBytes budget)+        )+  | otherwise =+      case runGetOrFail (runExceptT getTriangulation) bytes of+        Left (_, offset, message) -> Left (BinaryDecodeFailure offset message)+        Right (_, _, Left failure) -> Left failure+        Right (trailing, _, Right triangulation)+          | not (BL.null trailing) -> Left (TrailingBytes (BL.length trailing))+          | otherwise ->+              case validateTriangulation triangulation of+                [] -> Right triangulation+                firstViolation : remainingViolations ->+                  Left (DecodedInvariantViolations (firstViolation :| remainingViolations))  where+  inputByteCount = fromIntegral (BL.length bytes)+   getTriangulation :: Decoder (Triangulation mode vertex directed undirected face)   getTriangulation = do     magic <- lift getWord64be@@ -186,51 +267,50 @@     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+    encodedVertexCount <- lift getWord64be+    encodedDirectedEdgeCount <- lift getWord64be+    encodedFaceCount <- lift getWord64be+    encodedConstraintCount <- lift getWord64be+    validateStructuralPrefix+      budget+      encodedVertexCount+      encodedDirectedEdgeCount+      encodedFaceCount+      encodedConstraintCount+    prefixByteCount <- fromIntegral <$> lift bytesRead+    let bodyByteCount = inputByteCount - prefixByteCount+        minimumBodyByteCount =+          minimumFixedBodyBytes+            encodedVertexCount+            encodedDirectedEdgeCount+            encodedFaceCount+    unless (bodyByteCount >= minimumBodyByteCount) $+      throwE (SerializedFixedBodyTooShort bodyByteCount minimumBodyByteCount) -    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+    let vertexCount = fromIntegral encodedVertexCount+        halfCount = fromIntegral encodedDirectedEdgeCount         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)+        faceCount = fromIntegral encodedFaceCount+        cachedConstraintCount = fromIntegral encodedConstraintCount+    defaults <- ElementDefaults <$> lift get <*> lift get <*> lift get+    pointXs <- U.replicateM vertexCount (lift getDoublebe)+    pointYs <- U.replicateM vertexCount (lift getDoublebe)+    vertexDefault <- lift get+    vertexDataVector <- V.replicateM vertexCount (lift get)+    vertexOut <- U.replicateM vertexCount (lift getWord32be)+    halfOrigin <- U.replicateM halfCount (lift getWord32be)+    halfNext <- U.replicateM halfCount (lift getWord32be)+    halfPrev <- U.replicateM halfCount (lift getWord32be)+    halfFace <- U.replicateM halfCount (lift getWord32be)+    directedDataVector <- V.replicateM halfCount (lift get)+    undirectedDataVector <- V.replicateM edgeCount (lift get)+    faceEdge <- U.replicateM faceCount (lift getWord32be)+    faceDataVector <- V.replicateM faceCount (lift get)+    constraints <- U.replicateM edgeCount (lift getWord8) +    let points = V.generate vertexCount (\index -> Point (pointXs U.! index) (pointYs U.! index))+    traverse_ (uncurry validateStoredPoint) (V.indexed 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) ->@@ -243,8 +323,7 @@     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+    let distinctPointCount = Set.size (V.foldl' (flip Set.insert) Set.empty points)     unless (distinctPointCount == vertexCount) (throwE (DuplicateSerializedCoordinates vertexCount distinctPointCount))      let pointXStore = fromLocalVector 0 pointXs@@ -271,7 +350,7 @@         , triPointY = pointYStore         , triPointIndex = buildPointIndex pointXStore pointYStore         , triVertexOut = fromLocalVector maxBound vertexOut-        , triVertexData = boxedFromVector Nothing vertexDataVector+        , triVertexData = boxedFromVector vertexDefault vertexDataVector         , triHalfTopology = topologyStore         , triDirectedData = boxedFromVector (Just (defaultDirectedEdgeData defaults)) directedDataVector         , triUndirectedData = boxedFromVector (Just (defaultUndirectedEdgeData defaults)) undirectedDataVector@@ -296,31 +375,84 @@ 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)+validateStructuralPrefix+  :: DecodingBudget+  -> Word64+  -> Word64+  -> Word64+  -> Word64+  -> Decoder ()+validateStructuralPrefix budget vertexCount directedEdgeCount faceCount constraintCount = do+  traverse_+    (uncurry validateEncodedCount)+    [ (SerializedVertexCount, vertexCount)+    , (SerializedDirectedEdgeCount, directedEdgeCount)+    , (SerializedFaceCount, faceCount)+    , (SerializedConstraintCount, constraintCount)+    ]+  unless (even directedEdgeCount) $+    throwE (SerializedDirectedEdgeCountOdd directedEdgeCount)+  unless (faceCount >= 1) (throwE SerializedMissingOuterFace)+  let undirectedEdgeCount = directedEdgeCount `quot` 2+  unless (constraintCount <= undirectedEdgeCount) $+    throwE+      ( SerializedConstraintCountExceedsEdges+          constraintCount+          undirectedEdgeCount+      )+  unless+    (planarCardinalityHolds vertexCount directedEdgeCount faceCount)+    ( throwE+        ( SerializedPlanarCardinalityMismatch+            vertexCount+            directedEdgeCount+            faceCount+        )+    )+  let sectionElements =+        4 * vertexCount+          + 6 * directedEdgeCount+          + 2 * faceCount+      maximumElements = decodingMaximumSectionElements budget+  when (sectionElements > maximumElements) $+    throwE (DecodedSectionBudgetExceeded sectionElements maximumElements) -putUVector :: U.Unbox a => (a -> Put) -> U.Vector a -> Put-putUVector putElement values = do-  putCount (fromIntegral (U.length values))-  U.mapM_ putElement values+validateEncodedCount :: SerializedCountKind -> Word64 -> Decoder ()+validateEncodedCount kind count = do+  when (count > fromIntegral (maxBound :: Int)) $+    throwE (EncodedCountExceedsInt kind count)+  when (count > maximumPackedElementCount) $+    throwE+      ( EncodedCountExceedsPackedIndex+          kind+          count+          maximumPackedElementCount+      ) -getUVector :: U.Unbox a => Decoder a -> Decoder (U.Vector a)-getUVector getElement = do-  count <- getCount-  U.fromList <$> replicateM count getElement+-- Each resident handle is a Word32 with @maxBound@ withheld as the optional+-- no-index marker. A count may include every remaining representable handle.+maximumPackedElementCount :: Word64+maximumPackedElementCount = fromIntegral indexLimit + 1 -putBoxedVector :: (a -> Put) -> V.Vector a -> Put-putBoxedVector putElement values = do-  putCount (fromIntegral (V.length values))-  V.mapM_ putElement values+-- Every resident triangulation is a connected planar straight-line graph.+-- Empty input has only the outer face; a bounded-face-free nonempty graph is the+-- collinear chain; otherwise Euler's law determines the edge count. All+-- arithmetic is safe after 'validateEncodedCount' bounds each term to the+-- packed-index domain.+planarCardinalityHolds :: Word64 -> Word64 -> Word64 -> Bool+planarCardinalityHolds vertexCount directedEdgeCount faceCount+  | vertexCount == 0 = directedEdgeCount == 0 && faceCount == 1+  | faceCount == 1 = directedEdgeCount == 2 * (vertexCount - 1)+  | vertexCount < 3 = False+  | otherwise =+      directedEdgeCount == 2 * (vertexCount + faceCount - 2) -getBoxedVector :: Decoder a -> Decoder (V.Vector a)-getBoxedVector getElement = do-  count <- getCount-  V.fromList <$> replicateM count getElement+-- The packed-index proof above bounds every term far below Word64 overflow.+-- Payloads and defaults have no format-level lower bound because lawful+-- 'Binary' decoders such as that for @()@ may consume zero bytes.+minimumFixedBodyBytes :: Word64 -> Word64 -> Word64 -> Word64+minimumFixedBodyBytes vertexCount directedEdgeCount faceCount =+  20 * vertexCount+    + 16 * directedEdgeCount+    + 4 * faceCount+    + directedEdgeCount `quot` 2
test/algebra/Main.hs view
@@ -1,9 +1,15 @@ module Main (main) where  import qualified Moonlight.Triangulation.AlgebraSpec as AlgebraSpec+import qualified Moonlight.Triangulation.MinkowskiSpec as MinkowskiSpec+import qualified Moonlight.Triangulation.RegionAlgebraSpec as RegionAlgebraSpec import qualified Moonlight.Triangulation.ScheduleAgreementSpec as ScheduleAgreementSpec+import qualified Moonlight.Triangulation.ValuationSpec as ValuationSpec  main :: IO () main = do   AlgebraSpec.tests+  RegionAlgebraSpec.tests+  ValuationSpec.tests+  MinkowskiSpec.tests   ScheduleAgreementSpec.tests
test/algebra/Moonlight/Triangulation/AlgebraFixtures.hs view
@@ -4,7 +4,15 @@   ( Mesh   , PointMesh   , meshOf+  , inputOrderedMeshOf   , pointMeshOf+  , integerPoint+  , rectangleComponent+  , rectangleRegion+  , polygonRegion+  , annulusRegion+  , insideLayer+  , overlayRegions   , operands   , separatedOperands   , cocircularRing@@ -25,28 +33,40 @@   ) where  import Data.List (sortBy)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe) import Data.Ord (comparing) import qualified Data.Set as Set import qualified Data.Vector as V import Data.Word (Word64) import Moonlight.Triangulation   ( DelaunayTriangulation+  , OverlayResult+  , PlanarLayer+  , PlanarRegion   , Point (Point)   , VertexId   , buildTriangulation   , canonicalize   , delaunay   , delaunayGeometry+  , exactLoop+  , mapVertices   , numFaces   , numUndirectedEdges   , numVertices+  , overlayLayers+  , planarLayer+  , planarRegion+  , polygonComponent   , undirectedEdges   , undirectedEndpoints   , unitElementDefaults   , vertexPoint   , vertices   )-import Support (requireRight)+import Support (integerPoint, rectangleComponent, rectangleLoop, requireRight)  -- | The carrier. Geometry and nothing else: no vertex payload to need a -- commutative combining rule, no element payloads to survive a rewrite that@@ -56,7 +76,7 @@ -- | 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)+type PointMesh = DelaunayTriangulation Point  -- ── operands ───────────────────────────────────────────────────────────────── @@ -106,7 +126,7 @@ -- they are geometrically identical and structurally distinct. operands :: IO [(String, Mesh)] operands = do-  let sites name = maybe [] id (lookup name families)+  let sites name = fromMaybe [] (lookup name families)       lattice = sites "lattice"   void' <- meshOf "void" []   single <- meshOf "single" (sites "single")@@ -153,10 +173,72 @@ meshOf label points =   requireRight ("build geometry " <> label) (delaunayGeometry (V.fromList points)) +-- | Build through the annotated entrance when a law deliberately needs the+-- physical numbering induced by input order. Geometry-only construction is+-- free to choose the cheaper numbering because it publishes no input mapping.+inputOrderedMeshOf :: String -> [Point] -> IO Mesh+inputOrderedMeshOf label points =+  mapVertices (const ()) . buildTriangulation+    <$> requireRight+          ("build input-ordered geometry " <> label)+          (delaunay unitElementDefaults (V.fromList points))+ pointMeshOf :: String -> [Point] -> IO PointMesh pointMeshOf label points =   buildTriangulation     <$> requireRight ("build " <> label) (delaunay unitElementDefaults (V.fromList points))++rectangleRegion :: Integer -> Integer -> Integer -> Integer -> IO PlanarRegion+rectangleRegion minimumX minimumY maximumX maximumY =+  rectangleComponent minimumX minimumY maximumX maximumY+    >>= requireRight "rectangle region" . planarRegion . (: [])++polygonRegion :: [(Integer, Integer)] -> IO PlanarRegion+polygonRegion coordinates =+  case map (uncurry integerPoint) coordinates of+    firstPoint : secondPoint : thirdPoint : remaining -> do+      loop <-+        requireRight+          "polygon loop"+          (exactLoop (firstPoint :| (secondPoint : thirdPoint : remaining)))+      component <- requireRight "polygon component" (polygonComponent loop [])+      requireRight "polygon region" (planarRegion [component])+    _ -> fail "polygon fixture requires at least three points"++annulusRegion+  :: (Integer, Integer, Integer, Integer)+  -> (Integer, Integer, Integer, Integer)+  -> IO PlanarRegion+annulusRegion+  (outerMinX, outerMinY, outerMaxX, outerMaxY)+  (holeMinX, holeMinY, holeMaxX, holeMaxY) = do+    outer <- rectangleLoop outerMinX outerMinY outerMaxX outerMaxY+    hole <-+      requireRight+        "annulus hole loop"+        ( exactLoop+            ( integerPoint holeMinX holeMinY+                :| [ integerPoint holeMinX holeMaxY+                   , integerPoint holeMaxX holeMaxY+                   , integerPoint holeMaxX holeMinY+                   ]+            )+        )+    component <- requireRight "annulus component" (polygonComponent outer [hole])+    requireRight "annulus region" (planarRegion [component])++insideLayer :: PlanarRegion -> IO (PlanarLayer Bool)+insideLayer region =+  requireRight "inside layer" (planarLayer False (Map.singleton True region))++overlayRegions+  :: PlanarRegion+  -> PlanarRegion+  -> IO (OverlayResult Bool Bool)+overlayRegions left right = do+  leftLayer <- insideLayer left+  rightLayer <- insideLayer right+  requireRight "region algebra overlay" (overlayLayers leftLayer rightLayer)  pointsOf :: [(Double, Double)] -> [Point] pointsOf keys = [Point x y | (x, y) <- keys]
test/algebra/Moonlight/Triangulation/AlgebraSpec.hs view
@@ -55,6 +55,7 @@   , collinearSites   , dedupeAscending   , edgeKeys+  , inputOrderedMeshOf   , latticeSites   , meshOf   , operands@@ -107,8 +108,10 @@   legacy <-     mapVertices (const ()) . buildTriangulation       <$> requireRight "annotated point construction" (delaunay unitElementDefaults coordinates)-  unless (geometry == legacy) $-    fail "delaunayGeometry disagreed with the existing point construction"+  assertMeshEquivalent+    "geometry-only construction agrees with annotated point construction"+    legacy+    geometry   annotated <-     buildTriangulation       <$> requireRight@@ -186,10 +189,10 @@ 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)+  first <- inputOrderedMeshOf "order-1" base+  second <- inputOrderedMeshOf "order-2" (scramble 0x1111 base)+  third <- inputOrderedMeshOf "order-3" (scramble 0x2222 base)+  fourth <- inputOrderedMeshOf "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)@@ -283,7 +286,7 @@     \(name, base) -> do       built <-         traverse-          (\(order, sites) -> (,) order <$> meshOf (name <> "/" <> order) sites)+          (\(order, sites) -> (,) order <$> inputOrderedMeshOf (name <> "/" <> order) sites)           [ ("input", base)           , ("ranked", dedupeAscending (sort [(x, y) | Point x y <- base]))           , ("reversed", reverse base)@@ -397,7 +400,7 @@       let ranked = dedupeAscending (sort [(x, y) | Point x y <- base])       meshes <-         traverse-          (\(order, sites) -> (,) order <$> meshOf (name <> "/" <> order) sites)+          (\(order, sites) -> (,) order <$> inputOrderedMeshOf (name <> "/" <> order) sites)           [ ("input", base)           , ("ranked", ranked)           , ("reversed", reverse base)@@ -564,7 +567,7 @@ testEmptySetIdentitiesPreserveVerbatim :: IO () testEmptySetIdentitiesPreserveVerbatim = do   let sites = scramble 0xE771D3 (randomSites 0xE771D4 48)-  mesh <- meshOf "verbatim empty identity source" sites+  mesh <- inputOrderedMeshOf "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"
+ test/algebra/Moonlight/Triangulation/MinkowskiSpec.hs view
@@ -0,0 +1,226 @@+-- | Exact convex convolution and residual-morphology laws.+module Moonlight.Triangulation.MinkowskiSpec (tests) where++import Moonlight.Triangulation.AlgebraFixtures+  ( annulusRegion+  , polygonRegion+  , rectangleComponent+  , rectangleRegion+  )+import Moonlight.Triangulation.Minkowski+  ( MinkowskiOperation (..)+  , closeWith+  , convexMinkowskiSum+  , convexPolygon+  , erodeBy+  , minkowskiGeneratedPieces+  , minkowskiOperation+  , minkowskiOverlayPasses+  , minkowskiSum+  , openWith+  , polygonOffset+  , structuringElement+  )+import Moonlight.Triangulation.Region+  ( PlanarRegion+  , emptyPlanarRegion+  , exactLoopPoints+  , planarRegion+  , planarRegionComponents+  , polygonOuterLoop+  )+import Moonlight.Triangulation.Valuation+  ( exactAreaValue+  , regionValuations+  , valuationArea+  )+import Support (assertEqual, requireRight)++tests :: IO ()+tests = do+  testConvexConvolution+  testGeneralAddition+  testConvexMorphology+  testGeneralErosion+  testHoledAndNeckedErosion+  putStrLn "minkowski: ok"++testConvexConvolution :: IO ()+testConvexConvolution = do+  leftComponent <- rectangleComponent 0 0 1 1+  rightComponent <- rectangleComponent 0 0 1 1+  left <-+    requireRight+      "left convex polygon"+      (convexPolygon (exactLoopPoints (polygonOuterLoop leftComponent)))+  right <-+    requireRight+      "right convex polygon"+      (convexPolygon (exactLoopPoints (polygonOuterLoop rightComponent)))+  let result = convexMinkowskiSum left right+  assertRegionArea "convex square sum" 4 result+  assertEqual+    "convex convolution is commutative after canonical publication"+    result+    (convexMinkowskiSum right left)++testGeneralAddition :: IO ()+testGeneralAddition = do+  first <- rectangleComponent 0 0 1 1+  second <- rectangleComponent 3 0 4 1+  disconnected <- requireRight "disconnected source" (planarRegion [first, second])+  kernel <- rectangleRegion 0 0 1 1+  (sumRegion, receipt) <-+    requireRight "general disconnected sum" (minkowskiSum disconnected kernel)+  assertEqual "general sum operation receipt" MinkowskiAddition (minkowskiOperation receipt)+  assertEqual "general sum generated one piece per source component" 2 (minkowskiGeneratedPieces receipt)+  assertEqual "general sum remains disconnected" 2 (length (planarRegionComponents sumRegion))+  assertRegionArea "general disconnected sum" 8 sumRegion+  (swapped, _) <- requireRight "swapped disconnected sum" (minkowskiSum kernel disconnected)+  assertEqual "general Minkowski sum is commutative" sumRegion swapped+  (annihilated, _) <-+    requireRight "empty Minkowski annihilator" (minkowskiSum disconnected emptyPlanarRegion)+  assertEqual "empty region annihilates Minkowski addition" emptyPlanarRegion annihilated+  firstRegion <- requireRight "first distributive operand" (planarRegion [first])+  secondRegion <- requireRight "second distributive operand" (planarRegion [second])+  (firstSum, _) <- requireRight "first distributed sum" (minkowskiSum firstRegion kernel)+  (secondSum, _) <- requireRight "second distributed sum" (minkowskiSum secondRegion kernel)+  distributed <-+    requireRight+      "distributed union"+      (planarRegion (planarRegionComponents firstSum <> planarRegionComponents secondSum))+  assertEqual "Minkowski addition distributes over disjoint union" distributed sumRegion++  associativityThird <- rectangleRegion (-2) 0 0 1+  (leftPair, _) <- requireRight "associative left pair" (minkowskiSum firstRegion kernel)+  (leftAssociated, _) <-+    requireRight "left-associated Minkowski sum" (minkowskiSum leftPair associativityThird)+  (rightPair, _) <- requireRight "associative right pair" (minkowskiSum kernel associativityThird)+  (rightAssociated, _) <-+    requireRight "right-associated Minkowski sum" (minkowskiSum firstRegion rightPair)+  assertEqual "Minkowski addition is associative" leftAssociated rightAssociated+  concave <-+    polygonRegion+      [ (0, 0), (3, 0), (3, 1), (1, 1), (1, 3), (0, 3) ]+  (concaveSum, concaveReceipt) <-+    requireRight "concave triangulated sum" (minkowskiSum concave kernel)+  expectedConcaveSum <-+    polygonRegion+      [ (0, 0), (4, 0), (4, 2), (2, 2), (2, 4), (0, 4) ]+  assertEqual "triangulated nonconvex sum" expectedConcaveSum concaveSum+  if minkowskiOverlayPasses concaveReceipt > 0+    then pure ()+    else fail "nonconvex addition bypassed CDT decomposition and overlay union"++testConvexMorphology :: IO ()+testConvexMorphology = do+  source <- rectangleRegion (-2) (-2) 2 2+  kernelComponent <- rectangleComponent (-1) (-1) 1 1+  kernelPolygon <-+    requireRight+      "centred square kernel"+      (convexPolygon (exactLoopPoints (polygonOuterLoop kernelComponent)))+  element <- requireRight "centred structuring element" (structuringElement kernelPolygon)+  (eroded, erosionReceipt) <- requireRight "convex erosion" (erodeBy element source)+  expectedErosion <- rectangleRegion (-1) (-1) 1 1+  assertEqual "convex support-half-plane erosion" expectedErosion eroded+  assertEqual "convex erosion needs no overlay" 0 (minkowskiOverlayPasses erosionReceipt)+  exactFitSource <- rectangleRegion (-1) (-1) 1 1+  (lowerDimensionalResidual, _) <-+    requireRight "exact-fit regularized erosion" (erodeBy element exactFitSource)+  assertEqual+    "point-only erosion residual regularizes to the empty polygonal region"+    emptyPlanarRegion+    lowerDimensionalResidual+  (emptyResidual, _) <- requireRight "empty source erosion" (erodeBy element emptyPlanarRegion)+  assertEqual "empty source erodes to empty" emptyPlanarRegion emptyResidual+  (expanded, _) <- requireRight "convex offset" (polygonOffset element source)+  expectedExpansion <- rectangleRegion (-3) (-3) 3 3+  assertEqual "convex offset" expectedExpansion expanded+  (opened, _) <- requireRight "convex opening" (openWith element source)+  assertEqual "convex opening is idempotent on the square" source opened+  (openedTwice, _) <- requireRight "second convex opening" (openWith element opened)+  assertEqual "opening is idempotent" opened openedTwice+  (closed, _) <- requireRight "convex closing" (closeWith element source)+  assertEqual "convex closing is idempotent on the square" source closed+  (closedTwice, _) <- requireRight "second convex closing" (closeWith element closed)+  assertEqual "closing is idempotent" closed closedTwice+  cornerKernelComponent <- rectangleComponent 0 0 1 1+  cornerKernel <-+    requireRight+      "corner-anchored kernel"+      (convexPolygon (exactLoopPoints (polygonOuterLoop cornerKernelComponent)))+  cornerElement <- requireRight "corner-anchored element" (structuringElement cornerKernel)+  cornerSource <- rectangleRegion 0 0 4 4+  (cornerErosion, _) <- requireRight "corner-anchored erosion" (erodeBy cornerElement cornerSource)+  expectedCornerErosion <- rectangleRegion 0 0 3 3+  assertEqual "kernel origin controls erosion translation" expectedCornerErosion cornerErosion++testGeneralErosion :: IO ()+testGeneralErosion = do+  left <- rectangleComponent 0 0 4 4+  right <- rectangleComponent 6 0 10 4+  source <- requireRight "two-component erosion source" (planarRegion [left, right])+  kernelComponent <- rectangleComponent (-1) (-1) 1 1+  kernelPolygon <-+    requireRight+      "general erosion kernel"+      (convexPolygon (exactLoopPoints (polygonOuterLoop kernelComponent)))+  element <- requireRight "general erosion element" (structuringElement kernelPolygon)+  (eroded, receipt) <- requireRight "general erosion" (erodeBy element source)+  expectedLeft <- rectangleComponent 1 1 3 3+  expectedRight <- rectangleComponent 7 1 9 3+  expected <- requireRight "expected general erosion" (planarRegion [expectedLeft, expectedRight])+  assertEqual "general residual erosion" expected eroded+  if minkowskiOverlayPasses receipt > 0+    then pure ()+    else fail "general erosion bypassed the overlay candidate arrangement"++testHoledAndNeckedErosion :: IO ()+testHoledAndNeckedErosion = do+  kernelComponent <- rectangleComponent (-1) (-1) 1 1+  kernelPolygon <-+    requireRight+      "holed erosion kernel"+      (convexPolygon (exactLoopPoints (polygonOuterLoop kernelComponent)))+  element <- requireRight "holed erosion element" (structuringElement kernelPolygon)+  sourceAnnulus <- annulusRegion (0, 0, 10, 10) (4, 4, 6, 6)+  expectedAnnulus <- annulusRegion (1, 1, 9, 9) (3, 3, 7, 7)+  (erodedAnnulus, _) <- requireRight "annulus erosion" (erodeBy element sourceAnnulus)+  assertEqual "erosion shrinks the outer boundary and expands holes" expectedAnnulus erodedAnnulus++  necked <-+    polygonRegion+      [ (0, 0)+      , (8, 0)+      , (8, 3)+      , (12, 3)+      , (12, 0)+      , (20, 0)+      , (20, 8)+      , (12, 8)+      , (12, 5)+      , (8, 5)+      , (8, 8)+      , (0, 8)+      ]+  wideKernelComponent <- rectangleComponent (-2) (-2) 2 2+  wideKernelPolygon <-+    requireRight+      "neck erosion kernel"+      (convexPolygon (exactLoopPoints (polygonOuterLoop wideKernelComponent)))+  wideElement <- requireRight "neck erosion element" (structuringElement wideKernelPolygon)+  (separated, _) <- requireRight "narrow-neck erosion" (erodeBy wideElement necked)+  expectedLeft <- rectangleComponent 2 2 6 6+  expectedRight <- rectangleComponent 14 2 18 6+  expectedSeparated <-+    requireRight "expected separated erosion" (planarRegion [expectedLeft, expectedRight])+  assertEqual "erosion removes a neck narrower than the kernel" expectedSeparated separated++assertRegionArea :: String -> Integer -> PlanarRegion -> IO ()+assertRegionArea label expected region = do+  valuations <- requireRight label (regionValuations region)+  assertEqual+    label+    (fromInteger expected)+    (exactAreaValue (valuationArea valuations))
+ test/algebra/Moonlight/Triangulation/RegionAlgebraSpec.hs view
@@ -0,0 +1,90 @@+-- | Facade-only laws for exact planar Boolean composition.+module Moonlight.Triangulation.RegionAlgebraSpec (tests) where++import Moonlight.Triangulation+import Moonlight.Triangulation.AlgebraFixtures+  ( overlayRegions+  , rectangleComponent+  , rectangleRegion+  )+import Support (assertEqual, requireRight)++tests :: IO ()+tests = do+  testRegionBooleanLaws+  testFacadeComposition+  putStrLn "region algebra: ok"++testRegionBooleanLaws :: IO ()+testRegionBooleanLaws = do+  left <- rectangleRegion 0 0 2 2+  middle <- rectangleRegion 1 0 3 2+  right <- rectangleRegion 2 0 4 2+  expectedUnion <- rectangleRegion 0 0 3 2+  expectedIntersection <- rectangleRegion 1 0 2 2+  expectedDifference <- rectangleRegion 0 0 1 2++  leftUnionMiddle <- regionUnion left middle+  middleUnionLeft <- regionUnion middle left+  assertEqual "region union result" expectedUnion leftUnionMiddle+  assertEqual "region union commutativity" leftUnionMiddle middleUnionLeft+  assertEqual "region union idempotence" left =<< regionUnion left left+  assertEqual+    "region intersection result"+    expectedIntersection+    =<< regionIntersection left middle+  assertEqual+    "regularized region difference"+    expectedDifference+    =<< regionDifference left middle++  leftAssociated <- regionUnion leftUnionMiddle right+  middleUnionRight <- regionUnion middle right+  rightAssociated <- regionUnion left middleUnionRight+  assertEqual "region union associativity" leftAssociated rightAssociated++testFacadeComposition :: IO ()+testFacadeComposition = do+  left <- rectangleRegion 0 0 2 2+  right <- rectangleRegion 1 0 3 2+  overlay <- overlayRegions left right+  selectedUnion <-+    requireRight+      "facade selected region"+      (overlaySelectedRegion (uncurry (||)) overlay)+  valuations <- requireRight "facade region valuations" (regionValuations selectedUnion)+  assertEqual+    "facade valuation digest"+    (1, 6)+    ( eulerCharacteristicValue (valuationEuler valuations)+    , exactAreaValue (valuationArea valuations)+    )++  kernelComponent <- rectangleComponent 0 0 1 1+  kernel <-+    requireRight+      "facade convex kernel"+      (convexPolygon (exactLoopPoints (polygonOuterLoop kernelComponent)))+  element <- requireRight "facade structuring element" (structuringElement kernel)+  (expanded, receipt) <- requireRight "facade polygon offset" (polygonOffset element selectedUnion)+  expectedExpanded <- rectangleRegion 0 0 4 3+  assertEqual "facade morphology result" expectedExpanded expanded+  assertEqual "facade morphology receipt" MinkowskiAddition (minkowskiOperation receipt)++regionUnion :: PlanarRegion -> PlanarRegion -> IO PlanarRegion+regionUnion = combineRegions (uncurry (||))++regionIntersection :: PlanarRegion -> PlanarRegion -> IO PlanarRegion+regionIntersection = combineRegions (uncurry (&&))++regionDifference :: PlanarRegion -> PlanarRegion -> IO PlanarRegion+regionDifference = combineRegions (\(insideLeft, insideRight) -> insideLeft && not insideRight)++combineRegions+  :: ((Bool, Bool) -> Bool)+  -> PlanarRegion+  -> PlanarRegion+  -> IO PlanarRegion+combineRegions selected left right = do+  overlay <- overlayRegions left right+  requireRight "region Boolean publication" (overlaySelectedRegion selected overlay)
+ test/algebra/Moonlight/Triangulation/ValuationSpec.hs view
@@ -0,0 +1,271 @@+-- | Exact intrinsic-volume fixtures and common-subdivision inclusion-exclusion.+module Moonlight.Triangulation.ValuationSpec (tests) where++import Moonlight.Triangulation.AlgebraFixtures+  ( annulusRegion+  , insideLayer+  , polygonRegion+  , rectangleComponent+  , rectangleRegion+  )+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactRational )+import Moonlight.Triangulation.Overlay+  ( overlayClosedIntersection+  , overlayClosedUnion+  , overlayLayers+  , overlaySelectedRegion+  )+import Moonlight.Triangulation.Region+  ( PlanarRegion+  , emptyPlanarRegion+  , planarRegion+  )+import Moonlight.Triangulation.Valuation+  ( CertifiedInterval (..)+  , ExactLengthTerm+  , PlanarValuations+  , ValuationError (ValuationCellSetNotPureRegion)+  , cellSetPerimeter+  , cellValuations+  , exactAreaValue+  , exactLengthBounds+  , exactLengthExpression+  , exactLengthTerms+  , eulerCharacteristicValue+  , lengthCoefficient+  , regionPerimeter+  , regionValuations+  , squaredLength+  , valuationArea+  , valuationEuler+  , valuationIntrinsic1+  )+import Support (assertEqual, requireRight)++tests :: IO ()+tests = do+  testRegionGoldenValues+  testClosedCellInclusionExclusion+  testDimensionalCellFixtures+  testMetricInvariance+  putStrLn "valuation: ok"++testRegionGoldenValues :: IO ()+testRegionGoldenValues = do+  assertRegionValuations "empty" emptyPlanarRegion 0 0 []++  unit <- rectangleRegion 0 0 1 1+  assertRegionValuations "unit square" unit 1 1 [(2, 1)]+  unitPerimeter <- requireRight "unit-square perimeter" (regionPerimeter unit)+  assertLength "unit-square perimeter" [(4, 1)] (exactLengthTerms (exactLengthExpression unitPerimeter))+  assertContains "unit-square perimeter bounds" 4 (exactLengthBounds unitPerimeter)++  annulus <- annulusRegion (0, 0, 3, 3) (1, 1, 2, 2)+  assertRegionValuations "annulus" annulus 0 8 [(2, 1), (2, 9)]++  lowerLeft <- rectangleComponent 0 0 1 1+  upperRight <- rectangleComponent 1 1 2 2+  cornerTouch <- requireRight "corner-touch region" (planarRegion [lowerLeft, upperRight])+  assertRegionValuations "corner-touch squares" cornerTouch 1 2 [(4, 1)]++  right <- rectangleComponent 1 0 2 1+  edgeTouch <- requireRight "edge-touch region" (planarRegion [lowerLeft, right])+  assertRegionValuations "edge-sharing squares" edgeTouch 1 2 [(3, 1)]++testClosedCellInclusionExclusion :: IO ()+testClosedCellInclusionExclusion = do+  leftRegion <- rectangleRegion 0 0 1 1+  rightRegion <- rectangleRegion 1 0 2 1+  leftLayer <- insideLayer leftRegion+  rightLayer <- insideLayer rightRegion+  overlay <- requireRight "edge-sharing valuation overlay" (overlayLayers leftLayer rightLayer)+  left <- requireRight "left closed cells" (overlayClosedUnion id (const False) overlay)+  right <- requireRight "right closed cells" (overlayClosedUnion (const False) id overlay)+  union <- requireRight "union closed cells" (overlayClosedUnion id id overlay)+  intersection <-+    requireRight+      "intersection closed cells"+      (overlayClosedIntersection id id overlay)+  leftValues <- requireRight "left valuations" (cellValuations left)+  rightValues <- requireRight "right valuations" (cellValuations right)+  unionValues <- requireRight "union valuations" (cellValuations union)+  sharedEdgeValues <- requireRight "intersection valuations" (cellValuations intersection)+  assertEqual+    "Euler inclusion-exclusion retains the shared edge"+    (1, 1, 1, 1)+    ( eulerCharacteristicValue (valuationEuler leftValues)+    , eulerCharacteristicValue (valuationEuler rightValues)+    , eulerCharacteristicValue (valuationEuler unionValues)+    , eulerCharacteristicValue (valuationEuler sharedEdgeValues)+    )+  assertEqual+    "area inclusion-exclusion retains zero-dimensional measure"+    ( 1+    , 1+    , 2+    , 0+    )+    ( areaExact leftValues+    , areaExact rightValues+    , areaExact unionValues+    , areaExact sharedEdgeValues+    )+  assertLength+    "left intrinsic one-volume"+    [(2, 1)]+    (exactLengthTerms (exactLengthExpression (valuationIntrinsic1 leftValues)))+  assertLength+    "right intrinsic one-volume"+    [(2, 1)]+    (exactLengthTerms (exactLengthExpression (valuationIntrinsic1 rightValues)))+  assertLength+    "union intrinsic one-volume"+    [(3, 1)]+    (exactLengthTerms (exactLengthExpression (valuationIntrinsic1 unionValues)))+  assertLength+    "shared-edge intrinsic one-volume"+    [(1, 1)]+    (exactLengthTerms (exactLengthExpression (valuationIntrinsic1 sharedEdgeValues)))+  case cellSetPerimeter intersection of+    Left ValuationCellSetNotPureRegion -> pure ()+    other ->+      fail+        ( "an isolated selected edge was accepted as a perimeter: "+            <> show other+        )+  published <-+    requireRight+      "published edge-sharing union"+      (overlaySelectedRegion (uncurry (||)) overlay)+  publishedValues <- requireRight "published union valuations" (regionValuations published)+  assertEqual+    "cell and published region valuations agree"+    (valuationDigest unionValues)+    (valuationDigest publishedValues)++testDimensionalCellFixtures :: IO ()+testDimensionalCellFixtures = do+  disjoint <- intersectionValues (0, 0, 1, 1) (2, 0, 3, 1)+  assertEqual+    "empty intersection valuations"+    (0, 0, [])+    (exactDigest disjoint)++  point <- intersectionValues (0, 0, 1, 1) (1, 1, 2, 2)+  assertEqual+    "point intersection valuations"+    (1, 0, [])+    (exactDigest point)++  area <- intersectionValues (0, 0, 2, 2) (1, 0, 3, 2)+  assertEqual+    "two-dimensional intersection valuations"+    ( 1+    , 2+    , [ (1, 1)+      , (1, 4)+      ]+    )+    (exactDigest area)++testMetricInvariance :: IO ()+testMetricInvariance = do+  original <- polygonRegion [(0, 0), (1, 0), (0, 1)]+  translated <- polygonRegion [(5, -3), (6, -3), (5, -2)]+  quarterTurned <- polygonRegion [(0, 0), (0, 1), (-1, 0)]+  originalValues <- requireRight "original triangle valuations" (regionValuations original)+  translatedValues <- requireRight "translated triangle valuations" (regionValuations translated)+  quarterTurnedValues <- requireRight "quarter-turned triangle valuations" (regionValuations quarterTurned)+  assertEqual "translation invariance" (exactDigest originalValues) (exactDigest translatedValues)+  assertEqual "quarter-turn invariance" (exactDigest originalValues) (exactDigest quarterTurnedValues)+  perimeter <- requireRight "irrational triangle perimeter" (regionPerimeter original)+  assertContains+    "certified radical perimeter"+    (2 + sqrt 2)+    (exactLengthBounds perimeter)++intersectionValues+  :: (Integer, Integer, Integer, Integer)+  -> (Integer, Integer, Integer, Integer)+  -> IO PlanarValuations+intersectionValues leftBounds rightBounds = do+  leftRegion <- uncurryRectangle leftBounds+  rightRegion <- uncurryRectangle rightBounds+  leftLayer <- insideLayer leftRegion+  rightLayer <- insideLayer rightRegion+  overlay <- requireRight "dimensional valuation overlay" (overlayLayers leftLayer rightLayer)+  selected <-+    requireRight+      "dimensional closed intersection"+      (overlayClosedIntersection id id overlay)+  requireRight "dimensional cell valuations" (cellValuations selected)++uncurryRectangle+  :: (Integer, Integer, Integer, Integer)+  -> IO PlanarRegion+uncurryRectangle (minimumX, minimumY, maximumX, maximumY) =+  rectangleRegion minimumX minimumY maximumX maximumY++assertRegionValuations+  :: String+  -> PlanarRegion+  -> Int+  -> Integer+  -> [(Integer, Integer)]+  -> IO ()+assertRegionValuations label region expectedEuler expectedArea expectedLength = do+  values <- requireRight label (regionValuations region)+  assertEqual+    (label <> " Euler")+    expectedEuler+    (eulerCharacteristicValue (valuationEuler values))+  assertEqual+    (label <> " area")+    (fromInteger expectedArea)+    (exactAreaValue (valuationArea values))+  assertLength+    (label <> " intrinsic one-volume")+    expectedLength+    (exactLengthTerms (exactLengthExpression (valuationIntrinsic1 values)))++assertLength :: String -> [(Integer, Integer)] -> [ExactLengthTerm] -> IO ()+assertLength label expected actual =+  assertEqual+    label+    [ (fromInteger coefficient, fromInteger square)+    | (coefficient, square) <- expected+    ]+    [ (lengthCoefficient term, squaredLength term)+    | term <- actual+    ]++assertContains :: String -> Double -> CertifiedInterval -> IO ()+assertContains label expected interval =+  if intervalLower interval <= expected && expected <= intervalUpper interval+    then pure ()+    else fail (label <> ": interval does not contain " <> show expected <> ": " <> show interval)++valuationDigest+  :: PlanarValuations+  -> (Int, ExactRational, CertifiedInterval)+valuationDigest values =+  ( eulerCharacteristicValue (valuationEuler values)+  , exactAreaValue (valuationArea values)+  , exactLengthBounds (valuationIntrinsic1 values)+  )++exactDigest+  :: PlanarValuations+  -> (Int, ExactRational, [(ExactRational, ExactRational)])+exactDigest values =+  ( eulerCharacteristicValue (valuationEuler values)+  , exactAreaValue (valuationArea values)+  , [ (lengthCoefficient term, squaredLength term)+    | term <- exactLengthTerms (exactLengthExpression (valuationIntrinsic1 values))+    ]+  )++areaExact :: PlanarValuations -> ExactRational+areaExact values =+  exactAreaValue (valuationArea values)
test/coherence/Main.hs view
@@ -4,10 +4,13 @@ module Main (main) where  import Moonlight.Triangulation.AlgebraSpec ()+import Moonlight.Triangulation.MinkowskiSpec () import Moonlight.Triangulation.NativeSpec () import Moonlight.Triangulation.ParallelSpec ()+import Moonlight.Triangulation.RegionAlgebraSpec () import Moonlight.Triangulation.ScheduleAgreementSpec () import Moonlight.Triangulation.SerializationSpec ()+import Moonlight.Triangulation.ValuationSpec ()  main :: IO () main = pure ()
test/native/Main.hs view
@@ -1,6 +1,13 @@ module Main (main) where +import qualified Moonlight.Triangulation.ExactEmbeddingSpec as ExactEmbeddingSpec import qualified Moonlight.Triangulation.NativeSpec as NativeSpec+import qualified Moonlight.Triangulation.OverlaySpec as OverlaySpec+import qualified Moonlight.Triangulation.RegionSpec as RegionSpec  main :: IO ()-main = NativeSpec.tests+main =+  NativeSpec.tests+    >> ExactEmbeddingSpec.tests+    >> OverlaySpec.tests+    >> RegionSpec.tests
+ test/native/Moonlight/Triangulation/ExactEmbeddingSpec.hs view
@@ -0,0 +1,591 @@+{-# LANGUAGE NumericUnderscores #-}++-- | Focused exact-geometry and local-embedding milestone acceptance.+module Moonlight.Triangulation.ExactEmbeddingSpec (tests) where++import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Monad (unless)+import Data.Bits (xor)+import Data.Foldable (traverse_)+import Data.List (sort)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Map.Strict as Map+import Data.Word (Word64)+import GHC.Stats (allocated_bytes, getRTSStats, getRTSStatsEnabled)+import Moonlight.Triangulation.Exact+  ( ExactGeometryError (..)+  , ExactIntersectionError (..)+  , ExactPoint+  , exactLineIntersection+  , exactPoint+  , exactPointCoordinates+  , exactPointFromPoint+  , exactPointToEmbeddingCandidate+  , exactSegment+  , exactSegmentRelation+  )+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactArithmeticError (..)+  , ExactRational+  , exactDivide+  , exactRational+  , exactRationalDenominator+  , exactRationalFromDouble+  , exactRationalNumerator+  , exactSignum+  )+import Moonlight.Triangulation.Internal.Overlay.Embedding+  ( DraftIncidence (..)+  , DraftNeighborhood (..)+  , DraftSegmentId (..)+  , DraftSourceId (..)+  , DraftVertexId (..)+  , EmbeddingObligation (..)+  , ExactArrangementDraft (..)+  , LocalEmbeddingCertificate (..)+  , OverlayEmbeddingObstruction (..)+  , certifyLocalEmbedding+  , residualUndischargedObligations+  )+import Moonlight.Triangulation.Math+  ( SegmentRelation (..)+  , allSegmentRelations+  , segmentRelation+  )+import Moonlight.Triangulation.Types+  ( CoordinateError (..)+  , Point (..)+  , PointValidationError (..)+  )+import Support (assertEqual, integerPoint, requireRight)+import System.Mem (performGC)++-- | Run the exact geometry, embedding, and frozen binary64 acceptance actions.+tests :: IO ()+tests =+  sequence_+    [ testExactNonDyadicCrossing+    , testAllSegmentRelationsAgree+    , testSubUlpExactVertexCluster+    , testContactDuplicateAndOverlapAgreement+    , testVerticalNestedOverlapRefusal+    , testCoordinateRefusalsAndRoundtrip+    , testExactArithmeticReceipt+    , testEmbeddingAdmissionReceipt+    , testOrdinaryDraftCertificate+    , testFrozenBinary64RelationOracle+    ]++testExactNonDyadicCrossing :: IO ()+testExactNonDyadicCrossing = do+  firstSegment <-+    requireRight+      "first non-dyadic crossing segment"+      (exactSegment (integerPoint 0 0) (integerPoint 1 1))+  secondSegment <-+    requireRight+      "second non-dyadic crossing segment"+      (exactSegment (integerPoint 0 1) (integerPoint 2 0))+  crossing <-+    requireRight+      "non-dyadic exact line intersection"+      (exactLineIntersection firstSegment secondSegment)+  let (crossingX, crossingY) = exactPointCoordinates crossing+  assertRatio "non-dyadic crossing x" 2 3 crossingX+  assertRatio "non-dyadic crossing y" 2 3 crossingY+  putStrLn+    ( "exact non-dyadic crossing coordinates: "+        <> show (exactRationalNumerator crossingX, exactRationalDenominator crossingX)+        <> ", "+        <> show (exactRationalNumerator crossingY, exactRationalDenominator crossingY)+    )++testAllSegmentRelationsAgree :: IO ()+testAllSegmentRelationsAgree = do+  observed <- traverse observeExactAndRounded handFixtures+  traverse_ assertExpectedAndAgreement observed+  assertEqual+    "all exact segment relations covered"+    allSegmentRelations+    (sort (map observedExactRelation observed))++testSubUlpExactVertexCluster :: IO ()+testSubUlpExactVertexCluster = do+  let base = 2 ^ (52 :: Int)+  firstCoordinate <- requireRight "first sub-ulp coordinate" (exactRational (base * 4 + 1) 4)+  secondCoordinate <- requireRight "second sub-ulp coordinate" (exactRational (base * 4 + 2) 4)+  thirdCoordinate <- requireRight "third sub-ulp coordinate" (exactRational (base * 4 + 3) 4)+  firstCrossing <- exactCrossingAt firstCoordinate+  secondCrossing <- exactCrossingAt secondCoordinate+  thirdCrossing <- exactCrossingAt thirdCoordinate+  let draft =+        emptyDraft+          { draftVertices =+              Map.fromList+                [ (DraftVertexId 0, firstCrossing)+                , (DraftVertexId 1, secondCrossing)+                , (DraftVertexId 2, thirdCrossing)+                ]+          }+  assertLeftContains+    "sub-ulp exact vertex cluster"+    isRoundedCollision+    (certifyLocalEmbedding draft)++testContactDuplicateAndOverlapAgreement :: IO ()+testContactDuplicateAndOverlapAgreement =+  traverse_ assertContactAgreement contactFixtures++testVerticalNestedOverlapRefusal :: IO ()+testVerticalNestedOverlapRefusal = do+  let base = 2 ^ (52 :: Int)+      zero = 0+      lower = fromInteger base+      upper = fromInteger (base + 1)+  innerLower <- requireRight "vertical inner lower" (exactRational (base * 3 + 1) 3)+  innerUpper <- requireRight "vertical inner upper" (exactRational (base * 3 + 2) 3)+  let outerFrom = exactPoint zero lower+      outerTo = exactPoint zero upper+      innerFrom = exactPoint zero innerLower+      innerTo = exactPoint zero innerUpper+      outerSegmentId = DraftSegmentId 0+      innerSegmentId = DraftSegmentId 1+      draft =+        emptyDraft+          { draftVertices =+              Map.fromList+                [ (DraftVertexId 0, outerFrom)+                , (DraftVertexId 1, outerTo)+                , (DraftVertexId 2, innerFrom)+                , (DraftVertexId 3, innerTo)+                ]+          , draftSegments =+              Map.fromList+                [ (outerSegmentId, (DraftVertexId 0, DraftVertexId 1))+                , (innerSegmentId, (DraftVertexId 2, DraftVertexId 3))+                ]+          , draftIncidences =+              [ DraftIncidence+                  outerSegmentId+                  innerSegmentId+                  SegmentsCollinearlyOverlap+              ]+          }+  assertEqual+    "vertical nested overlap remains exact"+    SegmentsCollinearlyOverlap+    (exactSegmentRelation outerFrom outerTo innerFrom innerTo)+  assertLeftContains+    "vertical nested overlap rounded incidence"+    isIncidenceChange+    (certifyLocalEmbedding draft)++testCoordinateRefusalsAndRoundtrip :: IO ()+testCoordinateRefusalsAndRoundtrip = do+  assertEqual+    "zero exact denominator refusal"+    (Left ExactZeroDenominator)+    (exactRational 1 0)+  assertEqual+    "zero exact divisor refusal"+    (Left ExactZeroDivisor)+    (exactDivide 1 0)+  normalized <- requireRight "normalized exact rational" (exactRational (-2) (-4))+  assertRatio "normalized exact rational" 1 2 normalized+  canonicalZero <- requireRight "canonical exact zero" (exactRational 0 (-7))+  assertRatio "canonical exact zero" 0 1 canonicalZero+  assertEqual+    "NaN exact rational refusal"+    (Left ExactNaNInput)+    (exactRationalFromDouble (0 / 0))+  assertEqual+    "infinite exact rational refusal"+    (Left ExactInfiniteInput)+    (exactRationalFromDouble (1 / 0))+  assertEqual+    "NaN exact point refusal"+    (Left (InvalidPointX CoordinateNaN))+    (exactPointFromPoint (Point (0 / 0) 0))+  assertEqual+    "infinite exact point refusal"+    (Left (InvalidPointX CoordinateInfinite))+    (exactPointFromPoint (Point (1 / 0) 0))+  let unprojectablePoint =+        exactPoint+          (fromInteger (10 ^ (400 :: Int)))+          0+      unprojectableDraft =+        emptyDraft+          { draftVertices =+              Map.singleton (DraftVertexId 0) unprojectablePoint+          }+  assertLeftContains+    "unprojectable exact draft vertex"+    isProjectionRefusal+    (certifyLocalEmbedding unprojectableDraft)+  let finitePoint = Point 1.25 (-2.5)+  exactFinite <- requireRight "finite point exact conversion" (exactPointFromPoint finitePoint)+  projectedFinite <-+    requireRight+      "finite point candidate projection"+      (exactPointToEmbeddingCandidate exactFinite)+  assertEqual "finite exact point roundtrip" finitePoint projectedFinite+  assertEqual+    "coincident exact segment endpoints"+    (Left (ExactSegmentEndpointsCoincide exactFinite))+    (exactSegment exactFinite exactFinite)+  duplicateSegment <-+    requireRight+      "duplicate line intersection segment"+      (exactSegment (integerPoint 0 0) (integerPoint 2 0))+  assertEqual+    "duplicate line intersection refusal"+    (Left (ExactIntersectionNonUnique SegmentsDuplicate))+    (exactLineIntersection duplicateSegment duplicateSegment)++testOrdinaryDraftCertificate :: IO ()+testOrdinaryDraftCertificate = do+  half <- requireRight "ordinary draft half parameter" (exactRational 1 2)+  let west = DraftVertexId 0+      center = DraftVertexId 1+      east = DraftVertexId 2+      south = DraftVertexId 3+      north = DraftVertexId 4+      westCenter = DraftSegmentId 0+      centerEast = DraftSegmentId 1+      southCenter = DraftSegmentId 2+      centerNorth = DraftSegmentId 3+      draft =+        ExactArrangementDraft+          { draftVertices =+              Map.fromList+                [ (west, integerPoint (-1) 0)+                , (center, integerPoint 0 0)+                , (east, integerPoint 1 0)+                , (south, integerPoint 0 (-1))+                , (north, integerPoint 0 1)+                ]+          , draftSegments =+              Map.fromList+                [ (westCenter, (west, center))+                , (centerEast, (center, east))+                , (southCenter, (south, center))+                , (centerNorth, (center, north))+                ]+          , draftSourceMemberships =+              Map.fromList+                [ ( DraftSourceId 0+                  , [ (0, west)+                    , (half, center)+                    , (1, east)+                    ]+                  )+                , ( DraftSourceId 1+                  , [ (0, south)+                    , (half, center)+                    , (1, north)+                    ]+                  )+                ]+          , draftIncidences =+              [ DraftIncidence westCenter southCenter SegmentsShareEndpoint+              ]+          , draftNeighborhoods =+              [ DraftNeighborhood center (east :| [north, west, south])+              ]+          }+  certificate <- requireRight "ordinary local embedding" (certifyLocalEmbedding draft)+  assertEqual+    "ordinary distinctness obligations"+    10+    (certificateRoundedVertexDistinctnessCount certificate)+  assertEqual+    "ordinary split-order obligations"+    4+    (certificateSplitOrderPreservationCount certificate)+  assertEqual+    "ordinary incidence obligations"+    1+    (certificateIncidenceRelationPreservationCount certificate)+  assertEqual+    "ordinary neighborhood obligations"+    4+    (certificateNeighborhoodOrientationStabilityCount certificate)+  assertEqual+    "ordinary residual"+    (GlobalNoNewCrossing :| [])+    (residualUndischargedObligations (certificateResidual certificate))+  putStrLn+    ( "local embedding certificate counts: "+        <> show+          ( certificateRoundedVertexDistinctnessCount certificate+          , certificateSplitOrderPreservationCount certificate+          , certificateIncidenceRelationPreservationCount certificate+          , certificateNeighborhoodOrientationStabilityCount certificate+          )+    )+  putStrLn+    ( "local embedding declared residual: "+        <> show (residualUndischargedObligations (certificateResidual certificate))+    )++testExactArithmeticReceipt :: IO ()+testExactArithmeticReceipt = do+  enabled <- getRTSStatsEnabled+  unless enabled $+    fail "exact arithmetic allocation receipt requires +RTS -T"+  operands <-+    traverse+      ( \index ->+          requireRight+            "exact arithmetic receipt operand"+            (exactRational (toInteger (index `mod` 89 + 1)) 97)+      )+      [0 .. 9_999 :: Int]+  _ <- evaluate (force operands)+  performGC+  before <- allocated_bytes <$> getRTSStats+  checksum <-+    evaluate+      ( force+          ( foldl'+              ( \accumulated value ->+                  accumulated+                    + fromEnum+                      ( exactSignum+                          ((value + 1) * value)+                      )+              )+              0+              operands+          )+      )+  performGC+  after <- allocated_bytes <$> getRTSStats+  let operationCount = 3 * length operands+      allocated = after - before+  unless (checksum > 0) $+    fail "exact arithmetic receipt did not force its operation chain"+  putStrLn+    ( "exact arithmetic receipt: operations="+        <> show operationCount+        <> " allocated-bytes="+        <> show allocated+        <> " checksum="+        <> show checksum+    )++testEmbeddingAdmissionReceipt :: IO ()+testEmbeddingAdmissionReceipt = do+  let base = 2 ^ (52 :: Int)+  firstCollision <- requireRight "admission receipt collision a" (exactRational (base * 4 + 1) 4)+  secondCollision <- requireRight "admission receipt collision b" (exactRational (base * 4 + 2) 4)+  let admittedDraft =+        emptyDraft+          { draftVertices =+              Map.fromList+                [ (DraftVertexId 0, integerPoint 0 0)+                , (DraftVertexId 1, integerPoint 1 0)+                ]+          }+      collisionDraft =+        emptyDraft+          { draftVertices =+              Map.fromList+                [ (DraftVertexId 0, exactPoint firstCollision 0)+                , (DraftVertexId 1, exactPoint secondCollision 0)+                ]+          }+      projectionDraft =+        emptyDraft+          { draftVertices =+              Map.singleton+                (DraftVertexId 0)+                (exactPoint (fromInteger (10 ^ (400 :: Int))) 0)+          }+      outcomes =+        map certifyLocalEmbedding [admittedDraft, collisionDraft, projectionDraft]+      admitted = length [() | Right _ <- outcomes]+      refused = length [() | Left _ <- outcomes]+  assertEqual "embedding admission receipt admissions" 1 admitted+  assertEqual "embedding admission receipt refusals" 2 refused+  putStrLn+    ( "embedding admission receipt: admitted="+        <> show admitted+        <> " refused="+        <> show refused+    )++testFrozenBinary64RelationOracle :: IO ()+testFrozenBinary64RelationOracle = do+  let observed =+        map+          ( \(name, expected, (a, b, c, d)) ->+              (name, expected, segmentRelation a b c d)+          )+          handFixtures+      relations =+        map (\(_, _, relation) -> relation) observed <> corpusRelations+  traverse_+    (\(name, expected, actual) -> assertEqual name expected actual)+    observed+  assertEqual "frozen relation count" 16_390 (length relations)+  assertEqual+    "frozen relation digest"+    1_170_735_657_727_369_596+    (digest relations)++data ObservedRelation = ObservedRelation+  { observedName :: !String+  , observedExpectedRelation :: !SegmentRelation+  , observedRoundedRelation :: !SegmentRelation+  , observedExactRelation :: !SegmentRelation+  }++observeExactAndRounded+  :: (String, SegmentRelation, (Point, Point, Point, Point))+  -> IO ObservedRelation+observeExactAndRounded (name, expected, points@(a, b, c, d)) = do+  (exactA, exactB, exactC, exactD) <- exactPointTuple points+  pure+    ObservedRelation+      { observedName = name+      , observedExpectedRelation = expected+      , observedRoundedRelation = segmentRelation a b c d+      , observedExactRelation = exactSegmentRelation exactA exactB exactC exactD+      }++assertExpectedAndAgreement :: ObservedRelation -> IO ()+assertExpectedAndAgreement observed = do+  assertEqual+    (observedName observed <> " binary64 expectation")+    (observedExpectedRelation observed)+    (observedRoundedRelation observed)+  assertEqual+    (observedName observed <> " exact agreement")+    (observedRoundedRelation observed)+    (observedExactRelation observed)++contactFixtures+  :: [(String, SegmentRelation, (Point, Point, Point, Point))]+contactFixtures =+  [ ( "endpoint-on-edge"+    , SegmentEndpointTouchesInterior+    , (Point 0 0, Point 2 0, Point 1 0, Point 1 1)+    )+  , ( "duplicate"+    , SegmentsDuplicate+    , (Point 0 0, Point 2 0, Point 2 0, Point 0 0)+    )+  , ( "partial-collinear-overlap"+    , SegmentsCollinearlyOverlap+    , (Point 0 0, Point 3 0, Point 1 0, Point 2 0)+    )+  ]++assertContactAgreement+  :: (String, SegmentRelation, (Point, Point, Point, Point))+  -> IO ()+assertContactAgreement fixture =+  observeExactAndRounded fixture >>= assertExpectedAndAgreement++exactPointTuple+  :: (Point, Point, Point, Point)+  -> IO (ExactPoint, ExactPoint, ExactPoint, ExactPoint)+exactPointTuple (a, b, c, d) =+  (,,,)+    <$> requireRight "exact fixture point a" (exactPointFromPoint a)+    <*> requireRight "exact fixture point b" (exactPointFromPoint b)+    <*> requireRight "exact fixture point c" (exactPointFromPoint c)+    <*> requireRight "exact fixture point d" (exactPointFromPoint d)++exactCrossingAt :: ExactRational -> IO ExactPoint+exactCrossingAt coordinate = do+  horizontal <-+    requireRight+      "sub-ulp horizontal crossing segment"+      ( exactSegment+          (exactPoint (coordinate - 1) coordinate)+          (exactPoint (coordinate + 1) coordinate)+      )+  vertical <-+    requireRight+      "sub-ulp vertical crossing segment"+      ( exactSegment+          (exactPoint coordinate (coordinate - 1))+          (exactPoint coordinate (coordinate + 1))+      )+  requireRight "sub-ulp exact crossing" (exactLineIntersection horizontal vertical)++assertRatio :: String -> Integer -> Integer -> ExactRational -> IO ()+assertRatio label numerator denominator value = do+  assertEqual (label <> " numerator") numerator (exactRationalNumerator value)+  assertEqual (label <> " denominator") denominator (exactRationalDenominator value)++emptyDraft :: ExactArrangementDraft+emptyDraft =+  ExactArrangementDraft+    { draftVertices = Map.empty+    , draftSegments = Map.empty+    , draftSourceMemberships = Map.empty+    , draftIncidences = []+    , draftNeighborhoods = []+    }++assertLeftContains+  :: String+  -> (OverlayEmbeddingObstruction -> Bool)+  -> Either (NonEmpty OverlayEmbeddingObstruction) value+  -> IO ()+assertLeftContains label predicate result =+  case result of+    Left obstructions ->+      unless (any predicate obstructions) $+        fail (label <> ": missing witness in " <> show obstructions)+    Right _ -> fail (label <> ": unexpectedly certified")++isRoundedCollision :: OverlayEmbeddingObstruction -> Bool+isRoundedCollision RoundedVerticesCollide {} = True+isRoundedCollision _ = False++isProjectionRefusal :: OverlayEmbeddingObstruction -> Bool+isProjectionRefusal VertexProjectionRefused {} = True+isProjectionRefusal _ = False++isIncidenceChange :: OverlayEmbeddingObstruction -> Bool+isIncidenceChange IncidenceRelationChanged {} = True+isIncidenceChange _ = False++handFixtures :: [(String, SegmentRelation, (Point, Point, Point, Point))]+handFixtures =+  [ ("disjoint", SegmentsDisjoint, (Point 0 0, Point 1 0, Point 0 2, Point 1 2))+  , ("duplicate", SegmentsDuplicate, (Point 0 0, Point 2 0, Point 2 0, Point 0 0))+  , ("shared-endpoint", SegmentsShareEndpoint, (Point 0 0, Point 2 0, Point 2 0, Point 3 1))+  , ("proper-crossing", SegmentsProperlyCross, (Point 0 0, Point 2 2, Point 0 2, Point 2 0))+  , ("endpoint-interior", SegmentEndpointTouchesInterior, (Point 0 0, Point 2 0, Point 1 0, Point 1 1))+  , ("collinear-overlap", SegmentsCollinearlyOverlap, (Point 0 0, Point 3 0, Point 1 0, Point 2 0))+  ]++corpusPoint :: Int -> Int -> Point+corpusPoint index salt =+  Point+    (fromIntegral (((index * 17 + salt * 11) `mod` 47) - 23))+    (fromIntegral (((index * 29 + salt * 7) `mod` 43) - 21))++corpusRelations :: [SegmentRelation]+corpusRelations =+  [ segmentRelation+      (corpusPoint index 1)+      (corpusPoint index 2)+      (corpusPoint index 3)+      (corpusPoint index 4)+  | index <- [0 .. 16_383]+  ]++digest :: [SegmentRelation] -> Word64+digest = foldl' step 14_695_981_039_346_656_037+ where+  step :: Word64 -> SegmentRelation -> Word64+  step hash relation =+    (hash `xor` fromIntegral (fromEnum relation + 1)) * 1_099_511_628_211
test/native/Moonlight/Triangulation/NativeSpec.hs view
@@ -7,13 +7,20 @@ {-# LANGUAGE MultiParamTypeClasses #-}  -- | The native core slice: everything that needs no serialization surface.-module Moonlight.Triangulation.NativeSpec (tests) where+module Moonlight.Triangulation.NativeSpec+  ( tests+  , regionMesh+  , regionMeshFromPoints+  , regionFaceSatisfies+  ) 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.Foldable (toList, traverse_)+import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isJust) import qualified Data.Map.Strict as Map import qualified Data.Set as Set@@ -102,6 +109,8 @@   testConstrainedRefinement   testCheckedLocalRefinement   testRepeatedBoundaryAdjacentRefinement+  testFaceComponentsAndBoundaries+  testAlphaFaceFiltration   testTraversal   testRandomizedConstruction   testErrors@@ -776,6 +785,10 @@   assertEqual "edge iterator" (numUndirectedEdges triangulation) (length (undirectedEdges triangulation))   assertEqual "face iterator" (numInnerFaces triangulation) (length (innerFaces triangulation))   assertEqual+    "dense inner-face directed-edge projection"+    (Just (V.toList (innerFaceDirectedEdgeTriples triangulation)))+    (traverse (Dcel.innerFaceDirectedEdges triangulation) (innerFaces triangulation))+  assertEqual     "dense inner-face projection"     (Just (V.toList (innerFaceVertexTriples triangulation)))     (traverse (Dcel.innerFaceVertices triangulation) (innerFaces triangulation))@@ -2198,7 +2211,7 @@   seam <-     requireRight       "source-preserving separated constrained seam"-      (joinSeparatedConstrainedWith Set.union left right)+      (joinSeparatedConstrained left right)   let joined = constrainedSeamResultTriangulation seam       joinedFaceKeys = Set.fromList (fmap (faceKeyOf joined) (innerFaces joined))       actualAnnotations =@@ -2267,13 +2280,13 @@   reversed <-     requireRight       "source-preserving reversed separated constrained seam"-      (joinSeparatedConstrainedWith Set.union right left)+      (joinSeparatedConstrained right left)   assertEqual     "reversing separated seam operands preserves the published constrained value"     joined     (constrainedSeamResultTriangulation reversed) -  case joinSeparatedConstrainedWith Set.union left left of+  case joinSeparatedConstrained left left of     Left ConstraintUnionNotSeparated -> pure ()     other -> fail ("non-separated constrained seam was not refused: " <> show other) @@ -2652,6 +2665,353 @@       points ->         sum [x | Point x _ <- points] / fromIntegral (length points) +testFaceComponentsAndBoundaries :: IO ()+testFaceComponentsAndBoundaries = do+  emptyBuild <- requirePointBuild "empty region components" []+  collinearBuild <-+    requirePointBuild+      "collinear region components"+      [Point 0 0, Point 1 0, Point 2 0]+  assertEqual+    "empty mesh has no face components"+    ([] :: [(Bool, FaceComponent)])+    (faceComponents (buildTriangulation emptyBuild) (const True))+  assertEqual+    "collinear mesh has no face components"+    ([] :: [(Bool, FaceComponent)])+    (faceComponents (buildTriangulation collinearBuild) (const True))++  triangle <-+    regionMeshFromPoints+      "single triangle region"+      [Point 0 0, Point 2 0, Point 0 2]+  triangleBoundary <-+    requireComponentBoundary "single triangle" True triangle (const True)+  assertBoundaryShape "single triangle" triangle 3 [] triangleBoundary++  square <-+    regionMeshFromPoints+      "uniform square region"+      [Point 0 0, Point 2 0, Point 2 2, Point 0 2]+  squareComponent <-+    requireLabelledComponent+      "uniform square component"+      True+      (faceComponents square (const True))+  assertEqual+    "component provenance mismatch is typed before DCEL lookup"+    (Left (BoundaryComponentFaceOutOfRange (FaceId 2) 2))+    (componentBoundary triangle squareComponent)+  squareBoundary <- requireRight "uniform square boundary" (componentBoundary square squareComponent)+  repeatedSquareBoundary <-+    requireRight "repeated uniform square boundary" (componentBoundary square squareComponent)+  assertEqual "boundary extraction is deterministic" squareBoundary repeatedSquareBoundary+  assertEqual+    "uniform square drops its Delaunay diagonal"+    (Set.fromList [Point 0 0, Point 2 0, Point 2 2, Point 0 2])+    (loopPointSet square (regionBoundaryOuterLoop squareBoundary))+  assertBoundaryShape "uniform square" square 4 [] squareBoundary++  let splitComponents =+        faceComponents square (regionFaceSatisfies square (\point -> pointX point < 1))+  assertEqual "split square component count" 2 (length splitComponents)+  traverse_+    (\(_, component) -> do+       boundary <- requireRight "split square boundary" (componentBoundary square component)+       assertBoundaryShape "split square component" square 3 [] boundary)+    splitComponents++  collinearHull <-+    regionMeshFromPoints+      "collinear hull simplification"+      [ Point 0 0+      , Point 1 0+      , Point 2 0+      , Point 2 2+      , Point 0 2+      , Point 1 1+      ]+  collinearBoundary <-+    requireComponentBoundary "collinear hull" True collinearHull (const True)+  assertEqual+    "exact simplification drops a redundant hull site"+    (Set.fromList [Point 0 0, Point 2 0, Point 2 2, Point 0 2])+    (loopPointSet collinearHull (regionBoundaryOuterLoop collinearBoundary))++  lShape <- regionMesh "concave L region" 2 2+  let inL = regionFaceSatisfies lShape (\(Point x y) -> not (x > 1 && y > 1))+  lBoundary <- requireComponentBoundary "concave L" True lShape inL+  assertEqual+    "concave L boundary"+    ( Set.fromList+        [ Point 0 0+        , Point 2 0+        , Point 2 1+        , Point 1 1+        , Point 1 2+        , Point 0 2+        ]+    )+    (loopPointSet lShape (regionBoundaryOuterLoop lBoundary))+  assertBoundaryShape "concave L" lShape 6 [] lBoundary++  annulus <- regionMesh "annulus region" 3 3+  let outsideCenter =+        regionFaceSatisfies annulus (\(Point x y) -> not (x > 1 && x < 2 && y > 1 && y < 2))+  annulusBoundary <-+    requireComponentBoundary "annulus outer" True annulus outsideCenter+  assertBoundaryShape "annulus" annulus 4 [4] annulusBoundary++  twoHoles <- regionMesh "ordered hole regions" 5 3+  let outsideTwoCells =+        regionFaceSatisfies twoHoles $ \(Point x y) ->+          let cell = (floor x :: Int, floor y :: Int)+           in cell /= (1, 1) && cell /= (3, 1)+  twoHoleBoundary <-+    requireComponentBoundary "two-hole outer" True twoHoles outsideTwoCells+  assertBoundaryShape "two-hole" twoHoles 4 [4, 4] twoHoleBoundary++  disconnected <- regionMesh "disconnected equal labels" 3 1+  let outsideMiddle =+        regionFaceSatisfies disconnected (\(Point x _) -> x < 1 || x > 2)+      disconnectedComponents = faceComponents disconnected outsideMiddle+      equalLabelComponents =+        [component | (True, component) <- disconnectedComponents]+  assertEqual "equal labels remain two disconnected components" 2 (length equalLabelComponents)+  assertEqual+    "face component order is deterministic"+    disconnectedComponents+    (faceComponents disconnected outsideMiddle)++  pinched <- regionMesh "pinched region" 3 3+  let pinchedSelection =+        regionFaceSatisfies pinched $ \(Point x y) ->+          let cell = (floor x :: Int, floor y :: Int)+           in cell /= (0, 0) && cell /= (1, 1)+  pinchedComponent <-+    requireLabelledComponent+      "pinched selected component"+      True+      (faceComponents pinched pinchedSelection)+  case componentBoundary pinched pinchedComponent of+    Left (BoundaryPinch vertex firstEdge secondEdge) -> do+      assertEqual "pinch vertex" (Point 1 1) (vertexPoint pinched vertex)+      when (firstEdge == secondEdge) $+        fail ("pinch repeated one outgoing edge: " <> show firstEdge)+    other -> fail ("pinched boundary produced " <> show other)++testAlphaFaceFiltration :: IO ()+testAlphaFaceFiltration = do+  triangle <-+    regionMeshFromPoints+      "alpha right triangle"+      [Point 0 0, Point 2 0, Point 0 2]+  face <- case innerFaces triangle of+    [singleFace] -> pure singleFace+    faces -> fail ("alpha fixture faces: " <> show faces)+  exactThreshold <- requireRight "exact alpha threshold" (mkRadiusSquared 2)+  lowerThreshold <- requireRight "lower alpha threshold" (mkRadiusSquared 1.999)+  zeroThreshold <- requireRight "zero alpha threshold" (mkRadiusSquared 0)+  assertEqual "zero alpha threshold excludes face" False+    (alphaShapeContainsFace zeroThreshold triangle face)+  assertEqual "closed alpha threshold includes equality" True (alphaShapeContainsFace exactThreshold triangle face)+  assertEqual "lower alpha threshold excludes face" False (alphaShapeContainsFace lowerThreshold triangle face)+  assertEqual "outer face is absent from alpha filtration" False (alphaShapeContainsFace exactThreshold triangle outerFace)++  let roundedPoints =+        ( Point (-20) (-20)+        , Point (-19) (-13)+        , Point (-2) (-19)+        )+      (roundedFirst, roundedSecond, roundedThird) = roundedPoints+      roundedRadiusSquared = 84.5+  roundedTriangle <-+    regionMeshFromPoints+      "rounded alpha equality"+      [roundedFirst, roundedSecond, roundedThird]+  roundedFace <- case innerFaces roundedTriangle of+    [singleFace] -> pure singleFace+    faces -> fail ("rounded alpha fixture faces: " <> show faces)+  roundedThreshold <-+    requireRight+      "rounded exact alpha threshold"+      (mkRadiusSquared roundedRadiusSquared)+  roundedLowerThreshold <-+    requireRight+      "rounded lower alpha threshold"+      (mkRadiusSquared (roundedRadiusSquared - encodeFloat 1 (-46)))+  assertEqual+    "closed alpha equality is exact"+    True+    (alphaShapeContainsFace roundedThreshold roundedTriangle roundedFace)+  assertEqual+    "one binary64 step below exact alpha equality is excluded"+    False+    (alphaShapeContainsFace roundedLowerThreshold roundedTriangle roundedFace)++  alphaBoundary <-+    requireComponentBoundary+      "alpha"+      True+      triangle+      (alphaShapeContainsFace exactThreshold triangle)+  assertBoundaryShape "alpha component" triangle 3 [] alphaBoundary++  annulus <-+    regionMeshFromPoints+      "alpha annulus"+      (ringPoints 4 32 <> ringPoints 2 16 <> ringPoints 3 24)+  annulusThreshold <-+    requireRight "alpha annulus threshold" (mkRadiusSquared 0.4)+  annulusBoundary <-+    requireComponentBoundary+      "alpha annulus"+      True+      annulus+      (alphaShapeContainsFace annulusThreshold annulus)+  assertEqual+    "alpha annulus hole count"+    1+    (length (regionBoundaryHoleLoops annulusBoundary))+  assertLoopWinding+    "alpha annulus outer winding"+    GT+    annulus+    (regionBoundaryOuterLoop annulusBoundary)+  traverse_+    (assertLoopWinding "alpha annulus hole winding" LT annulus)+    (regionBoundaryHoleLoops annulusBoundary)+  traverse_+    (\(label, value, failure) ->+       assertEqual label (Left failure) (mkRadiusSquared value))+    [ ("negative alpha threshold refusal", -1, NegativeRadiusSquared (-1))+    , ("NaN alpha threshold refusal", 0 / 0, NonFiniteRadiusSquared ValueNaN)+    , ("positive-infinite alpha threshold refusal", 1 / 0, NonFiniteRadiusSquared ValuePositiveInfinity)+    , ("negative-infinite alpha threshold refusal", (-1) / 0, NonFiniteRadiusSquared ValueNegativeInfinity)+    ]++ringPoints :: Double -> Int -> [Point]+ringPoints radius count =+  [ Point (radius * cos angle) (radius * sin angle)+  | index <- [0 .. count - 1]+  , let angle = 2 * pi * fromIntegral index / fromIntegral count+  ]++regionMesh :: String -> Int -> Int -> IO NativeMesh+regionMesh label widthInCells heightInCells =+  regionMeshFromPoints+    label+    [ Point (fromIntegral x) (fromIntegral y)+    | y <- [0 .. heightInCells]+    , x <- [0 .. widthInCells]+    ]++regionMeshFromPoints :: String -> [Point] -> IO NativeMesh+regionMeshFromPoints label points =+  buildTriangulation <$> requirePointBuild label points++regionFaceCentroid+  :: Triangulation mode vertex directed undirected face+  -> FaceId+  -> Maybe Point+regionFaceCentroid triangulation face =+  (\(first, second, third) ->+     centroid+       (vertexPoint triangulation first)+       (vertexPoint triangulation second)+       (vertexPoint triangulation third))+    <$> Dcel.innerFaceVertices triangulation face++regionFaceSatisfies+  :: Triangulation mode vertex directed undirected face+  -> (Point -> Bool)+  -> FaceId+  -> Bool+regionFaceSatisfies triangulation predicate =+  maybe False predicate . regionFaceCentroid triangulation++requireLabelledComponent+  :: (Eq label, Show label)+  => String+  -> label+  -> [(label, FaceComponent)]+  -> IO FaceComponent+requireLabelledComponent label expected components =+  case [component | (actual, component) <- components, actual == expected] of+    [component] -> pure component+    matches ->+      fail+        ( label+            <> ": expected one component for label "+            <> show expected+            <> ", got "+            <> show (length matches)+        )++requireComponentBoundary+  :: (Eq label, Show label)+  => String+  -> label+  -> Triangulation mode vertex directed undirected face+  -> (FaceId -> label)+  -> IO RegionBoundary+requireComponentBoundary label expected triangulation labelFace = do+  component <-+    requireLabelledComponent+      (label <> " component")+      expected+      (faceComponents triangulation labelFace)+  requireRight (label <> " boundary") (componentBoundary triangulation component)++loopPointSet+  :: Triangulation mode vertex directed undirected face+  -> BoundaryLoop+  -> Set.Set Point+loopPointSet triangulation =+  Set.fromList+    . fmap (vertexPoint triangulation)+    . toList+    . boundaryLoopVertices++assertLoopWinding+  :: String+  -> Ordering+  -> Triangulation mode vertex directed undirected face+  -> BoundaryLoop+  -> IO ()+assertLoopWinding label expected triangulation loop =+  let first :| remaining = fmap (vertexPoint triangulation) (boundaryLoopVertices loop)+      points = first : remaining+      twiceArea =+        sum+          ( zipWith+              (\(Point ax ay) (Point bx by) -> ax * by - ay * bx)+              points+              (remaining <> [first])+          )+   in assertEqual label expected (compare twiceArea 0)++assertBoundaryShape+  :: String+  -> Triangulation mode vertex directed undirected face+  -> Int+  -> [Int]+  -> RegionBoundary+  -> IO ()+assertBoundaryShape label triangulation outerVertexCount holeVertexCounts boundary = do+  assertEqual (label <> " outer vertex count") outerVertexCount+    (length (boundaryLoopVertices (regionBoundaryOuterLoop boundary)))+  assertLoopWinding (label <> " outer winding") GT triangulation+    (regionBoundaryOuterLoop boundary)+  let holes = regionBoundaryHoleLoops boundary+  assertEqual (label <> " hole count") (length holeVertexCounts) (length holes)+  traverse_+    (\(vertexCount, hole) -> do+       assertEqual (label <> " hole vertex count") vertexCount+         (length (boundaryLoopVertices hole))+       assertLoopWinding (label <> " hole winding") LT triangulation hole)+    (zip holeVertexCounts holes)+ 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]@@ -2675,19 +3035,19 @@   assertEqual "circle edge flood" bruteCircle circleEdges   assertEqual     "negative circle metric refusal"-    (Left (NegativeRadiusSquared (-1)))+    (Left (InvalidCircleRadius (NegativeRadiusSquared (-1))))     (circleMetric (Point 0 0 :: Point) (-1))   assertEqual     "negative circle edge-query refusal"-    (Left (NegativeRadiusSquared (-1)))+    (Left (InvalidCircleRadius (NegativeRadiusSquared (-1))))     (edgesInCircle triangulation (Point 0 0) (-1))   assertEqual     "negative circle vertex-query refusal"-    (Left (NegativeRadiusSquared (-1)))+    (Left (InvalidCircleRadius (NegativeRadiusSquared (-1))))     (verticesInCircle triangulation (Point 0 0) (-1))   assertEqual     "NaN circle metric refusal"-    (Left (NonFiniteRadiusSquared ValueNaN))+    (Left (InvalidCircleRadius (NonFiniteRadiusSquared ValueNaN)))     (circleMetric (Point 0 0 :: Point) (0 / 0))   assertEqual     "NaN circle center-x refusal"@@ -2703,11 +3063,11 @@     (verticesInCircle triangulation (Point ((-1) / 0) 0) 1)   assertEqual     "infinite circle edge-query refusal"-    (Left (NonFiniteRadiusSquared ValuePositiveInfinity))+    (Left (InvalidCircleRadius (NonFiniteRadiusSquared ValuePositiveInfinity)))     (edgesInCircle triangulation (Point 0 0) (1 / 0))   assertEqual     "negative-infinite circle vertex-query refusal"-    (Left (NonFiniteRadiusSquared ValueNegativeInfinity))+    (Left (InvalidCircleRadius (NonFiniteRadiusSquared ValueNegativeInfinity)))     (verticesInCircle triangulation (Point 0 0) ((-1) / 0))   rectangleVertices <-     Set.fromList
+ test/native/Moonlight/Triangulation/OverlaySpec.hs view
@@ -0,0 +1,776 @@+-- | Focused common-refinement, provenance, selector, and grouped-publication+-- acceptance.+module Moonlight.Triangulation.OverlaySpec (tests) where++import Control.Monad (foldM, unless, when)+import Data.Foldable (traverse_)+import qualified Data.Map.Strict as Map+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Set as Set+import qualified Data.Vector as V+import Moonlight.Triangulation.CellSet+  ( ExactCellSet+  , exactCellSetEdgeCount+  , exactCellSetFaceCount+  , exactCellSetVertexCount+  )+import Moonlight.Triangulation.Dcel+  ( faceData+  , isConstraintEdge+  , undirectedEdgeData+  , undirectedEndpoints+  , vertexData+  )+import Moonlight.Triangulation.Exact+  ( ExactPoint+  , ExactIntersectionError+  , ExactSegment+  , SegmentRelation (..)+  , exactLineIntersection+  , exactOnClosedSegment+  , exactPointCoordinates+  , exactSegment+  , exactSegmentEndpoints+  , exactSegmentRelation+  )+import Moonlight.Triangulation.Internal.ExactRational+  ( exactRationalDenominator+  )+import Moonlight.Triangulation.Internal.ExactSegmentEvents+  ( ExactSegmentEventPlan+  , ExactSweepSegmentId (..)+  , exactSegmentEventPlan+  , exactSegmentRelationMap+  , exactSegmentSplitPoints+  , exactSegmentSweepMaximumHeight+  )+import Moonlight.Triangulation.Handles.Iterators.FixedIterators+  ( innerFaces+  , undirectedEdges+  )+import Moonlight.Triangulation.Internal.Overlay.Arrangement (certifyArrangement)+import Moonlight.Triangulation.Internal.Overlay.Resident+  ( OverlayDiagonalSchedule (..)+  , residentOverlay+  )+import Moonlight.Triangulation.Overlay+import Moonlight.Triangulation.Region+import Support+  ( assertEqual+  , assertValid+  , integerPoint+  , rectangleComponent+  , requireRight+  )++tests :: IO ()+tests = do+  testExactSegmentEventPlan+  testOverlappingSquares+  testLowerDimensionalIntersections+  testSeamAndOverlapNormalization+  testOutsidePairRemainsImplicit+  testNestedAndNonDyadicOverlay+  testSelectorRefusalsAndOperandSwap+  testDisconnectedGroupedPublication+  testMultiwayPointBoundaryCycles+  testDiagonalScheduleIndependence++testExactSegmentEventPlan :: IO ()+testExactSegmentEventPlan = do+  sourceFixture <-+    traverse+      (uncurry integerSegment)+      [ ((0, 0), (4, 0))+      , ((4, 0), (0, 0))+      , ((2, 0), (6, 0))+      , ((4, 0), (4, 4))+      , ((1, -1), (1, 0))+      , ((0, -1), (4, 1))+      , ((10, 10), (11, 10))+      ]+  verticalAndMultiway <-+    traverse+      (uncurry integerSegment)+      [ ((0, -4), (0, 4))+      , ((-4, 0), (4, 0))+      , ((-3, -3), (3, 3))+      , ((-3, 3), (3, -3))+      , ((0, 1), (0, 5))+      , ((0, 4), (0, 7))+      ]+  grid <-+    traverse+      (uncurry integerSegment)+      ( [((-1, y), (5, y)) | y <- [0 .. 4]]+          <> [((x, -1), (x, 5)) | x <- [0 .. 4]]+      )+  collinearOverlaps <-+    traverse+      (uncurry integerSegment)+      [ ((0, 0), (8, 0))+      , ((1, 0), (3, 0))+      , ((2, 0), (6, 0))+      , ((5, 0), (9, 0))+      , ((8, 0), (10, 0))+      , ((11, 0), (12, 0))+      ]+  traverse_+    compareEventPlanWithOracle+    [sourceFixture, verticalAndMultiway, grid, collinearOverlaps]+  let allRelations =+        Set.fromList+          [ exactSegmentRelation a b c d+          | (leftIndex, left) <- zip [0 :: Int ..] sourceFixture+          , right <- drop (leftIndex + 1) sourceFixture+          , let (a, b) = exactSegmentEndpoints left+                (c, d) = exactSegmentEndpoints right+          ]+  assertEqual+    "source fixture covers every segment relation"+    ( Set.fromList+        [ SegmentsDisjoint+        , SegmentsProperlyCross+        , SegmentsShareEndpoint+        , SegmentEndpointTouchesInterior+        , SegmentsCollinearlyOverlap+        , SegmentsDuplicate+        ]+    )+    allRelations++compareEventPlanWithOracle :: [ExactSegment] -> IO ()+compareEventPlanWithOracle segments = do+  let vector = V.fromList segments+  plan <- requireRight "exact event sweep" (exactSegmentEventPlan vector)+  expectedSplits <- requireRight "quadratic split oracle" (quadraticSplitPoints segments)+  assertEqual+    "sweep relation map agrees with quadratic oracle"+    (quadraticRelationMap segments)+    (exactSegmentRelationMap plan)+  traverse_+    (assertSegmentSplits plan expectedSplits)+    [0 .. length segments - 1]+  let heightLimit = 2 * ceilingLog2 (length segments + 1)+  if exactSegmentSweepMaximumHeight plan <= heightLimit+    then pure ()+    else+      fail+        ( "AVL height exceeded conservative logarithmic bound: "+            <> show (exactSegmentSweepMaximumHeight plan, heightLimit)+        )++assertSegmentSplits+  :: ExactSegmentEventPlan+  -> Map.Map Int (Set.Set ExactPoint)+  -> Int+  -> IO ()+assertSegmentSplits plan expected segmentIndex =+  assertEqual+    ("sweep split points agree for segment " <> show segmentIndex)+    (Map.findWithDefault Set.empty segmentIndex expected)+    (Set.fromList (exactSegmentSplitPoints plan (ExactSweepSegmentId segmentIndex)))++quadraticRelationMap+  :: [ExactSegment]+  -> Map.Map (ExactSweepSegmentId, ExactSweepSegmentId) SegmentRelation+quadraticRelationMap segments =+  Map.fromList+    [ ((ExactSweepSegmentId leftIndex, ExactSweepSegmentId rightIndex), relation)+    | (leftIndex, left) <- zip [0 :: Int ..] segments+    , (rightIndex, right) <- zip [leftIndex + 1 ..] (drop (leftIndex + 1) segments)+    , let (a, b) = exactSegmentEndpoints left+          (c, d) = exactSegmentEndpoints right+          relation = exactSegmentRelation a b c d+    , relation /= SegmentsDisjoint+    ]++quadraticSplitPoints+  :: [ExactSegment]+  -> Either ExactIntersectionError (Map.Map Int (Set.Set ExactPoint))+quadraticSplitPoints segments =+  foldM addRelation initial (segmentPairs segments)+ where+  initial =+    Map.fromList+      [ (index, Set.fromList [from, to])+      | (index, segment) <- zip [0 :: Int ..] segments+      , let (from, to) = exactSegmentEndpoints segment+      ]+  addRelation+    :: Map.Map Int (Set.Set ExactPoint)+    -> (Int, ExactSegment, Int, ExactSegment)+    -> Either ExactIntersectionError (Map.Map Int (Set.Set ExactPoint))+  addRelation splitPoints (leftIndex, left, rightIndex, right) = do+    witnesses <- relationSplitWitnesses left right+    pure+      ( Map.insertWith Set.union rightIndex (Set.fromList witnesses)+          (Map.insertWith Set.union leftIndex (Set.fromList witnesses) splitPoints)+      )++segmentPairs :: [value] -> [(Int, value, Int, value)]+segmentPairs values =+  [ (leftIndex, left, rightIndex, right)+  | (leftIndex, left) <- zip [0 :: Int ..] values+  , (rightIndex, right) <- zip [leftIndex + 1 ..] (drop (leftIndex + 1) values)+  ]++relationSplitWitnesses+  :: ExactSegment+  -> ExactSegment+  -> Either ExactIntersectionError [ExactPoint]+relationSplitWitnesses left right =+  case exactSegmentRelation a b c d of+    SegmentsDisjoint -> Right []+    SegmentsProperlyCross -> (: []) <$> exactLineIntersection left right+    SegmentsDuplicate -> Right []+    _ ->+      Right+        ( Set.toAscList+            ( Set.fromList+                [ point+                | point <- [a, b, c, d]+                , exactOnClosedSegment a b point+                , exactOnClosedSegment c d point+                ]+            )+        )+ where+  (a, b) = exactSegmentEndpoints left+  (c, d) = exactSegmentEndpoints right++ceilingLog2 :: Int -> Int+ceilingLog2 target = length (takeWhile (< target) (iterate (* 2) 1))++integerSegment :: (Integer, Integer) -> (Integer, Integer) -> IO ExactSegment+integerSegment (fromX, fromY) (toX, toY) =+  requireRight+    "integer exact segment"+    (exactSegment (integerPoint fromX fromY) (integerPoint toX toY))++testOverlappingSquares :: IO ()+testOverlappingSquares = do+  left <- singletonSquareLayer "left-outside" "left" 0 0 2 2+  right <- singletonSquareLayer "right-outside" "right" 1 (-1) 3 1+  result <- requireRight "overlapping square overlay" (overlayLayers left right)+  assertOverlayIntegrity "overlapping square" result+  let receipt = overlayReceipt result+  assertEqual "overlay source segment count" 8 (overlayInputSegments receipt)+  assertEqual "overlay has two proper crossings" 2 (overlayExactCrossings receipt)+  when (overlayAtomicEdges receipt < 8) $+    fail ("overlay lost atomic edges: " <> show receipt)+  intersection <-+    requireRight+      "closed square intersection"+      (overlayClosedIntersection (== "left") (== "right") result)+  when+    ( exactCellSetVertexCount intersection < 4+        || exactCellSetEdgeCount intersection < 4+        || exactCellSetFaceCount intersection < 1+    )+    (fail "closed intersection omitted incidence closure")+  published <-+    requireRight+      "selected square intersection publication"+      (overlaySelectedRegion (== ("left", "right")) result)+  assertEqual+    "selected square intersection component count"+    1+    (length (planarRegionComponents published))+  assertEqual+    "unbounded selected publication refusal"+    (Left RegionUnboundedSelection)+    (overlaySelectedRegion (const True) result)+  merged <-+    requireRight+      "selected adjacent overlay cells merge"+      (overlaySelectedRegion (\(leftLabel, _) -> leftLabel == "left") result)+  assertEqual+    "selected adjacent overlay cells publish one component"+    [4]+    (map (length . exactLoopPoints . polygonOuterLoop) (planarRegionComponents merged))++testLowerDimensionalIntersections :: IO ()+testLowerDimensionalIntersections = do+  left <- singletonSquareLayer "left-outside" "left" 0 0 1 1+  pointTouching <- singletonSquareLayer "right-outside" "right" 1 1 2 2+  pointResult <- requireRight "point-touching overlay" (overlayLayers left pointTouching)+  assertOverlayIntegrity "point-touching" pointResult+  assertEqual+    "point-touching unbounded cell keeps two simple boundary cycles"+    (Just 2)+    (unboundedLoopCount pointResult)+  pointIntersection <-+    requireRight+      "point-only closed intersection"+      (overlayClosedIntersection (== "left") (== "right") pointResult)+  assertEqual+    "point-only closed intersection retains only its zero-cell"+    (1, 0, 0)+    ( exactCellSetVertexCount pointIntersection+    , exactCellSetEdgeCount pointIntersection+    , exactCellSetFaceCount pointIntersection+    )++  edgeTouching <- singletonSquareLayer "right-outside" "right" 1 0 2 1+  edgeResult <- requireRight "edge-touching overlay" (overlayLayers left edgeTouching)+  assertOverlayIntegrity "edge-touching" edgeResult+  edgeIntersection <-+    requireRight+      "edge-only closed intersection"+      (overlayClosedIntersection (== "left") (== "right") edgeResult)+  assertEqual+    "edge-only closed intersection retains its closure"+    (2, 1, 0)+    ( exactCellSetVertexCount edgeIntersection+    , exactCellSetEdgeCount edgeIntersection+    , exactCellSetFaceCount edgeIntersection+    )+  publishedEdgeOnly <-+    requireRight+      "edge-only polygon publication"+      (overlaySelectedRegion (== ("left", "right")) edgeResult)+  assertEqual+    "edge-only selection is not fabricated into a polygon"+    0+    (length (planarRegionComponents publishedEdgeOnly))++testSeamAndOverlapNormalization :: IO ()+testSeamAndOverlapNormalization = do+  first <- rectangleComponent 0 0 1 1+  second <- rectangleComponent 1 0 2 1+  joinedRegion <- requireRight "same-label joined region" (planarRegion [first, second])+  joinedLayer <-+    requireRight+      "same-label joined layer"+      (planarLayer "outside" (Map.singleton "inside" joinedRegion))+  emptyLayer <- requireRight "empty normalization layer" (planarLayer "void" Map.empty)+  seamResult <- requireRight "same-label seam overlay" (overlayLayers joinedLayer emptyLayer)+  assertOverlayIntegrity "same-label seam" seamResult+  assertEqual "joined rectangle has one unbounded boundary cycle" (Just 1) (unboundedLoopCount seamResult)+  assertEqual+    "same-label shared boundary is removed before topology"+    6+    (overlayAtomicEdges (overlayReceipt seamResult))+  let seamPublication = overlayPlanarLayer seamResult+  assertEqual+    "the implicit outside pair is never duplicated as a bounded layer key"+    Nothing+    ( Map.lookup+        ("outside", "void")+        (planarLayerRegions seamPublication)+    )+  assertEqual+    "same-label seam dissolves to the rectangle boundary"+    [4]+    ( map+        (length . exactLoopPoints . polygonOuterLoop)+        ( maybe+            []+            planarRegionComponents+            (Map.lookup ("inside", "void") (planarLayerRegions seamPublication))+        )+    )++  duplicateLeft <- singletonSquareLayer "left-outside" "left" 0 0 2 2+  duplicateRight <- singletonSquareLayer "right-outside" "right" 0 0 2 2+  duplicateResult <-+    requireRight "cross-operand duplicate boundary overlay" (overlayLayers duplicateLeft duplicateRight)+  assertOverlayIntegrity "duplicate boundary" duplicateResult+  assertEqual+    "duplicate boundaries normalize to one atomic cycle"+    4+    (overlayAtomicEdges (overlayReceipt duplicateResult))++  partialLeft <- singletonSquareLayer "left-outside" "left" 0 0 3 2+  partialRight <- singletonSquareLayer "right-outside" "right" 1 0 4 1+  partialResult <-+    requireRight "partial collinear overlap" (overlayLayers partialLeft partialRight)+  assertOverlayIntegrity "partial collinear overlap" partialResult+  if overlayOverlapIntervals (overlayReceipt partialResult) > 0+    then pure ()+    else fail "partial collinear overlap emitted no overlap event"++testOutsidePairRemainsImplicit :: IO ()+testOutsidePairRemainsImplicit = do+  outer <-+    requireRight+      "annulus outer loop"+      ( exactLoop+          ( integerPoint 0 0+              :| [integerPoint 4 0, integerPoint 4 4, integerPoint 0 4]+          )+      )+  hole <-+    requireRight+      "annulus hole loop"+      ( exactLoop+          ( integerPoint 1 1+              :| [integerPoint 1 3, integerPoint 3 3, integerPoint 3 1]+          )+      )+  component <- requireRight "annulus component" (polygonComponent outer [hole])+  region <- requireRight "annulus region" (planarRegion [component])+  left <-+    requireRight+      "annulus layer"+      (planarLayer "outside" (Map.singleton "annulus" region))+  right <- requireRight "annulus empty layer" (planarLayer "void" Map.empty)+  result <- requireRight "annulus overlay" (overlayLayers left right)+  let published = overlayPlanarLayer result+  assertEqual+    "bounded cavities remain represented by the implicit outside pair"+    Nothing+    ( Map.lookup+        ("outside", "void")+        (planarLayerRegions published)+    )++testSelectorRefusalsAndOperandSwap :: IO ()+testSelectorRefusalsAndOperandSwap = do+  left <- singletonSquareLayer "left-outside" "left" 0 0 2 2+  right <- singletonSquareLayer "right-outside" "right" 1 (-1) 3 1+  result <- requireRight "selector refusal overlay" (overlayLayers left right)+  assertSelectionRefusal+    "closed union refuses selected outside cell"+    (OverlaySelectionContainsUnboundedCell ClosedUnionSelection)+    (overlayClosedUnion (== "left-outside") (const False) result)+  assertSelectionRefusal+    "closed intersection refuses selected outside cell"+    (OverlaySelectionContainsUnboundedCell ClosedIntersectionSelection)+    ( overlayClosedIntersection+        (== "left-outside")+        (== "right-outside")+        result+    )+  assertSelectionRefusal+    "regularized difference refuses selected outside cell"+    (OverlaySelectionContainsUnboundedCell RegularizedDifferenceSelection)+    ( overlayRegularizedDifference+        (== "left-outside")+        (== "right")+        result+    )++  swapped <- requireRight "operand-swapped overlay" (overlayLayers right left)+  assertOverlayIntegrity "operand-swapped" swapped+  assertEqual+    "operand swap preserves exact arrangement vertices"+    (Set.fromList (map (overlayExactPoint . snd) (overlayArrangementVertices result)))+    (Set.fromList (map (overlayExactPoint . snd) (overlayArrangementVertices swapped)))+  assertEqual+    "operand swap preserves cells and exchanges labels"+    [ (overlayCellGeometry cell, (overlayCellRight cell, overlayCellLeft cell))+    | (_, cell) <- overlayCells result+    ]+    [ (overlayCellGeometry cell, (overlayCellLeft cell, overlayCellRight cell))+    | (_, cell) <- overlayCells swapped+    ]+  assertEqual+    "operand swap exchanges typed vertex provenance"+    (vertexOriginCensus True result)+    (vertexOriginCensus False swapped)++testNestedAndNonDyadicOverlay :: IO ()+testNestedAndNonDyadicOverlay = do+  outer <- singletonSquareLayer "left-outside" "left" 0 0 4 4+  inner <- singletonSquareLayer "right-outside" "right" 1 1 3 3+  nested <- requireRight "nested overlay" (overlayLayers outer inner)+  assertOverlayIntegrity "nested" nested+  assertEqual "nested overlay unbounded boundary is outermost only" (Just 1) (unboundedLoopCount nested)+  assertEqual+    "nested overlay has unbounded, shell, and intersection cells"+    3+    (length (overlayCells nested))++  leftTriangle <-+    triangleLayer+      "left-outside"+      "left"+      ((0, 0), (4, 0), (0, 4))+  rightTriangle <-+    triangleLayer+      "right-outside"+      "right"+      ((1, -1), (3, -1), (2, 2))+  nonDyadic <-+    requireRight "non-dyadic proper-crossing overlay" (overlayLayers leftTriangle rightTriangle)+  assertOverlayIntegrity "non-dyadic proper crossing" nonDyadic+  let hasNonDyadicCoordinate =+        any+          (\(_, vertex) ->+             let (x, y) = exactPointCoordinates (overlayExactPoint vertex)+              in any+                   (not . isPowerOfTwo . exactRationalDenominator)+                   [x, y])+          (overlayArrangementVertices nonDyadic)+  if overlayExactCrossings (overlayReceipt nonDyadic) > 0 && hasNonDyadicCoordinate+    then pure ()+    else fail "proper-crossing overlay lost its non-dyadic exact witness"++assertSelectionRefusal+  :: String+  -> OverlaySelectionError+  -> Either OverlaySelectionError ExactCellSet+  -> IO ()+assertSelectionRefusal label expected actual =+  case actual of+    Left obstruction -> assertEqual label expected obstruction+    Right _ -> fail (label <> ": unbounded selection was truncated")++testDisconnectedGroupedPublication :: IO ()+testDisconnectedGroupedPublication = do+  first <- rectangleComponent 0 0 1 1+  second <- rectangleComponent 3 0 4 1+  region <- requireRight "two-island region" (planarRegion [first, second])+  left <-+    requireRight+      "two-island layer"+      (planarLayer "outside" (Map.singleton "island" region))+  right <- requireRight "empty right layer" (planarLayer "void" Map.empty)+  result <- requireRight "two-island overlay" (overlayLayers left right)+  assertEqual "two islands give two unbounded boundary cycles" (Just 2) (unboundedLoopCount result)+  let published = overlayPlanarLayer result+  let components =+        maybe+          []+          planarRegionComponents+          (Map.lookup ("island", "void") (planarLayerRegions published))+  assertEqual "equal labels group after component descent" 2 (length components)+  reversedRegion <- requireRight "reversed two-island region" (planarRegion [second, first])+  reversedLeft <-+    requireRight+      "reversed two-island layer"+      (planarLayer "outside" (Map.singleton "island" reversedRegion))+  reversedResult <- requireRight "reversed two-island overlay" (overlayLayers reversedLeft right)+  assertEqual+    "component construction order cannot perturb stable cells"+    (overlayCells result)+    (overlayCells reversedResult)++testMultiwayPointBoundaryCycles :: IO ()+testMultiwayPointBoundaryCycles = do+  components <-+    traverse+      triangleComponent+      [ ((0, 0), (2, 0), (1, 1))+      , ((0, 0), (-1, 1), (-2, 0))+      , ((0, 0), (-1, -1), (1, -1))+      ]+  region <- requireRight "three point-touching components" (planarRegion components)+  left <-+    requireRight+      "three point-touching layer"+      (planarLayer "outside" (Map.singleton "inside" region))+  right <- requireRight "empty multiway right layer" (planarLayer "void" Map.empty)+  result <- requireRight "three-way point-touching overlay" (overlayLayers left right)+  assertOverlayIntegrity "three-way point-touching" result+  assertEqual+    "multiway point contact descends to three simple unbounded cycles"+    (Just 3)+    (unboundedLoopCount result)++testDiagonalScheduleIndependence :: IO ()+testDiagonalScheduleIndependence = do+  left <- singletonSquareLayer "outside" "inside" 0 0 2 2+  right <- requireRight "empty diagonal-policy layer" (planarLayer "void" Map.empty)+  certified <-+    requireRight+      "diagonal-policy arrangement certification"+      (certifyArrangement left right)+  canonical <-+    requireRight+      "canonical resident diagonal schedule"+      (residentOverlay CanonicalOverlayDiagonals ("outside", "void") certified)+  alternate <-+    requireRight+      "alternate resident diagonal schedule"+      (residentOverlay FlipFirstAdmissibleDiagonal ("outside", "void") certified)+  assertOverlayIntegrity "canonical diagonal schedule" canonical+  assertOverlayIntegrity "alternate diagonal schedule" alternate+  assertEqual+    "exact cells are independent of resident diagonal policy"+    (overlayCells canonical)+    (overlayCells alternate)+  when (residentDiagonalKeys canonical == residentDiagonalKeys alternate) $+    fail "alternate diagonal fixture did not change the resident topology"++residentDiagonalKeys+  :: OverlayResult leftLabel rightLabel+  -> Set.Set (ExactPoint, ExactPoint)+residentDiagonalKeys result =+  Set.fromList+    [ if fromPoint <= toPoint+        then (fromPoint, toPoint)+        else (toPoint, fromPoint)+    | edge <- undirectedEdges triangulation+    , OverlayDiagonal <- [undirectedEdgeData triangulation edge]+    , let (fromVertex, toVertex) = undirectedEndpoints triangulation edge+          fromPoint = overlayExactPoint (vertexData triangulation fromVertex)+          toPoint = overlayExactPoint (vertexData triangulation toVertex)+    ]+ where+  triangulation = overlayEmbeddedTriangulation result++assertOverlayIntegrity+  :: String+  -> OverlayResult leftLabel rightLabel+  -> IO ()+assertOverlayIntegrity label result = do+  let triangulation = overlayEmbeddedTriangulation result+      boundaryEdges = overlayArrangementEdges result+      cellIds = Set.fromList (map fst (overlayCells result))+      residentFaceIds =+        Set.fromList+          [ overlayFaceCellId (faceData triangulation face)+          | face <- innerFaces triangulation+          ]+  assertValid (label <> " embedded triangulation") triangulation+  assertEqual+    (label <> " atomic constraint correspondence")+    (overlayAtomicEdges (overlayReceipt result))+    (length boundaryEdges)+  unless (all (isConstraintEdge triangulation . fst) boundaryEdges) $+    fail (label <> ": boundary payload names an unconstrained edge")+  unless (residentFaceIds `Set.isSubsetOf` cellIds) $+    fail (label <> ": resident face names no exact cell")+  unless+    ( all+        (vertexOriginIsNonEmpty . overlayVertexOrigin . snd)+        (overlayArrangementVertices result)+    )+    (fail (label <> ": exact vertex lost all typed origins"))+  unless (all (edgeOriginIsNonEmpty . snd) boundaryEdges) $+    fail (label <> ": atomic edge lost all typed origins")+  atomicSegments <-+    traverse+      (\(edge, _) ->+         let (fromVertex, toVertex) = undirectedEndpoints triangulation edge+          in requireRight+               (label <> " atomic segment")+               ( exactSegment+                   (overlayExactPoint (vertexData triangulation fromVertex))+                   (overlayExactPoint (vertexData triangulation toVertex))+               ))+      boundaryEdges+  atomicPlan <-+    requireRight+      (label <> " atomic endpoint-incidence proof")+      (exactSegmentEventPlan (V.fromList atomicSegments))+  assertEqual+    (label <> " atomics have only endpoint-incidence relations")+    (endpointIncidenceRelations atomicSegments)+    (exactSegmentRelationMap atomicPlan)++endpointIncidenceRelations+  :: [ExactSegment]+  -> Map.Map (ExactSweepSegmentId, ExactSweepSegmentId) SegmentRelation+endpointIncidenceRelations segments =+  Map.fromList+    [ ( (ExactSweepSegmentId leftIndex, ExactSweepSegmentId rightIndex)+      , SegmentsShareEndpoint+      )+    | (leftIndex, left) <- zip [0 :: Int ..] segments+    , (rightIndex, right) <- zip [leftIndex + 1 ..] (drop (leftIndex + 1) segments)+    , let (leftFrom, leftTo) = exactSegmentEndpoints left+          (rightFrom, rightTo) = exactSegmentEndpoints right+    , not+        ( Set.null+            ( Set.intersection+                (Set.fromList [leftFrom, leftTo])+                (Set.fromList [rightFrom, rightTo])+            )+        )+    ]++vertexOriginIsNonEmpty :: OverlayVertexOrigin -> Bool+vertexOriginIsNonEmpty origin =+  not+    ( null (overlayOriginLeftVertices origin)+        && null (overlayOriginRightVertices origin)+        && null (overlayOriginLeftEdges origin)+        && null (overlayOriginRightEdges origin)+    )++edgeOriginIsNonEmpty :: OverlayEdgeOrigin -> Bool+edgeOriginIsNonEmpty origin =+  not+    (null (overlayEdgeLeftSources origin) && null (overlayEdgeRightSources origin))++vertexOriginCensus+  :: Bool+  -> OverlayResult String String+  -> Map.Map ExactPoint (Int, Int, Int, Int)+vertexOriginCensus preserveSides result =+  Map.fromList+    [ ( overlayExactPoint vertex+      , if preserveSides+          then census origin+          else swapCensus (census origin)+      )+    | (_, vertex) <- overlayArrangementVertices result+    , let origin = overlayVertexOrigin vertex+    ]+ where+  census :: OverlayVertexOrigin -> (Int, Int, Int, Int)+  census origin =+    ( length (overlayOriginLeftVertices origin)+    , length (overlayOriginRightVertices origin)+    , length (overlayOriginLeftEdges origin)+    , length (overlayOriginRightEdges origin)+    )+  swapCensus :: (Int, Int, Int, Int) -> (Int, Int, Int, Int)+  swapCensus (leftVertices, rightVertices, leftEdges, rightEdges) =+    (rightVertices, leftVertices, rightEdges, leftEdges)++unboundedLoopCount :: OverlayResult leftLabel rightLabel -> Maybe Int+unboundedLoopCount result =+  case+    [ length loops+    | (cellId, cell) <- overlayCells result+    , cellId == OverlayCellId 0+    , UnboundedOverlayCell loops <- [overlayCellGeometry cell]+    ] of+    [count] -> Just count+    _ -> Nothing++singletonSquareLayer+  :: String+  -> String+  -> Integer+  -> Integer+  -> Integer+  -> Integer+  -> IO (PlanarLayer String)+singletonSquareLayer outside inside minX minY maxX maxY = do+  component <- rectangleComponent minX minY maxX maxY+  region <- requireRight "singleton square region" (planarRegion [component])+  requireRight "singleton square layer" (planarLayer outside (Map.singleton inside region))++triangleLayer+  :: String+  -> String+  -> ((Integer, Integer), (Integer, Integer), (Integer, Integer))+  -> IO (PlanarLayer String)+triangleLayer outside inside (firstPoint, secondPoint, thirdPoint) = do+  component <- triangleComponent (firstPoint, secondPoint, thirdPoint)+  region <- requireRight "overlay triangle region" (planarRegion [component])+  requireRight "overlay triangle layer" (planarLayer outside (Map.singleton inside region))++triangleComponent+  :: ((Integer, Integer), (Integer, Integer), (Integer, Integer))+  -> IO PolygonComponent+triangleComponent (firstPoint, secondPoint, thirdPoint) = do+  loop <-+    requireRight+      "overlay triangle loop"+      ( exactLoop+          ( uncurry integerPoint firstPoint+              :| [uncurry integerPoint secondPoint, uncurry integerPoint thirdPoint]+          )+      )+  requireRight "overlay triangle component" (polygonComponent loop [])++isPowerOfTwo :: Integer -> Bool+isPowerOfTwo value =+  value > 0 && value `elem` takeWhile (<= value) (iterate (* 2) 1)
+ test/native/Moonlight/Triangulation/RegionSpec.hs view
@@ -0,0 +1,238 @@+-- | Focused exact-region authoring and ordinary publication acceptance.+module Moonlight.Triangulation.RegionSpec (tests) where++import qualified Data.Map.Strict as Map+import qualified Data.Vector as V+import Moonlight.Triangulation+  ( Point (..)+  , buildTriangulation+  , delaunay+  , unitElementDefaults+  )+import Moonlight.Triangulation.CellSet+  ( CellSelectionError (..)+  , closeFaceCellSet+  , exactCellSet+  , exactCellSetEdgeCount+  , exactCellSetFaceCount+  , exactCellSetVertexCount+  )+import Moonlight.Triangulation.Dcel (outerFace)+import Moonlight.Triangulation.Handles.Iterators.FixedIterators+  ( innerFaces+  , undirectedEdges+  )+import Moonlight.Triangulation.Internal.Region.Publication+  ( labelledPlanarLayerFromExactCoordinates+  )+import Moonlight.Triangulation.FloodFillIterator (BoundaryObstruction (BoundaryPinch))+import Moonlight.Triangulation.NativeSpec+  ( regionFaceSatisfies+  , regionMesh+  , regionMeshFromPoints+  )+import Moonlight.Triangulation.Region+import Support (assertEqual, integerPoint, rectangleComponent, requireRight)++tests :: IO ()+tests = do+  testExactAuthoring+  testOrdinaryPublication+  testExactCellSetAdmission+  testGroupedPublicationFixtures+  testPinchPublicationRefusal++testExactAuthoring :: IO ()+testExactAuthoring = do+  firstComponent <- rectangleComponent 0 0 2 2+  secondComponent <- rectangleComponent 4 0 5 1+  region <- requireRight "disconnected exact region" (planarRegion [firstComponent, secondComponent])+  layer <-+    requireRight+      "disconnected labelled layer"+      (planarLayer "outside" (Map.singleton "land" region))+  assertEqual+    "disconnected exact components remain separate"+    2+    ( maybe+        0+        (length . planarRegionComponents)+        (Map.lookup "land" (planarLayerRegions layer))+    )+  assertEqual+    "interior exact point location"+    RegionInterior+    (regionPointLocation region (integerPoint 1 1))+  assertEqual+    "exterior exact point location"+    RegionExterior+    (regionPointLocation region (integerPoint 3 1))++testOrdinaryPublication :: IO ()+testOrdinaryPublication = do+  built <-+    requireRight+      "ordinary square triangulation"+      ( delaunay+          unitElementDefaults+          (V.fromList [Point 0 0, Point 2 0, Point 2 2, Point 0 2])+      )+  layer <-+    requireRight+      "ordinary square labelled publication"+      (labelledPlanarLayer "outside" (buildTriangulation built) (const "inside"))+  case+    labelledPlanarLayerFromExactCoordinates+      "outside"+      (buildTriangulation built)+      (\vertex -> Left (RegionCoordinateMissing vertex))+      (const (Right "inside")) of+    Left (RegionCoordinateMissing _) -> pure ()+    other -> fail ("missing exact publication coordinate produced " <> show other)+  assertEqual+    "ordinary publication omits outside label"+    ["inside"]+    (Map.keys (planarLayerRegions layer))+  let components =+        maybe [] planarRegionComponents (Map.lookup "inside" (planarLayerRegions layer))+  assertEqual "ordinary square component count" 1 (length components)+  assertEqual+    "ordinary square drops resident diagonal"+    [4]+    (map (length . exactLoopPoints . polygonOuterLoop) components)++testExactCellSetAdmission :: IO ()+testExactCellSetAdmission = do+  built <-+    requireRight+      "cell-set triangle"+      (delaunay unitElementDefaults (V.fromList [Point 0 0, Point 2 0, Point 0 2]))+  let triangulation = buildTriangulation built+  face <-+    case innerFaces triangulation of+      [singleFace] -> pure singleFace+      faces -> fail ("cell-set triangle faces: " <> show faces)+  closed <- requireRight "closed face cell set" (closeFaceCellSet triangulation [face])+  assertEqual+    "face cell set carries its complete downward closure"+    (3, 3, 1)+    ( exactCellSetVertexCount closed+    , exactCellSetEdgeCount closed+    , exactCellSetFaceCount closed+    )+  case exactCellSet triangulation [] [] [outerFace] of+    Left CellOuterFaceSelected -> pure ()+    _ -> fail "cell set admitted the unbounded outer face"+  edge <-+    case undirectedEdges triangulation of+      firstEdge : _ -> pure firstEdge+      [] -> fail "cell-set triangle has no edge"+  case exactCellSet triangulation [] [edge] [] of+    Left (CellEdgeBoundaryMissing failedEdge _) ->+      assertEqual "edge closure witness" edge failedEdge+    _ -> fail "cell set admitted an edge without its boundary vertices"++testGroupedPublicationFixtures :: IO ()+testGroupedPublicationFixtures = do+  triangle <-+    regionMeshFromPoints+      "published single triangle"+      [Point 0 0, Point 2 0, Point 0 2]+  triangleLayer <-+    requireRight+      "published single triangle layer"+      (labelledPlanarLayer (0 :: Int) triangle (const 1))+  assertComponentShape "published single triangle" 1 3 [] triangleLayer++  concave <- regionMesh "published concave L" 2 2+  let concaveLabel =+        regionFaceSatisfies concave (\(Point x y) -> not (x > 1 && y > 1))+  concaveLayer <-+    requireRight+      "published concave L layer"+      (labelledPlanarLayer False concave concaveLabel)+  assertComponentShape "published concave L" True 6 [] concaveLayer++  annulus <- regionMesh "published annulus" 3 3+  let annulusLabel =+        regionFaceSatisfies annulus+          (\(Point x y) -> not (x > 1 && x < 2 && y > 1 && y < 2))+  annulusLayer <-+    requireRight+      "published annulus layer"+      (labelledPlanarLayer False annulus annulusLabel)+  assertComponentShape "published annulus" True 4 [4] annulusLayer++  twoHoles <- regionMesh "published two holes" 5 3+  let twoHoleLabel =+        regionFaceSatisfies twoHoles $ \(Point x y) ->+          let cell = (floor x :: Int, floor y :: Int)+           in cell /= (1, 1) && cell /= (3, 1)+  twoHoleLayer <-+    requireRight+      "published two-hole layer"+      (labelledPlanarLayer False twoHoles twoHoleLabel)+  assertComponentShape "published two holes" True 4 [4, 4] twoHoleLayer++  disconnected <- regionMesh "published disconnected islands" 3 1+  let islandLabel =+        regionFaceSatisfies disconnected (\(Point x _) -> x < 1 || x > 2)+  disconnectedLayer <-+    requireRight+      "published disconnected layer"+      (labelledPlanarLayer False disconnected islandLabel)+  assertEqual+    "published equal label keeps disconnected components"+    2+    (length (componentsFor True disconnectedLayer))++  islandInHole <- regionMesh "published island in hole" 3 3+  let islandInHoleLabel face =+        if regionFaceSatisfies islandInHole+             (\(Point x y) -> x > 1 && x < 2 && y > 1 && y < 2)+             face+          then (2 :: Int)+          else 1+  nestedLayer <-+    requireRight+      "published island-in-hole layer"+      (labelledPlanarLayer 0 islandInHole islandInHoleLabel)+  assertComponentShape "published shell around island" 1 4 [4] nestedLayer+  assertComponentShape "published island inside hole" 2 4 [] nestedLayer++testPinchPublicationRefusal :: IO ()+testPinchPublicationRefusal = do+  pinched <- regionMesh "published pinch" 3 3+  let selected =+        regionFaceSatisfies pinched $ \(Point x y) ->+          let cell = (floor x :: Int, floor y :: Int)+           in cell /= (0, 0) && cell /= (1, 1)+  case labelledPlanarLayer False pinched selected of+    Left (RegionBoundaryObstruction BoundaryPinch {}) -> pure ()+    other -> fail ("pinched publication produced " <> show other)++assertComponentShape+  :: Ord label+  => String+  -> label+  -> Int+  -> [Int]+  -> PlanarLayer label+  -> IO ()+assertComponentShape label regionLabel expectedOuterVertices expectedHoleVertices layer =+  case componentsFor regionLabel layer of+    [component] -> do+      assertEqual+        (label <> " outer vertices")+        expectedOuterVertices+        (length (exactLoopPoints (polygonOuterLoop component)))+      assertEqual+        (label <> " hole vertices")+        expectedHoleVertices+        (map (length . exactLoopPoints) (polygonHoleLoops component))+    components ->+      fail (label <> ": expected one component, got " <> show (length components))++componentsFor :: Ord label => label -> PlanarLayer label -> [PolygonComponent]+componentsFor label =+  maybe [] planarRegionComponents . Map.lookup label . planarLayerRegions
test/serialization/Moonlight/Triangulation/SerializationSpec.hs view
@@ -1,26 +1,34 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# 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 Control.Monad (unless) import Data.Binary (Binary)+import Data.Binary.Put (putWord16be, putWord64be, runPut) import qualified Data.ByteString.Lazy as BL+import Data.Foldable (traverse_) import qualified Data.Vector as V+import Data.Word (Word16, Word64) import GHC.Generics (Generic) import Moonlight.Triangulation import Moonlight.Triangulation.Serialization+import Moonlight.Triangulation.Types (KnownConstraintMode) import Support (assertEqual, assertValid, requireRight)  tests :: IO () tests = do   testRoundTrip+  testDegenerateCardinalityRoundTrips+  testConstrainedRoundTrip   testIndependentPayloadGeometryRoundTrip   testPointPayloadRoundTrip+  testRejectsHostileStructuralPrefixes   testRejectsCorruption   putStrLn "all serialization tests passed" @@ -36,6 +44,13 @@  type SerialTriangulation = Triangulation 'Unconstrained SerialVertex Int Bool String +testDecodingBudget :: DecodingBudget+testDecodingBudget =+  DecodingBudget+    { decodingMaximumInputBytes = 10_000_000+    , decodingMaximumSectionElements = 10_000_000+    }+ source :: IO SerialTriangulation source = do   let defaults = ElementDefaults (3 :: Int) True ("face" :: String)@@ -53,10 +68,35 @@   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+  assertSerializationRoundTrip "serialization" original +testDegenerateCardinalityRoundTrips :: IO ()+testDegenerateCardinalityRoundTrips =+  traverse_+    roundTripGeometry+    [ ("empty", V.empty)+    , ("singleton", V.singleton (Point 0 0))+    , ("segment", V.fromList [Point 0 0, Point 1 0])+    , ("collinear chain", V.fromList [Point 0 0, Point 1 0, Point 2 0, Point 3 0])+    ]+ where+  roundTripGeometry (label, points) = do+    original <- requireRight (label <> " serialization source") (delaunayGeometry points)+    assertSerializationRoundTrip (label <> " serialization") original++testConstrainedRoundTrip :: IO ()+testConstrainedRoundTrip = do+  built <-+    requireRight+      "constrained serialization source"+      ( constrainedDelaunay+          unitElementDefaults+          (V.fromList [Point 0 0, Point 2 0, Point 2 2, Point 0 2])+          (V.singleton (0, 2))+      )+  let original = buildTriangulation built+  assertSerializationRoundTrip "constrained serialization" original+ -- 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.@@ -73,18 +113,8 @@     (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+  assertSerializationRoundTrip "independent payload serialization" original+  assertSerializationRoundTrip "positionless payload serialization" positionless  testPointPayloadRoundTrip :: IO () testPointPayloadRoundTrip = do@@ -99,13 +129,85 @@     (vertexPoint geometry vertex) (vertexPoint original vertex)   assertEqual "point payload is stored"     (Point 13 17) (vertexData original vertex)-  roundTrip <-+  assertSerializationRoundTrip "point payload serialization" original++assertSerializationRoundTrip+  :: ( KnownConstraintMode mode+     , Binary vertex+     , Binary directed+     , Binary undirected+     , Binary face+     , Eq (Triangulation mode vertex directed undirected face)+     , Show (Triangulation mode vertex directed undirected face)+     )+  => String+  -> Triangulation mode vertex directed undirected face+  -> IO ()+assertSerializationRoundTrip label original = do+  decoded <-     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+      (label <> " round trip")+      (decodeTriangulation testDecodingBudget trustedBinaryPayloadDecoders (encodeTriangulation original))+  assertEqual (label <> " equality") original decoded+  assertValid (label <> " validity") decoded +-- Counts are one prefix precisely so these refusals precede all default and+-- payload decoders. The hostile fixtures use @()@, whose lawful decoder consumes+-- no bytes, to exercise the formerly allocative attack rather than relying on+-- truncation to save the process.+testRejectsHostileStructuralPrefixes :: IO ()+testRejectsHostileStructuralPrefixes =+  traverse_+    (\(label, budget, bytes, failure) ->+       assertDecodeFailure label budget bytes failure)+    [ ( "input byte budget"+      , DecodingBudget 43 10_000+      , structuralPrefix 6 0 0 1 0+      , InputByteBudgetExceeded 44 43+      )+    , ( "section element budget"+      , DecodingBudget 1_000 1_000_000+      , structuralPrefix 6 1_000_000 1_999_998 1 0+      , DecodedSectionBudgetExceeded 15_999_990 1_000_000+      )+    , ("directed edge parity", testDecodingBudget, structuralPrefix 6 0 1 1 0, SerializedDirectedEdgeCountOdd 1)+    , ("missing outer face", testDecodingBudget, structuralPrefix 6 0 0 0 0, SerializedMissingOuterFace)+    , ("constraint count relationship", testDecodingBudget, structuralPrefix 6 0 2 1 2, SerializedConstraintCountExceedsEdges 2 1)+    , ("planar cardinality relationship", testDecodingBudget, structuralPrefix 6 2 0 1 0, SerializedPlanarCardinalityMismatch 2 0 1)+    , ("fixed body lower bound", testDecodingBudget, structuralPrefix 6 1 0 1 0, SerializedFixedBodyTooShort 0 24)+    , ("host Int vertex count", DecodingBudget 1_000 maxBound, structuralPrefix 6 maxBound 0 1 0, EncodedCountExceedsInt SerializedVertexCount maxBound)+    , ( "packed vertex count"+      , DecodingBudget 1_000 maxBound+      , structuralPrefix 6 4_294_967_296 0 1 0+      , EncodedCountExceedsPackedIndex SerializedVertexCount 4_294_967_296 4_294_967_295+      )+    , ("version 5", testDecodingBudget, structuralPrefix 5 0 0 1 0, UnsupportedFormatVersion 5)+    ]++assertDecodeFailure+  :: String+  -> DecodingBudget+  -> BL.ByteString+  -> SerializationError+  -> IO ()+assertDecodeFailure label budget bytes expected =+  assertEqual+    label+    (Left expected)+    ( decodeTriangulation budget trustedBinaryPayloadDecoders bytes+        :: Either SerializationError (Triangulation 'Unconstrained () () () ())+    )++structuralPrefix :: Word16 -> Word64 -> Word64 -> Word64 -> Word64 -> BL.ByteString+structuralPrefix version vertexCount directedEdgeCount faceCount constraintCount =+  runPut $ do+    putWord64be 0x5350414445485307+    putWord16be version+    putWord16be 2+    traverse_+      putWord64be+      [vertexCount, directedEdgeCount, faceCount, constraintCount]+ -- 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@@ -119,8 +221,9 @@   original <- source   let bytes = encodeTriangulation original       size = BL.length bytes-      headerSize = 8 + 2 + 1 + 1-      decode candidate = decodeTriangulation candidate :: Either SerializationError SerialTriangulation+      envelopeSize = 8 + 2 + 1 + 1+      structuralPrefixSize = envelopeSize + 4 * 8+      decode candidate = decodeTriangulation testDecodingBudget trustedBinaryPayloadDecoders 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 ()@@ -136,12 +239,18 @@     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 ->+  traverse_+    (\dropped -> rejects ("a payload truncated by " <> show dropped) (BL.take (size - dropped) bytes))+    [1 .. size]+  traverse_+    (\offset -> rejects ("an envelope byte flipped at offset " <> show offset) (flipAt offset))+    [0 .. envelopeSize - 1]+  traverse_+    (\offset -> rejects ("a structural-prefix byte flipped at offset " <> show offset) (flipAt offset))+    [envelopeSize .. structuralPrefixSize - 1]+  traverse_ (\offset ->     case decode (flipAt offset) of       Left _ -> pure ()       Right decoded ->         assertValid ("a byte flipped at offset " <> show offset <> " decoded to") decoded+    ) [structuralPrefixSize .. size - 1]
test/support/Support.hs view
@@ -1,19 +1,29 @@--- | 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.+-- | Assertions and exact planar fixtures shared by the test slices. Nothing+-- here may depend on an optional package flag, so the minimal configuration+-- compiles the same helpers as the full one. module Support   ( requireRight   , requireQueryPoint   , assertEqual   , assertValid+  , integerPoint+  , rectangleLoop+  , rectangleComponent   ) where  import Control.Monad (unless)+import Data.List.NonEmpty (NonEmpty (..)) import Moonlight.Triangulation-  ( Point+  ( ExactLoop+  , ExactPoint+  , Point+  , PolygonComponent   , QueryPoint   , Triangulation+  , exactLoop+  , exactPoint   , mkQueryPoint+  , polygonComponent   , validateTriangulation   ) @@ -22,7 +32,7 @@   Left failure -> fail (label <> ": " <> show failure)   Right result -> pure result -requireQueryPoint :: String -> Point -> IO (QueryPoint)+requireQueryPoint :: String -> Point -> IO QueryPoint requireQueryPoint label = requireRight label . mkQueryPoint  assertEqual :: (Eq value, Show value) => String -> value -> value -> IO ()@@ -35,3 +45,29 @@   case validateTriangulation triangulation of     [] -> pure ()     violations -> fail (label <> " invariant violations: " <> show violations)++integerPoint :: Integer -> Integer -> ExactPoint+integerPoint x y = exactPoint (fromInteger x) (fromInteger y)++rectangleLoop :: Integer -> Integer -> Integer -> Integer -> IO ExactLoop+rectangleLoop minimumX minimumY maximumX maximumY =+  requireRight+    "rectangle loop"+    ( exactLoop+        ( integerPoint minimumX minimumY+            :| [ integerPoint maximumX minimumY+               , integerPoint maximumX maximumY+               , integerPoint minimumX maximumY+               ]+        )+    )++rectangleComponent+  :: Integer+  -> Integer+  -> Integer+  -> Integer+  -> IO PolygonComponent+rectangleComponent minimumX minimumY maximumX maximumY =+  rectangleLoop minimumX minimumY maximumX maximumY+    >>= requireRight "rectangle component" . (`polygonComponent` [])
weeder.toml view
@@ -11,6 +11,10 @@   '^Moonlight\.Triangulation\.LineSideInfo$',   '^Moonlight\.Triangulation\.Types$',   '^Moonlight\.Triangulation\.Math$',+  '^Moonlight\.Triangulation\.Exact$',+  '^Moonlight\.Triangulation\.CellSet$',+  '^Moonlight\.Triangulation\.Region$',+  '^Moonlight\.Triangulation\.Valuation$',   '^Moonlight\.Triangulation\.Interop$',   '^Moonlight\.Triangulation\.Dcel$',   '^Moonlight\.Triangulation\.Payload$',@@ -31,6 +35,8 @@   '^Moonlight\.Triangulation\.Removal$',   '^Moonlight\.Triangulation\.Session$',   '^Moonlight\.Triangulation\.Cdt$',+  '^Moonlight\.Triangulation\.Minkowski$',+  '^Moonlight\.Triangulation\.Overlay$',   '^Moonlight\.Triangulation\.Refinement$',   '^Moonlight\.Triangulation\.SetAlgebra$',   '^Moonlight\.Triangulation\.Parallel$',