packages feed

moonlight-planar (empty) → 1.0.0.0

raw patch · 287 files changed

+81634/−0 lines, 287 filesdep +aesondep +asyncdep +basebinary-added

Dependencies added: aeson, async, base, binary, bytestring, containers, deepseq, directory, filepath, moonlight-algebra, moonlight-category, moonlight-core, moonlight-homology, moonlight-planar, primitive, process, tasty, tasty-bench, tasty-hunit, text, transformers, unix, vector, vector-algorithms

Files

+ CHANGELOG.md view
@@ -0,0 +1,326 @@+# Changelog++This is release chronology, not current interface authority. The package+[README](./README.md), Cabal manifest, and linked focused guides own the live+surface.++`moonlight-planar` follows the+[Haskell Package Versioning Policy](https://pvp.haskell.org).++The serialization format carries its own version tag, independent of the package+version; any change to it is recorded here explicitly.++## Unreleased++## 1.0.0.0 - 2026-08-31++* Rename the planar package from `moonlight-triangulation` to+  `moonlight-planar`. Triangulation modules and foreign symbols retain their+  domain names; the old Hackage package remains immutable history.+* Add the dependency-light public `hex` sublibrary. Global axial coordinates,+  canonical vertices and sides, bounded layouts, and immutable packed regions+  support constant-time neighbours and wordwise union, intersection,+  difference, symmetric difference, complement, restriction, reframing, and+  overlap-compatible gluing with typed witnesses.+* Add exact polygonal, cellular-chain, and versioned serialization+  interpretations without introducing a second planar, Homology, or wire+  authority.++## 1.5.0.0 - 2026-08-30++* Make the complete stable-labelled `PowerSite` section authoritative in+  `RegularTriangulation`. Add pure insertion, removal, and batch reweighting+  with exhaustive typed disposition transitions, plus bounded power-cell+  construction that reuses an already normalized regular value.+* Collapse edit publication to changed-site support plus exact disposition+  transitions. A normalized face/edge/star section supports exact slope walks,+  insertion conflict cavities, interior removal cavities, and atomic reweight+  composition. Local publication certifies incidence, cavity boundary, and+  lifted convexity; unsupported degeneracies reconstruct once through the exact+  batch owner. On the retained GHC 9.14.1 `-O1` 512-site fixture, full-result+  insertion falls from 250.7 ms / 304.7 MB to 0.53 ms / 0.61 MB, removal from+  246.4 ms / 303.5 MB to 0.72 ms / 0.87 MB, and a general one-site reweight+  from 99.4 ms / 119.2 MB to 22.8 ms / 34.2 MB. A common shift of all 512+  weights takes 0.22 ms / 0.27 MB without changing incidence. Remove the+  transient peak-hull counter+  from the persistent topology receipt: unlike its remaining fields, it was a+  construction-history measurement rather than a property of the value.+* Make batch-reweight validation proportional to the patch rather than the+  resident site set, and descend changed sites without an association-list+  copy.+* Add signed exact weighted-alpha filtration over resident regular topology, a+  generic labelled planar-complex lowering into Homology, and focused weighted+  preparation and persistence benchmark lanes.++## 1.4.0.5 - 2026-08-29++* Add the GHC-9.14 `zigzag` sublibrary. Stable labelled activation points become+  independently sampled exact alpha complexes; adjacent observations glue+  through checked union cospans, and Homology returns stage-labelled exact+  zigzag intervals without comparing DCEL handles across meshes.++## 1.4.0.4 - 2026-08-28++* Add exact affine upper envelopes through the existing power-cell owner, with+  a no-overlay convex fast path and exact restriction to nonconvex or holed+  polygonal windows.+* Add balanced n-ary layer refinement, exact window-coverage certification+  carrying the uncovered region, and direct selected/confusion area folds.+  On the 16-layer benchmark fixture, balanced refinement is 13x faster and+  allocates 13.5x less than left association; direct mass and confusion are+  14.6x and 16.5x faster than materializing polygonal regions.+* Add exact regular triangulations over the lifted affine generators, including+  per-label visible/lower-dimensional/hidden dispositions and weighted dual+  segments, rays, full lines, and collapsed degenerate edges. Coplanar hull+  triangles glue before extreme-site extraction, so implementation diagonals+  cannot promote a facet-interior generator.+* Route bounded power cells through the regular-neighbour graph. The production+  lane derives one radical axis per regular edge and clips one small neighbour+  section per visible site; globally hidden sites perform no HPI, while only+  lower-dimensional sites use the complete exact oracle.+* Make regular-topology descent output-sensitive: hull removal touches only the+  removed face stars, the next expansion comes from a strict conflict frontier,+  supporting-plane duals survive into publication, coplanar fans share one dual,+  and collinear classification is one monotone merge. Regular edges retain only+  their admitted generator pair; neighbour and clipping views are derived at+  their respective consumers rather than stored as competing authorities. On+  the retained GHC 9.14.1 `-O1` 512-site fixture, topology and full-construction+  allocation fall by 10.7% and 10.2%; the corresponding wall times improve by+  roughly 1%.+* Consolidate convex erosion and power-cell construction on one exact clipper+  that retains source affine lines, avoiding measured endpoint-coefficient+  swell without claiming smaller reduced output denominators.+* Replace repeated polygon scans with one exact angular closed-half-plane+  descent, including empty, point, segment, parallel, and coincident sections.+  Clip receipts report boundary compatibility, exact intersections, rational+  widths, regular incidence, oracle cells, and maximum per-cell constraints.+* Evaluate exact signs and affine intersections through integer cross-products+  with one rational normalization at publication. This removes intermediate+  `Ratio` normalization from the HPI predicate kernel.+* Consolidate affine and power inputs on direct exact score coefficients,+  publish already-admitted cells without revalidation, and fold clip receipts+  into one strict summary. On the retained GHC 9.14.1 `-O1` 169-site fixtures,+  construction falls from 171.4 ms / 351.2 MB to 79.2 ms / 105.4 MB for the+  well-conditioned family and from 142.3 ms / 296.7 MB to 65.6 ms / 82.4 MB+  for the near-parallel family. Mesh joins and n-ary overlays interpret one+  shared balanced tournament.+* Collapse four exact-planar test runners into one behavioral owner, return the+  canonical overlay obstruction directly from n-ary refinement, and share the+  bounded-cell and strict-turn folds. Direct mass and confusion now allocate+  22% and 5% less on their accepted fixtures.+* Execute the exact-planar, documentation-example, and public-component suites+  in CI. Publish only the local embedding certifier; arrangement constructors+  and resident diagonal schedules live in the private `overlay-internal`+  component shared only with package-owned oracle tests.+* Add nominal rank-2 mesh scopes for zero-cost safe traversal, retain owning+  handles for escaping values, and document fixed identifiers as the unchecked+  issuing-mesh index lane. Convex reflection now preserves its counter-clockwise+  carrier invariant directly.+* Preserve a noncanonical zero-site mesh when it is joined with the canonical+  empty identity. The previous zero-count guard order broke structural right+  identity when both operands represented the empty support differently.++## 1.4.0.3 - 2026-08-28++* Restore public `dcel` and `build` sublibraries as safe restrictions of their+  private implementation owners. The default library reexports the same lawful+  modules, so consumers may choose the broad surface or a smaller dependency+  cone without receiving a second implementation.+* Publish incremental insertion/removal, sealed edit sessions, typed point and+  shape queries, owning handles, payload traversals, dynamic constraint+  operations, and whole-mesh diagnostics through the canonical Haskell facade.+* Keep raw identifier constructors, resident representation, admitted-input+  construction, local transaction scheduling, seam witnesses, and local+  validation closures private.++## 1.4.0.2 - 2026-08-28++* Consolidate usage guidance behind one operation index and exact set-operation+  type contract. Focused guides now uniquely own publication schedules,+  examples, comparisons, exhibits, and foreign-consumer details instead of+  repeating them across the package overview.++## 1.4.0.1 - 2026-08-24++* Break `joinSeparatedConstrained` onto its stronger local-extension contract:+  callers now supply a source-face preservation section and+  `RefinementParameters`, and receive seam provenance and publication+  receipts from the one constrained seam owner.+* Extend `RefinementParameters` with an optional maximum edge length and add+  typed refusals for non-finite, non-positive, interface-crossing, protected+  face, bridge-budget, and final oversized-edge obstructions. Local refinement+  now publishes its final permitted-face witness and validation/publication+  receipts.+* Add source-preserving paged publication receipts, cached seam-frontier+  observations, bounded-region face selection, and exact validation-closure+  statistics without introducing a second mesh carrier.+* Preserve each boundary loop's exact resident DCEL vertex chain through+  `boundaryLoopResidentVertices`; `boundaryLoopVertices` remains the derived+  collinearity-reduced polygon observation.+* Ship the persistence-rose source observatory and replace the decorative alpha+  eclipse with the canonical four-site square interval computed by+  `alphaFiltration` and Moonlight Homology: its one `H1` class is born at exact+  squared radius 1 and dies at 2. The retained SVGs and GIF now have a checked+  regeneration/provenance command, and CI rejects stale exhibit artifacts.++## 1.3.0.3 - 2026-08-22++* Restore the package-overview Delaunay board on Hackage with a release-tagged+  absolute image URL; the chart remains package-owned and shipped in the source+  distribution.++## 1.3.0.2 - 2026-08-22++* Add an opaque exact alpha filtration over every resident Delaunay vertex,+  edge, and bounded face, exact threshold cell selection, checked integral+  cellular-chain lowering, and direct lowering into Moonlight Homology's+  ordered filtered complex.+* Add exact Gabriel/non-Gabriel birth laws, boundary monotonicity, degenerate+  support, and a cocircular-square persistence witness whose degree-one class+  is born at squared radius 1 and dies at squared radius 2.+* Add a focused benchmark comparing one persistence reduction with recomputing+  homology at every exact critical radius over the same prepared geometry.+* Compute exact edge lengths and face circumradii as aligned dyadic integer+  kernels with one rational normalization at publication, and lower already+  ordered DCEL incidence before Homology checks and seals the chain law.+* Batch every critical-radius Betti profile through Homology's dense rank+  quotient. On the shared 1,000-site Spade diagnostic this cuts Moonlight from+  941.312 ms and 3.11 GB allocated to a 34.177 ms median and 96.0 MB while+  preserving the exact receipt.+* Remove the duplicate packed radial-geometry arena from bulk Delaunay ingress.+  Coordinates remain in dense planes while a 32-bit vertex-id plane descends+  through prefix radix order and exact equal-prefix normalization.+* Refresh the complete 120-case construction board. Moonlight's mean is below+  plain Spade and Spade hierarchy on all 24 fixtures, with non-overlapping+  reported 2σ on 18 and 22 fixtures respectively.+* Remove promotional advantage callouts from both SVG projections, ship the+  regenerated small SVG with the package, and reference it directly from the+  README instead of displaying a stale remote mirror copy.++## 1.3.0.0++* Add the public GHC-9.14 `cell-complex` component. It interprets an admitted+  `ExactCellSet` as Homology's generic `CellComplex2D` without copying the mesh+  or introducing a second cell inventory, and the accompanying observatory+  executable derives its incidence category and normalized flag nerve.+* Keep the LLVM-optimized hot modules buildable with GHC 9.8 by restoring the+  legacy LLVM pass manager that its supported LLVM 15 toolchain requires.+* Withdraw `constrainedExtensionTriangulation`,+  `constrainedExtensionConstraintOutcomes` and+  `constrainedExtensionConstraintStats`. A constrained extension now publishes+  one `ConstraintBatchResult` through `constrainedExtensionConstraintBatch`,+  read with `constraintBatchTriangulation`, `constraintBatchOutcomes` and+  `constraintBatchStats`; `constrainedExtensionBuildStats` is unchanged. The+  batch is the same value `recoverConstraints` returns, so extension and+  standalone recovery are now read through one accessor set instead of two.+* Withdraw the aggregator modules `Moonlight.Triangulation.Handles`,+  `Moonlight.Triangulation.Handles.Iterators` and+  `Moonlight.Triangulation.Internal.DcelOperations` from the exposed module+  list. Every leaf they re-exported remains exposed under its own name; import+  the leaf.+* Add `BoundaryOrientation`, `boundaryLoopOrientation` and+  `componentBoundaryLoops`, so a face component publishes all of its boundary+  loops with each loop's orientation rather than only the outer one.+* Add `planarValuationsPerimeter`, the certified perimeter of a planar region+  taken directly from its valuations.+* Advance the C boundary to ABI version 2 with opaque exact-region and reusable+  structuring-element handles, one-call bulk authoring/projection, exact region+  union/intersection/difference/symmetric difference, point location, exact+  area plus Euler and certified perimeter observations, and existing polygonal+  Minkowski morphology with fixed-width receipts.+* Rename the former mesh Boolean symbols and Python, TypeScript, and Rust+  methods to `site_*`; they combine Delaunay site sets and are deliberately not+  compatibility aliases for the new polygonal region operations.+* Restore `-O0` for ordinary test bodies while retaining the filtered-predicate+  allocation witness at module-local `-O1`.+* Move the existing exact Overlay/Minkowski implementations from the `build`+  sublibrary into the main library and move `HintGenerator` from `dual` into+  that same apex owner. The `dual` sublibrary is now dcel-only and can compile+  concurrently with `build`; direct `:dual` consumers of `HintGenerator` must+  depend on the main library instead. No geometry type or runtime operation is+  duplicated.+* Reserve the planar DCEL bound rather than the general one when joining two+  separated triangulations. The separated seam copies two planar sources and+  then only adds, so its peak is its published result; the general reservation+  was a third again as much arena as the merge can ever reach. Measured at+  twenty thousand sites over twenty-one processes per arm, the separated join+  lanes fall 36.4% to 41.3% in allocation and 10.2% to 22.0% in elapsed time,+  with every unaffected lane byte-identical.+* Stop materializing an intermediate validated vector in `mesh_insert_many_f64`.+  Admission is unchanged — a malformed point anywhere still refuses the whole+  batch before any insertion — but the canonical coordinate is now applied+  where the point is used. Against a fifty-thousand-site mesh, allocation falls+  5.3% at a thousand added points and 26.5% at fifty thousand; wall time is+  unmoved, because geometric insertion, not admission, is the critical path.++## 1.2.0.1++* Admit GHC 9.8 as a tested compiler by spelling the package language as+  `GHC2021` plus `DerivingStrategies`, accepting `base-4.19`, and qualifying+  strict list folds through `Data.List`. This restores Hackage build and+  documentation generation without changing the API or binary format.++## 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+  `delaunayFromCoordinates` with its duplicate-payload policy from the main+  facade.+* Add one versioned C ABI over immutable geometry meshes, with typed+  obstruction witnesses and thin Python, TypeScript, and Rust bindings.++## 1.0.0.0++* Specialize the public geometry surface to binary64 and remove the ornamental+  scalar parameter from points, queries, triangulations, sessions, hierarchy+  hints, interpolation workspaces, and result types.+* Add dense coordinate and inner-face vertex projections to the existing DCEL+  surface.+* Add exact support relations and finite-set operations over triangulations,+  with local publication for sparse differences, intersections, and symmetric+  differences.+* Schedule singleton insertion and constrained extension between dense and+  locality-preserving transactions from measured workload evidence.+* Resolve dense coordinate-removal batches through one mutable identity index,+  retaining geometric descent for sparse removals.+* Strengthen constrained extension, refinement, serialization, algebra, and+  hostile-boundary validation.++## 0.1.0.0++* Initial release.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 Blue Rose++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,266 @@+# moonlight-planar++> Part of **Moonlight**, the sheaf-theoretic computation layer beneath+> [Melusine](https://bluerose.blue) and Pale Meridian.++`moonlight-planar` carries native hexagonal regions plus Delaunay and+constrained Delaunay triangulations as lawful finite-set algebras. A hex region+is an immutable packed cell selection; a mesh is observed through its canonical+site set. In both domains operations close over the same kind of value: a+mesh represents its site set, a join returns a valid Delaunay representative,+and the result is a triangulation again — so the operations close, compose, and+fold. Operations return typed obstructions where the finite arena cannot+represent a result.++Delaunay triangulation, constrained Delaunay (CDT), exact rational planar+regions and labelled overlay, intrinsic valuations, polygonal Minkowski+morphology, exact regular/power geometry, the Voronoi dual, natural-neighbour interpolation, Ruppert+refinement, walk point location, convex hull, exact Shewchuk predicates,+exact zigzag persistence across non-nested activation depths, and versioned+binary serialization.++## Persistence rose++![Animated Moonlight persistence rose: exact Delaunay alpha filtration, persistent homology, Voronoi dual, and natural-neighbour field](./docs/persistence-rose/moonlight-triangulation-persistence-rose.gif)++[Open the animation directly.](./docs/persistence-rose/moonlight-triangulation-persistence-rose.gif)+· [Open the static vector poster.](./docs/persistence-rose/moonlight-triangulation-persistence-rose.svg)+· [Read the exhibit guide.](./docs/persistence-rose/README.md)++## Operations++| Operation | Use when | Inputs | Result |+| --- | --- | --- | --- |+| `hexLayout` / `hexNeighbourCoord` | A bounded native hexagonal world needs dense identity and arithmetic adjacency | Axial origin and extents / coordinate and direction | `HexLayout` / optional neighbour / typed layout obstruction |+| `hexRegionUnion` / `hexRegionIntersection` / `hexRegionDifference` / `hexRegionSymmetricDifference` | Native cell selections must combine without triangulation or polygon construction | Two same-layout `HexRegion`s | Packed `HexRegion` / layout mismatch |+| `restrictHexRegion` / `reframeHexRegion` | A local section changes context | Target layout and region | Packed restricted/reframed region / typed restriction obstruction |+| `glueCompatibleHexRegions` | Local sections must descend only after agreeing on overlaps | Nonempty local-region family | Glued `HexRegion` / exact overlap witness |+| `hexRegionPlanarRegion` | Native selected cells need exact polygonal operations | `HexRegion` | Existing `PlanarRegion` / typed boundary or publication obstruction |+| `delaunayGeometry` | Coordinates own the input | `Vector Point` | Geometry-only mesh / `BuildError` |+| `delaunayFromCoordinates` | Payloads have a separate plane | Defaults, points, payloads, duplicate policy | `BuildResult` / `BuildError` |+| `insert` / `insertAt` / `insertMany` | An immutable mesh gains sites or payload replacements | Mesh plus payloads or explicit points | `InsertionResult` / `BuildResult` / `BuildError` |+| `withSession` | Many inserts and removals should publish once | Mesh, peak added-site count, composed `Session` | Result, mesh, and `BuildStats` / `BuildError` |+| `withScopedTriangulation` | Local traversal must make cross-mesh identifiers unrepresentable | Mesh and rank-2 continuation | Zero-cost scoped mesh and identifiers |+| `removeVertex` / `locateAndRemove` | A resident handle or exact position must be removed | Mesh plus `VertexId` / `Point` | `RemovalResult` / optional result / `BuildError` |+| `siteRelation` | Supports need exact classification | Two meshes | `SiteRelation` |+| `union` / `unions` | Unconstrained supports must join | Two meshes / mesh list | Union mesh / `BuildError` |+| `intersection` / `intersectionWith` | Shared support is required | Two meshes; optional payload combiner | Common-site mesh / `BuildError` |+| `difference` / `symmetricDifference` | Left-only / exclusive support is required | Source and mask / two meshes | Result mesh / `BuildError` |+| `constrainedDelaunay` | Segments author topology | Defaults, positioned vertices, index pairs | `BuildResult` / `CdtError` |+| `addConstraintEdge(s)` / `removeConstraintEdge` | Constraints change on a resident mesh | Mesh plus vertex pair(s) / edge | Constraint receipt or mesh / `CdtError` |+| `unionConstrained` / `unionConstrainedWith` | Arbitrary constrained meshes must join | Two meshes; optional payload combiner | Constrained mesh / `ConstrainedUnionError` |+| `extendConstrainedWith` | One constrained mesh owns identity | Combiner, base, extension | `ConstrainedExtensionResult` / `ConstrainedUnionError` |+| `joinSeparatedConstrained` | Inputs are strictly x-separated | Face predicate, refinement parameters, two meshes | `ConstrainedSeamResult` / `ConstrainedUnionError` |+| `refine` | Quality applies globally | Vertex constructor, parameters, mesh | `RefinementResult` / `BuildError` |+| `refineWithinDomain` | Quality applies to admitted faces | Vertex constructor, parameters, face set, mesh | `RefinementDomainResult` / `BuildError` |+| `faceComponents` | Bounded faces must descend by label | Mesh, `FaceId -> label` | `[(label, FaceComponent)]` |+| `componentBoundary` | One component must publish as loops | Mesh, `FaceComponent` | `RegionBoundary` / `BoundaryObstruction` |+| `locatePoint` / `locatePointWithHint` | An admitted point needs an exact cell classification | Mesh, `QueryPoint`, optional hint | `Location`, optionally with `LocationStats` |+| `lineIntersections` | A segment needs its ordered mesh crossings | Mesh and admitted endpoints | `[Intersection]` |+| `verticesInCircle` / `verticesInRectangle` | A metric window selects resident sites | Mesh and circle / rectangle | Handles / typed metric error |+| `exactClipRetainedPolygon` | A convex exact polygon must meet closed half-planes while retaining source lines | Retained polygon and half-plane list | Empty, point, segment, or polygon section plus receipt / `ExactClipError` |+| `overlayLayers` | Layers need one exact arrangement | Two `PlanarLayer`s | `OverlayResult` / `OverlayError` |+| `overlayAll` | A nonempty layer family needs one tuple-labelled common refinement | `NonEmpty (PlanarLayer label)` | `PlanarLayer (NonEmpty label)` / `OverlayError` |+| `overlayClosedUnion` / `overlayClosedIntersection` / `overlayRegularizedDifference` | Boolean output may retain lower cells | Two label predicates, `OverlayResult` | `ExactCellSet` / `OverlaySelectionError` |+| `overlaySelectedRegion` | Selected faces must publish as polygons | Label-pair predicate, `OverlayResult` | `PlanarRegion` / `RegionPublicationError` |+| `overlayMass` / `overlayConfusion` | Only exact selected area or the finite label-pair matrix is needed | Predicate / `OverlayResult` | `ExactArea` / exact mass map |+| `layerCovers` | A labelled layer must cover an admitted polygonal window | `PlanarLayer`, `PolygonComponent` | `()` or `LayerCoverageError` carrying the exact gap |+| `cellValuations` / `regionValuations` | Intrinsic measures are required | `ExactCellSet` / `PlanarRegion` | `PlanarValuations` / `ValuationError` |+| `minkowskiSum` / `polygonOffset` | Regions must add / expand | Two regions / element and region | Region plus receipt / `MinkowskiError` |+| `erodeBy` / `openWith` / `closeWith` | Regularized morphology is required | Structuring element, region | Region plus receipt / `MinkowskiError` |+| `regularTriangulation` | Weighted sites need unbounded topology and exact dual geometry | Nonempty `PowerSite` family | Opaque regular topology, dispositions, segments/rays/lines, and receipt / `PowerDiagramError` |+| `insertRegularSite` / `removeRegularSite` | A persistent regular value gains or loses one stable-labelled site | `PowerSite` / label and `RegularTriangulation` | New regular value, changed-site support, and exact disposition transitions / `RegularEditError` |+| `reweightRegularSites` | Stable sites receive one optimizer or simulation weight update | `Map label PowerWeight`, `RegularTriangulation` | New regular value, changed-site support, and exact disposition transitions / `RegularEditError` |+| `boundedPowerDiagram` | Labelled weighted sites need exact cells inside one finite convex domain | `ConvexPolygon`, nonempty `PowerSite` family | Total labelled dispositions plus rational-width receipt / `PowerDiagramError` |+| `boundedPowerDiagramFromRegular` | An admitted regular value already owns the weighted-site topology | `ConvexPolygon`, `RegularTriangulation` | Exact bounded cells without rebuilding the lifted hull / `PowerDiagramError` |+| `upperEnvelope` | Exact affine forms need their labelled argmax decomposition in a polygonal window | `PolygonComponent`, `Map label AffineForm` | `PlanarLayer (Maybe label)` / `UpperEnvelopeError` |+| `alphaShapeContainsFace` | One face at one radius is enough | `RadiusSquared`, mesh, `FaceId` | `Bool` |+| `alphaFiltration` | Every critical radius matters | Delaunay mesh | `AlphaFiltration` / `AlphaFiltrationError` |+| `regularAlphaFiltration` | Weighted regular topology needs signed exact births | `RegularTriangulation` | `RegularAlphaFiltration` / `RegularAlphaError` |+| `fromExactCellSet` | Exact cells need a generic complex view | `ExactCellSet` | `DCELComplex` |+| `filteredAlphaComplex` | Alpha births must enter persistence | `AlphaFiltration` | Filtered chain complex / `DCELError` |+| `activationAlphaZigzag` | Non-nested labelled depths need checked correspondence | `NonEmpty (ActivationSlice depth label)` | Admitted complexes, adjacent-union witnesses, and checked zigzag / `ActivationZigzagError` |+| `activationZigzagIntervals` / `activationAlphaPersistence` | An admitted zigzag / labelled depth family needs its exact barcode | `ActivationZigzag` / `NonEmpty (ActivationSlice depth label)` | Stage-labelled exact zigzag intervals / `ActivationZigzagError` |+| `canonicalize` | Numbering must ignore construction history | Mesh with unit edge/face payloads | Canonical mesh / `BuildError` |++[Interpret cell sets as incidence categories.](docs/category-observatory/README.md#cell-complex-and-category-interpretation)+· [Compute persistent alpha topology.](docs/persistence-rose/README.md#exact-alpha-filtration-and-persistent-topology)+· [Track topology across non-nested activation depths.](docs/activation-zigzag.md)+· [Compute weighted alpha persistence.](docs/weighted-alpha.md)++## Exact power cells and affine envelopes++`PowerWeight` admits a finite signed additive offset through its own+`PowerWeightError`; `PowerSite` admits its binary64 position once.+`regularTriangulation` constructs the exact lifted upper hull once. It retains+every admitted labelled site as its semantic value; visibility, regular faces,+and weighted-dual segments, rays, full lines, or collapsed degenerate edges are+sealed derived projections. Pure insertion, removal, and batch reweighting+return exhaustive typed disposition transitions. Exact conflict-cavity and+face-star descent update only affected topology; an internal typed refusal+falls back once to the canonical batch constructor.+`boundedPowerDiagram` then clips only regular-neighbour inequalities against the+`ConvexPolygon`; globally hidden sites need no clip, while lower-dimensional+sites use the complete HPI oracle. It retains one full-dimensional,+lower-dimensional, empty, coincident-equivalent, or coincident-dominated result+per label. `powerDiagramPlanarLayer` is only the derived full-dimensional view.+When a regular value is already available, `boundedPowerDiagramFromRegular`+reuses its normalized lifted hull.++`upperEnvelope` maps exact `c0 + cx*x + cy*y` forms into the same owner. Its+planar result contains only two-dimensional winning regions, with `Nothing`+outside the window; nonconvex windows and holes use the canonical overlay.++[Edit and reweight the complete regular-site section.](docs/regular-site-algebra.md)+· [Lower weighted topology into exact persistence.](docs/weighted-alpha.md)++## Foreign bindings++The C ABI and its Python, TypeScript, and Rust consumers are documented in the+[foreign-bindings guide](ffi/bindings/README.md). It owns construction, ABI+versioning, lifecycle, obstruction semantics, and consumer examples.++## Algebraic contract++`union` is idempotent; commutativity and associativity hold after+`canonicalize`. Structural `Eq` is resident equality; use `siteRelation` for+support comparison.++### Set-operation types++```haskell+union :: JoinSemilattice annotation+      => Triangulation 'Unconstrained annotation () () ()+      -> Triangulation 'Unconstrained annotation () () ()+      -> Either BuildError (Triangulation 'Unconstrained annotation () () ())++unions :: JoinSemilattice annotation+       => [Triangulation 'Unconstrained annotation () () ()]+       -> Either BuildError (Triangulation 'Unconstrained annotation () () ())++siteRelation+      :: Triangulation leftMode leftAnnotation leftDirected leftUndirected leftFace+      -> Triangulation rightMode rightAnnotation rightDirected rightUndirected rightFace+      -> SiteRelation++intersection+      :: Triangulation 'Unconstrained () () () ()+      -> Triangulation 'Unconstrained () () () ()+      -> Either BuildError (Triangulation 'Unconstrained () () () ())++intersectionWith+      :: (leftAnnotation -> rightAnnotation -> annotation)+      -> Triangulation 'Unconstrained leftAnnotation () () ()+      -> Triangulation 'Unconstrained rightAnnotation () () ()+      -> Either BuildError (Triangulation 'Unconstrained annotation () () ())++difference+      :: Triangulation 'Unconstrained leftAnnotation () () ()+      -> Triangulation 'Unconstrained rightAnnotation () () ()+      -> Either BuildError (Triangulation 'Unconstrained leftAnnotation () () ())++symmetricDifference+      :: Triangulation 'Unconstrained annotation () () ()+      -> Triangulation 'Unconstrained annotation () () ()+      -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+```++### Zigzag composition++The activation surface composes admitted local geometry with exact global+reduction through the existing typed obstruction:++```haskell+activationAlphaPersistence slices =+  activationAlphaZigzag slices >>= activationZigzagIntervals+```++Each slice yields a canonical labelled subcomplex `K_i`. Adjacent sections glue+through `K_i -> K_i ∪ K_{i+1} <- K_{i+1}`: the union is the join of labelled+subcomplexes, and both legs are checked chain maps satisfying+`boundary . inclusion = inclusion . boundary`. The glued zigzag is therefore a+finite path in chain complexes; rational homology and interval decomposition+produce its authoritative global barcode. Betti profiles are derived views,+while any failed local, overlap, or gluing obligation remains an+`ActivationZigzagError`.++[Publication schedules and scale behavior.](docs/mesh-publication.md)++## Use++For native hexagonal worlds, depend only on the bottom component. It has no+DCEL, overlay, Homology, `containers`, or serialization dependency:++```cabal+build-depends:+  moonlight-planar:hex >= 1.0 && < 1.1+```++```haskell+layout <- hexLayout (HexCoord 0 0) 1024 1024+left <- hexRegionFromCoords layout [HexCoord 4 7, HexCoord 5 7]+right <- hexRegionFromCoords layout [HexCoord 5 7, HexCoord 6 7]+combined <- hexRegionUnion left right+```++The pure Boolean kernels visit one `Word64` per 64 cells. Exact polygons,+Homology chains, and bytes are explicit derived interpretations in the default,+`cell-complex`, and `serialize` components respectively.++Use the broad default library with explicit `Vector` inputs. It exposes the+facade and the safe leaf modules; construction and set algebra retain their+typed obstruction in `Either`:++```cabal+build-depends:+  base >= 4.19 && < 5,+  moonlight-planar >= 1.0 && < 1.1,+  vector >= 0.13 && < 0.14+```++Use `withScopedTriangulation` for allocation-free local incidence traversal.+Use `Handles.Dynamic` when a handle must escape. Fixed `VertexId`/edge/face+values are unchecked resident indices and belong only with the mesh that issued+them.++[`SetAlgebra.hs`](docs/examples/Moonlight/Triangulation/Example/SetAlgebra.hs)+is the smallest compile-checked workflow. The+[example index](docs/examples/README.md) adds constrained interiors,+alpha-boundary descent, exact overlay and valuations, and polygonal morphology.++For a smaller compile/dependency cone, depend on only the component modules you+import:++```cabal+build-depends:+  moonlight-planar:dcel >= 1.0 && < 1.1,+  moonlight-planar:build >= 1.0 && < 1.1+```++## Architecture++The resident DCEL is immutable structure-of-arrays over paged copy-on-write+storage; local mutation is sealed in `ST`. Half-edge twins are index+complements. Exact predicates use bounded machine-word evaluation and fall+through to aligned `Integer` arithmetic when required.++## Consumer libraries++The Cabal manifest owns component visibility and dependencies; this is its+consumer-facing projection. Use a public sublibrary directly when its smaller+dependency cone matters; trusted implementation units remain private.++| Dependency | Imports | Purpose |+| --- | --- | --- |+| `moonlight-planar:hex` | `Moonlight.Hex.Coordinate`, `.Element`, `.Region` | Native axial elements, arithmetic neighbours, packed finite-set algebra, restriction, and compatible gluing; depends only on `base`, `deepseq`, `transformers`, and `vector`. |+| `moonlight-planar` | `Moonlight.Triangulation` plus the public `dcel`, `build`, and `dual` modules | Broad construction, observation, set algebra, CDT, refinement, alpha, Voronoi, interpolation, and exact planar surface. |+| `moonlight-planar:core` | `.Scalar`, `.LineSideInfo` | Low-level exact scalars and paged storage primitives. |+| `moonlight-planar:dcel` | `.Types`, `.Dcel`, `.Handles.*`, `.PointLocation`, `.FloodFillIterator`, `.IntersectionIterator`, `.Alpha`, `.Exact`, `.Region`, `.Valuation` | Immutable mesh vocabulary, exact geometry, scoped/owning observations, and the explicit fixed-index kernel; no construction kernel. |+| `moonlight-planar:build` | `.BulkLoad`, `.Session`, `.Removal`, `.Cdt`, `.Refinement`, `.SetAlgebra` | Construction and persistent editing over the DCEL; no dual, serialization, concurrency, or Homology dependency. |+| `moonlight-planar:dual` | `.Voronoi`, `.Voronoi.Handles`, `.Interpolation` | Voronoi observations and natural-neighbour interpolation. |+| `moonlight-planar:parallel` | `.Parallel` | Bounded concurrent union; adds `async`. |+| `moonlight-planar:serialize` | `Moonlight.Hex.Serialization`, `Moonlight.Triangulation.Serialization` | Versioned binary envelopes; adds `binary`, `bytestring`, and `transformers`. |+| `moonlight-planar:cell-complex` (GHC 9.14+) | `Moonlight.Hex.CellComplex`, `Moonlight.Triangulation.CellComplex` | Native-hex and exact-DCEL chain interpretations; adds Homology. |+| `moonlight-planar:zigzag` (GHC 9.14+) | `.Zigzag` | Labelled activation alpha complexes, adjacent-union witnesses, and stage-labelled zigzag intervals; adds Homology and construction. |++[Build and validate package components locally.](docs/development.md)
+ bench/aggregate/Main.hs view
@@ -0,0 +1,19 @@+-- | Every benchmark slice, in one process. This imports the slice modules+-- rather than restating their contents, so a benchmark added to a slice appears+-- here without anyone remembering to add it. An aggregate that duplicates its+-- slices instead of importing them drifts the moment a slice grows.+module Main (main) where++import qualified Moonlight.Triangulation.BuildBench as BuildBench+import qualified Moonlight.Triangulation.DcelBench as DcelBench+import qualified Moonlight.Triangulation.DualBench as DualBench+import qualified Moonlight.Triangulation.JoinBench as JoinBench+import qualified Moonlight.Triangulation.RegionBench as RegionBench++main :: IO ()+main = do+  BuildBench.benchmarks+  DcelBench.benchmarks+  DualBench.benchmarks+  JoinBench.benchmarks+  RegionBench.benchmarks
+ bench/alpha/Main.hs view
@@ -0,0 +1,203 @@+-- | Measure the exact alpha shortcut against recomputing homology at every+-- critical radius. Delaunay construction is deliberately outside every timed+-- lane: both algorithms consume the same already-built geometry.+module Main (main) where++import BenchMeasure+  ( requireRight+  , timedProjection+  , timedValue+  )+import BenchSupport (randomPoints)+import Data.Map.Strict qualified as Map+import Data.List.NonEmpty qualified as NonEmpty+import Data.Foldable (traverse_)+import Data.Vector qualified as Vector+import Moonlight.Homology.Boundary+  ( degreeCardinality+  , maxHomologicalDegree+  , restrictComplex+  )+import Moonlight.Homology.Chain+  ( HomologicalDegree (..)+  , HomologyFailure+  )+import Moonlight.Homology.Persistence+  ( FilteredFiniteChainComplex+  , criticalBettiVectors+  , filteredBaseComplex+  , filteredCellBirths+  , filteredCriticalValues+  , mod2PersistentPairsWithCriticalBettiTable+  )+import Moonlight.Homology.Topology (freeBettiVector)+import Moonlight.Triangulation.Alpha+  ( AlphaBirth+  , alphaFiltration+  )+import Moonlight.Triangulation.BulkLoad (delaunayGeometry)+import Moonlight.Triangulation.CellComplex (filteredAlphaComplex)+import Moonlight.Triangulation.LabelledComplex (filteredPlanarComplex)+import Moonlight.Triangulation.PowerDiagram+  ( PowerSite+  , RegularTriangulation+  , powerSite+  , powerWeight+  , regularTriangulation+  , regularTriangulationReceipt+  )+import Moonlight.Triangulation.RegularAlpha+  ( PowerAlphaBirth+  , regularAlphaBirths+  , regularAlphaComplex+  , regularAlphaFiltration+  )+import Moonlight.Triangulation.Types (DelaunayTriangulation, Point)++type PreparedAlpha = FilteredFiniteChainComplex AlphaBirth Int++main :: IO ()+main = do+  benchmarkAlphaFiltration 64+  traverse_ benchmarkWeightedAlphaFiltration [64, 512, 2048]++benchmarkAlphaFiltration :: Int -> IO ()+benchmarkAlphaFiltration siteCount = do+  triangulation <-+    requireRight+      (delaunayGeometry (Vector.fromList (randomPoints 0x9e3779b97f4a7c15 siteCount)))+  filtered <-+    timedProjection+      (benchmarkLabel siteCount "alpha-filtered-complex")+      preparationReceipt+      (prepareAlpha triangulation)+  let thresholds = filteredCriticalValues filtered+      maximumDegree = maxHomologicalDegreeValue filtered+  persistentProfile <-+    timedValue+      (benchmarkLabel siteCount "persistence-critical-profile")+      ( do+          (_, bettiTable) <-+            requireRight (mod2PersistentPairsWithCriticalBettiTable filtered)+          pure (criticalBettiVectors bettiTable)+      )+  repeatedProfile <-+    timedValue+      (benchmarkLabel siteCount "repeated-threshold-homology")+      (requireRight (traverse (bettiVectorAtThreshold maximumDegree filtered) thresholds))+  if persistentProfile == repeatedProfile+    then+      putStrLn+        ( benchmarkLabel siteCount "agreement"+            <> ": critical-radii="+            <> show (length thresholds)+            <> " profiles="+            <> show (length persistentProfile)+            <> " prepared-cells="+            <> show (preparationReceipt filtered)+        )+    else fail (benchmarkLabel siteCount "profile-mismatch")++benchmarkLabel :: Int -> String -> String+benchmarkLabel siteCount suffix =+  "alpha/n" <> show siteCount <> "/" <> suffix++prepareAlpha+  :: DelaunayTriangulation ()+  -> IO PreparedAlpha+prepareAlpha triangulation = do+  filtration <- requireRight (alphaFiltration triangulation)+  requireRight (filteredAlphaComplex filtration)++preparationReceipt+  :: FilteredFiniteChainComplex filtration coefficient+  -> (Int, Int, [Int])+preparationReceipt filtered =+  let finite = filteredBaseComplex filtered+      HomologicalDegree maximumDegree = maxHomologicalDegree finite+   in ( length (filteredCriticalValues filtered)+      , Map.size (filteredCellBirths filtered)+      , fmap+          (degreeCardinality finite . HomologicalDegree)+          [0 .. maximumDegree]+      )++maxHomologicalDegreeValue+  :: FilteredFiniteChainComplex filtration coefficient+  -> Int+maxHomologicalDegreeValue filtered =+  case maxHomologicalDegree (filteredBaseComplex filtered) of+    HomologicalDegree degreeValue -> degreeValue++bettiVectorAtThreshold+  :: Int+  -> FilteredFiniteChainComplex AlphaBirth Int+  -> AlphaBirth+  -> Either HomologyFailure [Int]+bettiVectorAtThreshold maximumDegree filtered threshold = do+  restricted <-+    restrictComplex+      (Map.keysSet (Map.filter (<= threshold) (filteredCellBirths filtered)))+      (filteredBaseComplex filtered)+  pure (padBettiVector maximumDegree (freeBettiVector restricted))++padBettiVector :: Int -> [Int] -> [Int]+padBettiVector maximumDegree bettiVector =+  bettiVector+    <> replicate+      (max 0 (maximumDegree + 1 - length bettiVector))+      0++type PreparedWeightedAlpha = FilteredFiniteChainComplex PowerAlphaBirth Int++benchmarkWeightedAlphaFiltration :: Int -> IO ()+benchmarkWeightedAlphaFiltration siteCount = do+  sites <-+    traverse prepareWeightedSite+      (zip [0 ..] (randomPoints 0x517cc1b727220a95 siteCount))+  submitted <-+    maybe (fail "weighted alpha benchmark requires at least one site") pure+      (NonEmpty.nonEmpty sites)+  regular <-+    timedProjection+      (benchmarkLabel siteCount "regular-topology")+      regularTriangulationReceipt+      (fst <$> requireRight (regularTriangulation submitted))+  filtered <-+    timedProjection+      (benchmarkLabel siteCount "weighted-filtered-complex")+      preparationReceipt+      (prepareWeightedAlpha regular)+  profiles <-+    timedValue+      (benchmarkLabel siteCount "weighted-persistence-critical-profile")+      ( do+          (_, bettiTable) <-+            requireRight (mod2PersistentPairsWithCriticalBettiTable filtered)+          pure (criticalBettiVectors bettiTable)+      )+  putStrLn+    ( benchmarkLabel siteCount "weighted-profile"+        <> ": critical-births="+        <> show (length (filteredCriticalValues filtered))+        <> " profiles="+        <> show (length profiles)+        <> " prepared-cells="+        <> show (preparationReceipt filtered)+    )++prepareWeightedSite :: (Int, Point) -> IO (PowerSite Int)+prepareWeightedSite (label, point) = do+  weight <- requireRight (powerWeight (fromIntegral (label `mod` 11 - 5) / 256))+  requireRight (powerSite label point weight)++prepareWeightedAlpha+  :: RegularTriangulation Int+  -> IO PreparedWeightedAlpha+prepareWeightedAlpha regular = do+  filtration <- requireRight (regularAlphaFiltration regular)+  requireRight+    ( filteredPlanarComplex+        (regularAlphaComplex filtration)+        (regularAlphaBirths filtration)+    )
+ bench/build/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.BuildBench as BuildBench++main :: IO ()+main = BuildBench.benchmarks
+ bench/build/Moonlight/Triangulation/BuildBench.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NumericUnderscores #-}++-- | The construction side: circle-sweep bulk load against the arrival-order+-- session kernel, persistent single insertion, constraint recovery and Ruppert+-- refinement. Each reports the library's own work counters alongside the time,+-- because the claim being measured is about work done rather than seconds.+module Moonlight.Triangulation.BuildBench (benchmarks) where++import BenchMeasure (requireRight, timedValue)+import BenchSupport (randomPoints)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Monad (forM_, unless)+import Data.List (sort)+import Data.Primitive.PrimArray (indexPrimArray, sizeofPrimArray)+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.BulkLoad (empty, insert)+import Moonlight.Triangulation.Cdt (recoverConstraints)+import Moonlight.Triangulation.Foreign.Mesh (insertGeometryBatch)+-- The facade withholds this constructor. The benchmark indexes the builder's+-- own input mapping, so every handle it forges is one the builder issued, and+-- it owns that obligation explicitly by naming the module that grants it.+import Moonlight.Triangulation.Internal.HandleDefs (VertexId (VertexId))+import Moonlight.Triangulation.Internal.Session (insertVertex, insertVertexAt, withLocalSession, withSession)+import Moonlight.Triangulation.Types+  ( InsertionResult (insertionTriangulation)+  , refinementStats+  , statEdgeFlips+  , statLocationWalkSteps+  , statRefinementFaceChecks+  , statRefinementQueuePops+  )++benchmarks :: IO ()+benchmarks = do+  putStrLn "moonlight-triangulation native construction benchmark"+  forM_ [1_000, 10_000, 50_000] benchmarkConstruction+  forM_ [1_000, 10_000, 50_000, 100_000, 1_000_000] benchmarkSingletonInsertionCrossover+  forM_ [(50_000, 1_000), (50_000, 10_000), (50_000, 50_000)] benchmarkGeometryBatchInsertion+  benchmarkConstraints+  benchmarkRefinement 2_500++-- | What the geometry-only foreign batch entrance costs against the session+-- insertion it is built out of. The two arms differ by exactly one thing: the+-- ABI route validates every point into an intermediate boxed vector before it+-- opens the session, and the session arm receives the same points with that+-- pass already paid. Their difference is therefore the price of admission,+-- and it is the number that decides whether a fused geometry entrance is worth+-- designing at all. Inserting into an existing mesh is not the law of fresh+-- circle sweep, so nothing here transfers from the construction lanes above.+benchmarkGeometryBatchInsertion :: (Int, Int) -> IO ()+benchmarkGeometryBatchInsertion (baseCount, addedCount) = do+  let label suffix = "geometry-batch-" <> suffix <> "/" <> show baseCount <> "+" <> show addedCount+      basePoints = V.fromList (randomPoints 0x9e3779b97f4a7c15 baseCount)+      addedPoints = V.fromList (randomPoints 0xbf58476d1ce4e5b9 addedCount)+  base <- evaluate . force =<< requireRight (delaunayGeometry basePoints)+  _ <- evaluate (force addedPoints)+  admitted <- timedValue (label "abi") $ requireRight (insertGeometryBatch base addedPoints)+  (_, sessioned, _) <- timedValue (label "session") $+    requireRight+      ( withSession base (V.length addedPoints) $+          V.mapM_ (\point -> () <$ insertVertexAt point ()) addedPoints+      )+  admittedCanonical <- requireRight (canonicalize admitted)+  sessionedCanonical <- requireRight (canonicalize sessioned)+  equal <- evaluate (force (admittedCanonical == sessionedCanonical))+  unless equal $+    fail (label "witness" <> ": the admitted and session arms disagree")+  putStrLn (label "witness" <> ": ok")++benchmarkConstruction :: Int -> IO ()+benchmarkConstruction count = do+  let points = V.fromList (randomPoints 0x9e3779b97f4a7c15 count)+  swept <- timedValue ("circle-sweep/" <> show count) $ requireRight (delaunay unitElementDefaults points)+  (_, sessioned, _) <- timedValue ("session/" <> show count) $+    requireRight+      ( withSession (empty unitElementDefaults) (V.length points) $+          V.mapM_ insertVertex points+      )+  evaluate (force (canonicalEdges (buildTriangulation swept) == canonicalEdges sessioned)) >>= \equal ->+    if equal then pure () else fail "circle-sweep and session construction disagree"++benchmarkSingletonInsertionCrossover :: Int -> IO ()+benchmarkSingletonInsertionCrossover count = do+  let points = V.fromList (randomPoints 0xd1b54a32d192ed03 count)+  built <- requireRight (delaunay unitElementDefaults points)+  let query = Point 0.000_123_456_7 (-0.000_765_432_1)+      base = buildTriangulation built+  scheduled <- timedValue ("singleton-scheduled-public-insert/" <> show count) $ requireRight (insert base query)+  (_, local, _) <- timedValue ("singleton-local-session-insert/" <> show count) $+    requireRight (withLocalSession base 1 (insertVertex query))+  let scheduledMesh = insertionTriangulation scheduled+  unless (null (validateTriangulation scheduledMesh)) $+    fail ("scheduled singleton insertion produced an invalid triangulation at " <> show count <> " sites")+  unless (null (validateTriangulation local)) $+    fail ("local singleton insertion produced an invalid triangulation at " <> show count <> " sites")+  scheduledCanonical <- requireRight (canonicalize scheduledMesh)+  localCanonical <- requireRight (canonicalize local)+  equal <- evaluate (force (scheduledCanonical == localCanonical))+  unless equal $+    fail ("scheduled and local singleton insertion disagree semantically at " <> show count <> " sites")+  putStrLn ("singleton-insertion-crossover/" <> show count <> "-semantic-witness: ok")++benchmarkConstraints :: IO ()+benchmarkConstraints = do+  let pointCount = 8_000+      constraintCount = 800+  built <- requireRight (delaunay unitElementDefaults (V.fromList (randomPoints 0x94d049bb133111eb pointCount)))+  let cdt = fromDelaunay (buildTriangulation built)+      inputMapping = buildInputVertices built+      requestIndices =+        V.fromList+          ( take constraintCount+              [ (a, b)+              | index <- [0 .. pointCount * constraintCount - 1]+              , let a = index `mod` pointCount+                    b = (index * 6151 + pointCount `quot` 2) `mod` pointCount+              , a /= b+              ]+          )+  pairs <-+    V.mapM+      (\(fromIndex, toIndex) ->+        let len = sizeofPrimArray inputMapping+            mFrom = if fromIndex >= 0 && fromIndex < len then Just (VertexId (indexPrimArray inputMapping fromIndex)) else Nothing+            mTo = if toIndex >= 0 && toIndex < len then Just (VertexId (indexPrimArray inputMapping toIndex)) else Nothing+        in case (mFrom, mTo) of+          (Just from, Just to) -> pure (from, to)+          _ -> fail "constraint benchmark endpoint is out of range"+      )+      requestIndices+  batch <- timedValue "cdt/recovery" (requireRight (recoverConstraints cdt pairs))+  putStrLn ("cdt/recovery-stats: " <> show (constraintBatchStats batch))++-- Ruppert refinement on a constrained square. The Steiner budget is the+-- variable of interest: both the encroachment search and the outer-region+-- classification are per-insertion costs, so their growth shows as a widening+-- gap between the two budgets rather than in either figure alone.+benchmarkRefinement :: Int -> IO ()+benchmarkRefinement steinerBudget = do+  cdtBuild <- requireRight $ constrainedDelaunay+    unitElementDefaults+    (V.fromList [Point 0 0, Point 64 0, Point 64 64, Point 0 64, Point 20 20, Point 44 44] :: V.Vector (Point))+    (V.fromList [(0, 1), (1, 2), (2, 3), (3, 0), (4, 5)])+  let cdt :: ConstrainedDelaunayTriangulation (Point)+      cdt = buildTriangulation cdtBuild+      parameters :: Int -> RefinementParameters+      parameters budget = defaultRefinementParameters+        { refineMaxAdditionalVertices = Just budget+        , refineMaxArea = Just 0.5+        , refineMaxRadiusEdgeRatio = Just 1.0+        , refineExcludeOuterFaces = True+        , refineKeepConstraintEdges = False+        }+  forM_ [steinerBudget `quot` 4, steinerBudget] $ \budget -> do+    refined <- timedValue ("refine/steiner-" <> show budget) (requireRight (refine id (parameters budget) cdt))+    let stats = refinementStats refined+    putStrLn ("refine-added/" <> show budget <> ": " <> show (refinementAddedVertices refined))+    putStrLn+      ( "refine-work/"+          <> show budget+          <> ": location-steps="+          <> show (statLocationWalkSteps stats)+          <> ", face-checks="+          <> show (statRefinementFaceChecks stats)+          <> ", queue-pops="+          <> show (statRefinementQueuePops stats)+          <> ", flips="+          <> show (statEdgeFlips stats)+      )++canonicalEdges :: Triangulation mode vertex directed undirected face -> [(Point, Point)]+canonicalEdges triangulation =+  sort+    [ ordered (vertexPoint triangulation (origin triangulation edge)) (vertexPoint triangulation (destination triangulation edge))+    | undirected <- undirectedEdges triangulation+    , let edge = normalizedDirected undirected+    ]+ where+  ordered :: Ord value => value -> value -> (value, value)+  ordered left right = if left <= right then (left, right) else (right, left)
+ bench/dcel/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.DcelBench as DcelBench++main :: IO ()+main = DcelBench.benchmarks
+ bench/dcel/Moonlight/Triangulation/DcelBench.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# 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+  ( latticeFaceBand+  , latticePoints+  , randomPoints+  )+import BenchMeasure (requireRight, timedValue)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import qualified Data.List as List+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.FloodFillIterator (edgesInCircle)+import Moonlight.Triangulation.IntersectionIterator (lineIntersections)++benchmarks :: IO ()+benchmarks = do+  benchmarkQueries 20_000 10_000+  benchmarkRegionWorkload 440 272 22++benchmarkQueries :: Int -> Int -> IO ()+benchmarkQueries pointCount queryCount = do+  built <- requireRight (delaunay unitElementDefaults (V.fromList (randomPoints 0xbf58476d1ce4e5b9 pointCount)))+  circleEdges <- requireRight (edgesInCircle (buildTriangulation built) (Point 0 0) 0.25)+  queries <-+    requireRight+      (traverse mkQueryPoint (V.fromList (take (2 * queryCount) (randomPoints 0x632be59bd9b4e019 (2 * queryCount)))))+  let triangulation = buildTriangulation built+      total = V.ifoldl' (lineCount triangulation queries queryCount) 0 (V.take queryCount queries)+      shapeTotal = length circleEdges+  _ <- timedValue "line-and-shape-queries" (pure (total, shapeTotal))+  pure ()+ where+  lineCount+    :: DelaunayTriangulation (Point)+    -> V.Vector (QueryPoint)+    -> Int+    -> Int+    -> Int+    -> QueryPoint+    -> Int+  lineCount triangulation queries stride !accumulator index from =+    accumulator + length (lineIntersections triangulation from (queries V.! (index + stride)))++-- | 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 (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+          ( List.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/dual/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.DualBench as DualBench++main :: IO ()+main = DualBench.benchmarks
+ bench/dual/Moonlight/Triangulation/DualBench.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NumericUnderscores #-}++-- | The dual side: Delaunay-hierarchy hints against an unhinted walk, and+-- natural-neighbour interpolation over a reused workspace. Both report+-- allocation, because the claim in each case is about work avoided rather than+-- time taken.+module Moonlight.Triangulation.DualBench (benchmarks) where++import BenchMeasure (requireRight, timedValue)+import BenchSupport (randomPoints)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Monad.ST (stToIO)+import qualified Data.Vector as V+import GHC.Exts (RealWorld)+import GHC.Stats (RTSStats (allocated_bytes), getRTSStats, getRTSStatsEnabled)+import Moonlight.Triangulation+import Moonlight.Triangulation.HintGenerator+  ( HierarchyHint+  , buildHierarchyHint+  , defaultHierarchyBranchFactor+  , hierarchyHint+  , hierarchyLevelCount+  , hierarchyVertexCount+  )+import Moonlight.Triangulation.Interpolation+  ( NaturalNeighborWorkspace+  , interpolateNaturalNeighbor+  , newNaturalNeighborWorkspace+  , workspaceBytes+  )+import System.Mem (performGC)++benchmarks :: IO ()+benchmarks = do+  benchmarkHierarchy 20_000 5_000+  benchmarkSibson 10_000 5_000++benchmarkHierarchy :: Int -> Int -> IO ()+benchmarkHierarchy pointCount queryCount = do+  built <- requireRight (delaunay unitElementDefaults (V.fromList (randomPoints 0x123456789abcdef pointCount)))+  queries <-+    requireRight+      (traverse mkQueryPoint (V.fromList (take queryCount (randomPoints 0x3141592653589793 queryCount))))+  let triangulation = buildTriangulation built+  hierarchy <- requireRight (buildHierarchyHint defaultHierarchyBranchFactor triangulation)+  (_, baselineSteps) <- timedValue "nearest/no-hierarchy" (evaluate (force (walkTotal triangulation Nothing queries)))+  (_, hierarchySteps) <- timedValue "nearest/delaunay-hierarchy" (evaluate (force (walkHierarchyTotal triangulation hierarchy queries)))+  putStrLn ("hierarchy-levels: " <> show (hierarchyLevelCount hierarchy))+  putStrLn ("hierarchy-vertices: " <> show (hierarchyVertexCount hierarchy))+  putStrLn ("nearest-walk-steps/no-hierarchy: " <> show baselineSteps)+  putStrLn ("nearest-walk-steps/hierarchy: " <> show hierarchySteps)+ where+  walkTotal+    :: DelaunayTriangulation (Point)+    -> Maybe VertexId+    -> V.Vector (QueryPoint)+    -> (Int, Int)+  walkTotal triangulation hint queries = V.foldl' step (0 :: Int, 0 :: Int) queries+   where+    step (!count, !steps) query =+      case nearestNeighbor triangulation hint query of+        Nothing -> (count, steps)+        Just (_, stats) -> (count + 1, steps + nearestWalkSteps stats)++  walkHierarchyTotal+    :: DelaunayTriangulation (Point)+    -> HierarchyHint+    -> V.Vector (QueryPoint)+    -> (Int, Int)+  walkHierarchyTotal triangulation hierarchy queries = V.foldl' step (0 :: Int, 0 :: Int) queries+   where+    step (!count, !steps) query =+      let hint = case hierarchyHint hierarchy query of+            Just (VertexHint vertex) -> Just vertex+            _ -> Nothing+       in case nearestNeighbor triangulation hint query of+            Nothing -> (count, steps)+            Just (_, stats) -> (count + 1, steps + nearestWalkSteps stats)++benchmarkSibson :: Int -> Int -> IO ()+benchmarkSibson pointCount queryCount = do+  built <- requireRight (delaunay unitElementDefaults (V.fromList (randomPoints 0x8cb92baa3f3d8dd7 pointCount)))+  queries <-+    requireRight+      (traverse mkQueryPoint (V.fromList (take queryCount (randomPoints 0xdb4f0b9175ae2165 queryCount))))+  let triangulation = buildTriangulation built+      height vertex =+        let Point x y = vertexPoint triangulation vertex+         in x * x + 0.5 * y+  workspace <- stToIO (newNaturalNeighborWorkspace triangulation)+  putStrLn ("sibson-workspace-bytes: " <> show (workspaceBytes workspace))+  statsEnabled <- getRTSStatsEnabled+  if statsEnabled then performGC else pure ()+  before <- if statsEnabled then Just <$> getRTSStats else pure Nothing+  _ <- timedValue "sibson/reused-workspace" (queryLoop workspace height queries)+  after <- if statsEnabled then Just <$> getRTSStats else pure Nothing+  case (before, after) of+    (Just left, Just right) -> do+      let allocated = allocated_bytes right - allocated_bytes left+          perQuery = fromIntegral allocated / fromIntegral queryCount :: Double+      putStrLn ("sibson-allocated-bytes-total: " <> show allocated)+      putStrLn ("sibson-allocated-bytes/query: " <> show perQuery)+    _ -> putStrLn "sibson allocation counters unavailable; run with +RTS -T"+ where+  queryLoop+    :: NaturalNeighborWorkspace RealWorld 'Unconstrained (Point) () () ()+    -> (VertexId -> Double)+    -> V.Vector (QueryPoint)+    -> IO Double+  queryLoop workspace height queries = go 0 0+   where+    !count = V.length queries+    go !index !total+      | index >= count = evaluate total+      | otherwise = do+          (value, _) <- stToIO (interpolateNaturalNeighbor height workspace Nothing (queries V.! index))+          go (index + 1) (total + maybe 0 id value)
+ bench/hex/Main.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NumericUnderscores #-}++module Main (main) where++import BenchMeasure (requireRight, timedValue)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Data.List.NonEmpty (NonEmpty (..))+import Moonlight.Hex.Coordinate (HexCoord (..), HexDirection (HexNorthEast))+import Moonlight.Hex.Region++main :: IO ()+main = do+  benchmarkPackedAlgebra "hex-4096" 1024 4+  benchmarkPackedAlgebra "hex-1048576" 1024 1024+  benchmarkPackedAlgebra "hex-16777216" 4096 4096++benchmarkPackedAlgebra :: String -> Int -> Int -> IO ()+benchmarkPackedAlgebra label width height = do+  layout <- requireRight (hexLayout (HexCoord 0 0) width height)+  left <- evaluate (force (hexRegionGenerate layout leftPredicate))+  right <- evaluate (force (hexRegionGenerate layout rightPredicate))+  let cells = hexLayoutCellCount layout+      wordsVisited = hexLayoutWordCount layout+  putStrLn+    ( label+        <> "-layout: cells="+        <> show cells+        <> " words="+        <> show wordsVisited+    )+  unionRegion <- timedValue (label <> "-union") (requireRight (hexRegionUnion left right))+  intersectionRegion <- timedValue (label <> "-intersection") (requireRight (hexRegionIntersection left right))+  differenceRegion <- timedValue (label <> "-difference") (requireRight (hexRegionDifference left right))+  symmetricRegion <- timedValue (label <> "-symmetric-difference") (requireRight (hexRegionSymmetricDifference left right))+  complemented <- timedValue (label <> "-complement") (evaluate (complementHexRegion left))+  generated <- timedValue (label <> "-generate") (evaluate (hexRegionGenerate layout generatedPredicate))+  neighbourCount <-+    timedValue+      (label <> "-neighbour")+      ( evaluate+          (countRepeatedNeighbourLookups cells layout (HexCoord 1 1))+      )+  restricted <- benchmarkRestriction label layout left+  glued <- benchmarkGluing label width height+  putStrLn+    ( label+        <> "-receipt: cardinalities="+        <> show+          ( hexRegionCardinality left+          , hexRegionCardinality right+          , hexRegionCardinality unionRegion+          , hexRegionCardinality intersectionRegion+          , hexRegionCardinality differenceRegion+          , hexRegionCardinality symmetricRegion+          , hexRegionCardinality complemented+          , hexRegionCardinality generated+          , hexRegionCardinality restricted+          , hexRegionCardinality glued+          )+        <> " neighbours="+        <> show neighbourCount+    )++benchmarkRestriction :: String -> HexLayout -> HexRegion -> IO HexRegion+benchmarkRestriction label layout source = do+  let targetHeight = max 1 (hexLayoutHeight layout `quot` 2)+  target <- requireRight (hexLayout (hexLayoutOrigin layout) (hexLayoutWidth layout) targetHeight)+  timedValue (label <> "-restriction") (requireRight (restrictHexRegion target source))++benchmarkGluing :: String -> Int -> Int -> IO HexRegion+benchmarkGluing label width height = do+  let quarter = max 1 (width `quot` 4)+      localWidth = width - quarter+      membership (HexCoord q r) = (q + 3 * r) `mod` 7 <= 2+  leftLayout <- requireRight (hexLayout (HexCoord 0 0) localWidth height)+  rightLayout <- requireRight (hexLayout (HexCoord quarter 0) localWidth height)+  left <- evaluate (force (hexRegionGenerate leftLayout membership))+  right <- evaluate (force (hexRegionGenerate rightLayout membership))+  timedValue+    (label <> "-gluing")+    (requireRight (glueCompatibleHexRegions (left :| [right])))++leftPredicate :: HexCoord -> Bool+leftPredicate (HexCoord q r) = (q + r) `mod` 3 /= 0++rightPredicate :: HexCoord -> Bool+rightPredicate (HexCoord q r) = (2 * q - r) `mod` 5 <= 1++generatedPredicate :: HexCoord -> Bool+generatedPredicate (HexCoord q r) = mixedCoordinate q r `mod` 11 == 0++mixedCoordinate :: Int -> Int -> Int+mixedCoordinate left right = (left + right) * (left - right)++countRepeatedNeighbourLookups :: Int -> HexLayout -> HexCoord -> Int+countRepeatedNeighbourLookups repetitions layout coordinate = descend repetitions 0+ where+  descend :: Int -> Int -> Int+  descend !remaining !count+    | remaining <= 0 = count+    | otherwise =+        descend+          (remaining - 1)+          (maybe count (const (count + 1)) (hexNeighbourCoord layout coordinate HexNorthEast))
+ bench/join/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.JoinBench as JoinBench++main :: IO ()+main = JoinBench.benchmarks
+ bench/join/Moonlight/Triangulation/JoinBench.hs view
@@ -0,0 +1,1009 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NumericUnderscores #-}++-- | What the join costs, and against what.+--+-- These lanes compare the public union schedules with rebuild, local insertion,+-- and explicit canonical observation. Schedule claims live or die by these+-- measurements rather than by asymptotic theatre.+module Moonlight.Triangulation.JoinBench+  ( benchmarks+  , publicationBenchmarks+  ) where++import BenchMeasure (requireRight, timedValue)+import BenchSupport (randomPoints)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Monad (foldM, unless)+import Data.List (sort, sortBy)+import Data.Ord (comparing)+import qualified Data.Set as Set+import qualified Data.Vector as V+import Data.Word (Word64)+import Moonlight.Triangulation+import Moonlight.Triangulation.BulkLoad (insertMany)+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.Types (BuildStats, RefinementResult (refinementStats))+import Moonlight.Triangulation.Internal.BoxedPaged (boxedMaterializedPageCount)+import Moonlight.Triangulation.Internal.Paged (pagedOverlayPageCount)+import Moonlight.Triangulation.Internal.PointIndex (lookupPointIndex)+import Moonlight.Triangulation.Internal.Representation+  ( Triangulation+      ( triConstraint+      , triDirectedData+      , triFaceData+      , triFaceEdge+      , triHalfTopology+      , triPointIndex+      , triPointX+      , triPointY+      , triUndirectedData+      , triVertexData+      , triVertexOut+      )+  )+import System.Mem (performGC)++type Mesh = DelaunayTriangulation ()+type SiteMesh = DelaunayTriangulation (Point)+type ConstrainedMesh = ConstrainedDelaunayTriangulation ()++data ExtensionSignature = ExtensionSignature+  { extensionOmegaGeometry :: !(Set.Set (Point, Point, Point))+  , extensionGammaGeometry :: !(Set.Set (Point, Point))+  , extensionSeamGeometry :: !(Set.Set (Point, Point, Point))+  , extensionConstraintGeometry :: !(Set.Set (Point, Point))+  }+  deriving stock (Eq, Show)++data PreparedSeparatedExtension = PreparedSeparatedExtension+  { preparedBase :: !ConstrainedMesh+  , preparedExtension :: !ConstrainedMesh+  , preparedSignature :: !ExtensionSignature+  }++-- | The scale comparison retains only observations emitted by the local+-- interpreters.  Resident face count is deliberately absent: it is the+-- independent variable, not permission to normalize local work by A.+data ExtensionLocalityReceipt = ExtensionLocalityReceipt+  { extensionLocalitySeamPublication :: !PublicationStats+  , extensionLocalityRefinementPublication :: !PublicationStats+  , extensionLocalityCachedFrontierPointReads :: !Int+  , extensionLocalityValidationClosure :: !ValidationClosureStats+  , extensionLocalityRefinementStats :: !BuildStats+  , extensionLocalityFinalOmegaGeometry :: !(Set.Set (Point, Point, Point))+  , extensionLocalityAddedVertices :: !Int+  , extensionLocalityFinalOmegaFaces :: !Int+  , extensionLocalityTouchedEdges :: !Int+  , extensionLocalityCreatedFaces :: !Int+  , extensionLocalityInterfaceReads :: !Int+  , extensionLocalityBoundaryCrossings :: !Int+  }+  deriving stock (Eq, Show)++rectangleBoundarySites :: Double -> Double -> [Point]+rectangleBoundarySites left right =+  [ Point left (-1)+  , Point right (-1)+  ]+    <> fmap (Point right) [-0.75, -0.5, -0.25, 0, 0.25, 0.5, 0.75]+    <> [Point right 1, Point left 1]++rectangleCollarSites :: Double -> Double -> [Point]+rectangleCollarSites left right =+  let ys = [-0.75, -0.5, -0.25, 0, 0.25, 0.5, 0.75]+      width = right - left+   in fmap (Point (left + 0.2 * width)) ys+        <> fmap (Point (right - 0.2 * width)) ys++rectangleWorldSites :: Word64 -> Int -> Double -> Double -> [Point]+rectangleWorldSites seed count left right =+  rectangleFixedSites left right+    <> fmap+      (\(Point x y) ->+         Point+           (left + 0.35 * (right - left) + 0.15 * (right - left) * (x + 1))+           (-0.6 + 0.6 * (y + 1)))+      (randomPoints seed (max 0 (count - length (rectangleFixedSites left right))))++rectangleFixedSites :: Double -> Double -> [Point]+rectangleFixedSites left right = rectangleBoundarySites left right <> rectangleCollarSites left right++rectangleContour :: Int -> [(Int, Int)]+rectangleContour count =+  [ (index, (index + 1) `mod` count)+  | index <- [0 .. count - 1]+  ]++rectangleConstraintPairs :: [(Int, Int)]+rectangleConstraintPairs =+  rectangleContour boundaryCount+    <> chain collarLeftStart+    <> chain collarRightStart+ where+  boundaryCount = length (rectangleBoundarySites 0 1)+  collarLength = length (rectangleCollarSites 0 1) `quot` 2+  collarLeftStart = boundaryCount+  collarRightStart = collarLeftStart + collarLength+  chain start =+    [ (start + index, start + index + 1)+    | index <- [0 .. collarLength - 2]+    ]++contourPairs :: [Point] -> [(Point, Point)]+contourPairs points =+  case points of+    [] -> []+    first : rest -> zip points (rest <> [first])++orderedPointPair :: (Point, Point) -> (Point, Point)+orderedPointPair (first, second)+  | first <= second = (first, second)+  | otherwise = (second, first)++contourGeometry :: [Point] -> Set.Set (Point, Point)+contourGeometry = Set.fromList . fmap orderedPointPair . contourPairs++rectangleConstraintGeometry :: Double -> Double -> Set.Set (Point, Point)+rectangleConstraintGeometry left right =+  let boundary = rectangleBoundarySites left right+      collar = rectangleCollarSites left right+      collarLength = length collar `quot` 2+      (leftCollar, rightCollar) = splitAt collarLength collar+   in Set.unions+        [ contourGeometry boundary+        , openChainGeometry leftCollar+        , openChainGeometry rightCollar+        ]++openChainGeometry :: [Point] -> Set.Set (Point, Point)+openChainGeometry points =+  Set.fromList+    [ orderedPointPair pair+    | pair <- zip points (drop 1 points)+    ]++constraintGeometry :: ConstrainedMesh -> Set.Set (Point, Point)+constraintGeometry mesh =+  Set.fromList+    [ orderedPointPair (segmentStart segment, segmentEnd segment)+    | segment <- V.toList (constraintSegments mesh)+    ]++constrainedGeometryMesh :: [Point] -> IO ConstrainedMesh+constrainedGeometryMesh points =+  geometryOnlyPublication . buildTriangulation+    <$> requireRight+      ( constrainedDelaunay+          unitElementDefaults+          (V.fromList points)+          (V.fromList rectangleConstraintPairs)+      )++boundaryOfPermittedFaces+  :: ConstrainedMesh+  -> Set.Set FaceId+  -> Set.Set UndirectedEdgeId+boundaryOfPermittedFaces mesh faces =+  Set.fromList+    [ asUndirected edge+    | face <- Set.toList faces+    , edge <- Dcel.faceDirectedEdges mesh face+    , let adjacent = Dcel.incidentFace mesh (reverseEdge edge)+    , adjacent /= Dcel.outerFace+    , Set.notMember adjacent faces+    ]++faceGeometry :: ConstrainedMesh -> FaceId -> Maybe (Point, Point, Point)+faceGeometry mesh face =+  case sort (fmap (Dcel.vertexPoint mesh) (Dcel.faceVertices mesh face)) of+    [first, second, third] -> Just (first, second, third)+    _ -> Nothing++faceGeometrySet+  :: ConstrainedMesh+  -> Set.Set FaceId+  -> Either String (Set.Set (Point, Point, Point))+faceGeometrySet mesh faces =+  Set.fromList+    <$> traverse+      (\face ->+         maybe+           (Left ("local refinement receipt named a non-triangular face: " <> show face))+           Right+           (faceGeometry mesh face))+      (Set.toList faces)++edgeGeometry :: ConstrainedMesh -> UndirectedEdgeId -> (Point, Point)+edgeGeometry mesh edge =+  let (fromVertex, toVertex) = Dcel.undirectedEndpoints mesh edge+   in orderedPointPair+        (Dcel.vertexPoint mesh fromVertex, Dcel.vertexPoint mesh toVertex)++extensionSignature :: ConstrainedSeamResult () -> Either String ExtensionSignature+extensionSignature receipt =+  let joined = constrainedSeamResultTriangulation receipt+      permitted =+        Set.union+          (Set.fromList (fmap constrainedSeamTargetFace (V.toList (constrainedSeamRightFaceEvidence receipt))))+          (Set.fromList (V.toList (constrainedSeamJoinFaces receipt)))+      interface = boundaryOfPermittedFaces joined permitted+   in do+        seamFaces <-+          Set.fromList+            <$> traverse+              (\face ->+                 case faceGeometry joined face of+                   Just geometry -> Right geometry+                   Nothing -> Left "seam receipt named a non-triangular face")+              (V.toList (constrainedSeamJoinFaces receipt))+        let omegaFaces =+              Set.union+                ( Set.fromList+                    [ ( constrainedSeamFaceFirstPoint evidence+                      , constrainedSeamFaceSecondPoint evidence+                      , constrainedSeamFaceThirdPoint evidence+                      )+                    | evidence <- V.toList (constrainedSeamRightFaceEvidence receipt)+                    ]+                )+                seamFaces+        pure+          ExtensionSignature+            { extensionOmegaGeometry = omegaFaces+            , extensionGammaGeometry = Set.fromList (fmap (edgeGeometry joined) (Set.toList interface))+            , extensionSeamGeometry = seamFaces+            , extensionConstraintGeometry = constraintGeometry joined+            }++refinementInterfaceGeometry :: ConstrainedMesh -> Set.Set FaceId -> Set.Set (Point, Point)+refinementInterfaceGeometry mesh faces =+  Set.fromList+    [ edgeGeometry mesh edge+    | edge <- Set.toList (boundaryOfPermittedFaces mesh faces)+    ]++assertLocalPublicationStats :: String -> PublicationStats -> IO ()+assertLocalPublicationStats label stats = do+  unless (publicationUnboxedBasePageEnumerations stats == 0) $+    fail (label <> " enumerated resident unboxed base pages")+  unless (publicationUnboxedBasePageFreezes stats == 0) $+    fail (label <> " froze resident unboxed base pages")+  unless (publicationBoxedBasePageEnumerations stats == 0) $+    fail (label <> " enumerated resident boxed base pages")+  unless (publicationBoxedBasePageFreezes stats == 0) $+    fail (label <> " froze resident boxed base pages")++-- These are post-publication representation observations. They do not count+-- base-page opens or freeze enumeration and therefore are not a proof that+-- those events were absent from the timed action.+publicationPageReceipt :: ConstrainedMesh -> (Int, Int)+publicationPageReceipt mesh =+  ( sum+      [ pagedOverlayPageCount (triPointX mesh)+      , pagedOverlayPageCount (triPointY mesh)+      , pagedOverlayPageCount (triVertexOut mesh)+      , pagedOverlayPageCount (triHalfTopology mesh)+      , pagedOverlayPageCount (triFaceEdge mesh)+      , pagedOverlayPageCount (triConstraint mesh)+      ]+  , sum+      [ boxedMaterializedPageCount (triVertexData mesh)+      , boxedMaterializedPageCount (triDirectedData mesh)+      , boxedMaterializedPageCount (triUndirectedData mesh)+      , boxedMaterializedPageCount (triFaceData mesh)+      ]+  )++benchmarks :: IO ()+benchmarks = do+  benchmarkBalanced 20_000+  benchmarkSeparated 20_000+  benchmarkSkew 20_000 200+  benchmarkOverlap 20_000+  benchmarkTournament 20_000 16+  benchmarkSpatialTournament 20_000 16+  benchmarkTournamentScaling 20_000+  benchmarkCanonicalize 20_000+  benchmarkSetAlgebra 20_000++publicationBenchmarks :: IO ()+publicationBenchmarks = do+  -- These are face bands, not site-count labels.  A planar Delaunay mesh is+  -- approximately twice as many faces as sites, so the resident fixtures use+  -- 125k and 250k sites to exercise the requested 250k/500k-face lanes, and+  -- the incoming small world uses 15k sites for its approximately 30k faces.+  prepared250k <- preparePersistentSeparatedExtension 125_000 15_000+  prepared500k <- preparePersistentSeparatedExtension 250_000 15_000+  assertFaceBand "250k-faces" 245_000 255_000 (preparedBase prepared250k)+  assertFaceBand "500k-faces" 490_000 510_000 (preparedBase prepared500k)+  assertFaceBand "30k-extension-faces" 29_000 31_000 (preparedExtension prepared250k)+  assertFaceBand "30k-extension-faces-repeat" 29_000 31_000 (preparedExtension prepared500k)+  unless (preparedSignature prepared250k == preparedSignature prepared500k) $+    fail "separated extension changed its fixed collar, Gamma, or seam geometry across A sizes"+  receipt250k <- benchmarkPersistentSeparatedExtension "250k-faces" prepared250k+  receipt500k <- benchmarkPersistentSeparatedExtension "500k-faces" prepared500k+  assertIdenticalFrontierLocality receipt250k receipt500k++assertIdenticalFrontierLocality+  :: ExtensionLocalityReceipt+  -> ExtensionLocalityReceipt+  -> IO ()+assertIdenticalFrontierLocality smaller larger = do+  assertPublicationAccounting "250k seam" (extensionLocalitySeamPublication smaller)+  assertPublicationAccounting "500k seam" (extensionLocalitySeamPublication larger)+  assertPublicationAccounting "250k refinement" (extensionLocalityRefinementPublication smaller)+  assertPublicationAccounting "500k refinement" (extensionLocalityRefinementPublication larger)+  assertPageAlignedPublicationLocality+    "seam"+    (extensionLocalitySeamPublication smaller)+    (extensionLocalitySeamPublication larger)+  assertPageAlignedPublicationLocality+    "refinement"+    (extensionLocalityRefinementPublication smaller)+    (extensionLocalityRefinementPublication larger)+  unless+    ( extensionLocalityCachedFrontierPointReads smaller+        == extensionLocalityCachedFrontierPointReads larger+    ) $+    fail "identical-frontier cached-read work grew with resident A"+  unless+    ( extensionLocalityValidationClosure smaller+        == extensionLocalityValidationClosure larger+    ) $+    fail "identical local refinement produced an A-dependent validation closure"+  unless+    ( and+        [ extensionLocalityRefinementStats smaller == extensionLocalityRefinementStats larger+        , extensionLocalityFinalOmegaGeometry smaller == extensionLocalityFinalOmegaGeometry larger+        , extensionLocalityAddedVertices smaller == extensionLocalityAddedVertices larger+        , extensionLocalityFinalOmegaFaces smaller == extensionLocalityFinalOmegaFaces larger+        , extensionLocalityTouchedEdges smaller == extensionLocalityTouchedEdges larger+        , extensionLocalityCreatedFaces smaller == extensionLocalityCreatedFaces larger+        , extensionLocalityInterfaceReads smaller == extensionLocalityInterfaceReads larger+        , extensionLocalityBoundaryCrossings smaller == extensionLocalityBoundaryCrossings larger+        ]+    ) $+    fail "identical-frontier refinement changed its canonical local work receipt"++-- The receipt counts page opens and copied cells at the storage boundary.  It+-- intentionally does not update a counter for every logical cell write: that+-- instrumentation used to put a strict fourteen-field STRef update on every+-- dense build mutation.  Local page accounting is exact and remains the+-- observation used by the extension lane.+assertPublicationAccounting :: String -> PublicationStats -> IO ()+assertPublicationAccounting label stats = do+  unless+    ( publicationUnboxedBasePageOpens stats+        == publicationUnboxedDirtyBasePages stats+        && publicationBoxedBasePageOpens stats+          == publicationBoxedDirtyBasePages stats+        && publicationUnboxedCopiedCells stats+          <= 1_024 * publicationUnboxedBasePageOpens stats+        && publicationBoxedCopiedCells stats+          <= 256 * publicationBoxedBasePageOpens stats+    ) $+    fail (label <> " page publication accounting is inconsistent")++-- A larger resident shifts the same local write intervals within fixed-size+-- pages.  At most two interval boundaries per store may therefore change page+-- classification or copy one extra page; the semantic local-work receipt below+-- remains exact.+assertPageAlignedPublicationLocality :: String -> PublicationStats -> PublicationStats -> IO ()+assertPageAlignedPublicationLocality label smaller larger = do+  let unboxedPageSlack :: Int+      unboxedPageSlack = 2 * 6+      boxedPageSlack :: Int+      boxedPageSlack = 2 * 4+      dirtyUnboxed :: PublicationStats -> Int+      dirtyUnboxed stats =+        publicationUnboxedDirtyBasePages stats+          + publicationUnboxedDirtyAppendedPages stats+      dirtyBoxed :: PublicationStats -> Int+      dirtyBoxed stats =+        publicationBoxedDirtyBasePages stats+          + publicationBoxedDirtyAppendedPages stats+      within :: Int -> Int -> Int -> Bool+      within slack left right = abs (left - right) <= slack+  unless+    ( and+        [ within unboxedPageSlack (dirtyUnboxed smaller) (dirtyUnboxed larger)+        , within (1_024 * unboxedPageSlack) (publicationUnboxedCopiedCells smaller) (publicationUnboxedCopiedCells larger)+        , within boxedPageSlack (dirtyBoxed smaller) (dirtyBoxed larger)+        , within (256 * boxedPageSlack) (publicationBoxedCopiedCells smaller) (publicationBoxedCopiedCells larger)+        ]+    ) $+    fail ("identical-frontier " <> label <> " publication escaped its fixed page-alignment envelope")++assertFaceBand :: String -> Int -> Int -> ConstrainedMesh -> IO ()+assertFaceBand label lower upper mesh = do+  let actual = numFaces mesh+  unless (lower <= actual && actual <= upper) $+    fail+      ( "publication-separated-"+          <> label+          <> " expected base faces in ["+          <> show lower+          <> ","+          <> show upper+          <> "], got "+          <> show actual+      )++benchmarkIndexedSupportContexts :: Int -> Int -> IO ()+benchmarkIndexedSupportContexts baseCount deltaCount = do+  let baseSites = randomPoints 0xcbbb9d5dc1059ed8 baseCount+      retainedSites = drop deltaCount baseSites+  benchmarkColdRelationWarmIntersection baseSites retainedSites+  performGC+  benchmarkColdIntersectionWarmRelation baseSites retainedSites+  performGC++benchmarkColdRelationWarmIntersection :: [Point] -> [Point] -> IO ()+benchmarkColdRelationWarmIntersection baseSites retainedSites = do+  base <- geometryMesh baseSites+  retained <- geometryMesh retainedSites+  _ <- evaluate (force (base, retained))+  relation <- timedValue "set-relation-near-full-cold-index" (evaluate (force (siteRelation base retained)))+  unless (relation == RightProperSubset) $+    fail "cold indexed relation misclassified the retained operand"+  forceExactPointIndex base baseSites+  benchmarkIndexedIntersection "set-intersection-near-full-warm-index" base retained++benchmarkColdIntersectionWarmRelation :: [Point] -> [Point] -> IO ()+benchmarkColdIntersectionWarmRelation baseSites retainedSites = do+  base <- geometryMesh baseSites+  retained <- geometryMesh retainedSites+  _ <- evaluate (force (base, retained))+  benchmarkIndexedIntersection "set-intersection-near-full-cold-index" base retained+  forceExactPointIndex base baseSites+  relation <- timedValue "set-relation-near-full-warm-index" (evaluate (force (siteRelation base retained)))+  unless (relation == RightProperSubset) $+    fail "warm indexed relation misclassified the retained operand"++benchmarkIndexedIntersection :: String -> Mesh -> Mesh -> IO ()+benchmarkIndexedIntersection label base retained = do+  result <- benchmarkValidatedSetOperation label (intersection base retained)+  observedCanonical <- evaluate . force =<< requireRight (canonicalize result)+  expectedCanonical <- evaluate . force =<< requireRight (canonicalize retained)+  unless (observedCanonical == expectedCanonical) $+    fail (label <> " disagreed with the retained operand")++forceExactPointIndex :: Mesh -> [Point] -> IO ()+forceExactPointIndex triangulation points =+  case points of+    [] -> fail "cannot warm a point index without a witness"+    witness : _ ->+      case+          lookupPointIndex+            (triPointX triangulation)+            (triPointY triangulation)+            (triPointIndex triangulation)+            witness+        of+          Nothing -> fail "point-index warmup missed its exact witness"+          Just vertex -> () <$ evaluate (force vertex)++-- | Two halves of one point set, joined.+--+-- The balanced pair rebuilds from its combined site set. The input-order and+-- ranked lanes distinguish ordinary construction from construction whose+-- vertex numbering is already canonical.+benchmarkBalanced :: Int -> IO ()+benchmarkBalanced total = do+  let sites = randomPoints 0x9e3779b97f4a7c15 total+      (left, right) = splitAt (total `div` 2) sites+  leftMesh <- geometryMesh left+  rightMesh <- geometryMesh right+  _ <- evaluate (force (leftMesh, rightMesh))+  _ <- timedValue "join-balanced" (requireRight (union leftMesh rightMesh))+  _ <- timedValue "join-balanced-rebuild-input-order" (geometryMesh sites)+  _ <- timedValue "join-balanced-rebuild-ranked-order" (geometryMesh (canonical sites))+  pure ()++-- | Two operands whose sites are separated by a vertical line.+--+-- This is the stratum a seam merge is defined on, and the number here is the+-- one it has to beat: the reference schedule does not know the operands are+-- separated and rebuilds the union regardless. A linear-time merge wins+-- asymptotically over an @O(n log n)@ rebuild; whether it wins at the sizes+-- anything actually merges at is this measurement and not an argument.+--+-- Three gap widths, because the seam's work is the cross-edge chain and the+-- deletions it drives, and how far the two clouds stand apart decides how much+-- of each interior the chain disturbs. A distant pair is the easy case — the+-- chain is short and nothing inside either operand dies. An abutting pair is+-- the hard one.+benchmarkSeparated :: Int -> IO ()+benchmarkSeparated total = do+  let half = total `div` 2+      sites = randomPoints 0xd1b54a32d192ed03 half+      extent = 2 * maximum [abs x | Point x _ <- sites]+  leftMesh <- geometryMesh sites+  _ <- evaluate (force leftMesh)+  mapM_+    ( \(name, gap) -> do+        let shifted = [Point (x + gap * extent) y | Point x y <- sites]+        rightMesh <- geometryMesh shifted+        _ <- evaluate (force rightMesh)+        _ <- timedValue ("join-separated-" <> name) (requireRight (union leftMesh rightMesh))+        pure ()+    )+    [("distant" :: String, 8), ("near", 2), ("abutting", 1.02)]++-- | A large mesh joined with a small one. Rebuilding costs the whole union;+-- inserting the small operand's sites into the large mesh costs only the+-- insertions. This is the ratio that says whether a skewed lane is worth+-- having, and it needs no new algorithm — 'insertMany' is already the+-- one-transaction batch path.+--+-- Both lanes carry the same vertex payload so the comparison is of the+-- schedules and not of the stores.+benchmarkSkew :: Int -> Int -> IO ()+benchmarkSkew large small = do+  let bulk = randomPoints 0xbf58476d1ce4e5b9 large+      addition = randomPoints 0x94d049bb133111eb small+  bulkMesh <- siteMesh bulk+  _ <- evaluate (force bulkMesh)+  _ <-+    timedValue+      "join-skew-rebuild"+      (siteMesh (canonical (bulk <> addition)))+  _ <-+    timedValue+      "join-skew-insert-many"+      (buildTriangulation <$> requireRight (insertMany bulkMesh (V.fromList addition)))+  pure ()++-- | Prepare the fixed-frontier workload once. The preview join is outside the+-- timed lanes: it certifies that changing only the resident interior did not+-- alter the B/J geometry or the exact Gamma section.+preparePersistentSeparatedExtension :: Int -> Int -> IO PreparedSeparatedExtension+preparePersistentSeparatedExtension baseCount extensionCount = do+  let baseSites = rectangleWorldSites 0x243f6a8885a308d3 baseCount (-1) 0+      extensionSites = rectangleWorldSites 0x13198a2e03707344 extensionCount 4 5+      expectedBaseConstraints = rectangleConstraintGeometry (-1) 0+      expectedExtensionConstraints = rectangleConstraintGeometry 4 5+  base <- constrainedGeometryMesh baseSites+  extension <- constrainedGeometryMesh extensionSites+  _ <- evaluate (force (base, extension))+  unless (constraintGeometry base == expectedBaseConstraints) $+    fail "fixed A collar constraints were not retained by the source build"+  unless (constraintGeometry extension == expectedExtensionConstraints) $+    fail "fixed B collar constraints were not retained by the source build"+  preview <- requireRight (joinSeparatedConstrained (\_ _ -> True) defaultRefinementParameters base extension)+  signature <- requireRight (extensionSignature preview)+  let expectedConstraints = Set.union expectedBaseConstraints expectedExtensionConstraints+      actualConstraints = extensionConstraintGeometry signature+  unless (expectedConstraints `Set.isSubsetOf` actualConstraints) $+    fail+      ( "source-preserving seam did not retain the fixed A/B contour constraints; missing="+          <> show (Set.toAscList (Set.difference expectedConstraints actualConstraints))+      )+  pure+    PreparedSeparatedExtension+      { preparedBase = base+      , preparedExtension = extension+      , preparedSignature = signature+      }++-- | The extension lane is the operation the persistent-world plan actually+-- promises: geometry-only publication prepares the two frontier indexes once,+-- the caller-left constrained source stays resident, and refinement is+-- restricted to the right-source faces plus the seam faces emitted by that+-- interpretation. Construction, frontier preparation, receipt descent, and+-- the final validity observation are outside the timed extension actions;+-- neither action invokes generic union, canonical numbering, or global+-- validation.+benchmarkPersistentSeparatedExtension :: String -> PreparedSeparatedExtension -> IO ExtensionLocalityReceipt+benchmarkPersistentSeparatedExtension label prepared = do+  let base = preparedBase prepared+      extension = preparedExtension prepared+  joinedReceipt <-+    timedValue+      ("publication-separated-" <> label <> "-join")+      (requireRight (joinSeparatedConstrained (\_ _ -> True) defaultRefinementParameters base extension))+  let joined = constrainedSeamResultTriangulation joinedReceipt+      permitted =+        Set.union+          (Set.fromList (fmap constrainedSeamTargetFace (V.toList (constrainedSeamRightFaceEvidence joinedReceipt))))+          (Set.fromList (V.toList (constrainedSeamJoinFaces joinedReceipt)))+      interface = boundaryOfPermittedFaces joined permitted+      parameters =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just 4_096+          , refineMaxArea = Just 0.0002+          , refineMaxRadiusEdgeRatio = Nothing+          , refineKeepConstraintEdges = True+          }+  signature <- requireRight (extensionSignature joinedReceipt)+  unless (signature == preparedSignature prepared) $+    fail ("publication-separated-" <> label <> " changed its prepared Omega/Gamma/J geometry")+  unless (refinementInterfaceGeometry joined permitted == extensionGammaGeometry signature) $+    fail ("publication-separated-" <> label <> " changed its certified Gamma geometry")+  refined <-+    timedValue+      ("publication-separated-" <> label <> "-local-refine")+      ( requireRight+          ( refineWithinDomain+              (const ())+              parameters+              permitted+              joined+          )+      )+  let result = refinementDomainResult refined+      receipt = refinementDomainReceipt refined+      seamPublication = constrainedSeamPublicationStats joinedReceipt+      refinementPublication = refinementPublicationStats receipt+      validationClosure = refinementValidationClosureStats receipt+      finalFaces = Set.fromList (V.toList (refinementFinalPermittedFaces receipt))+  finalOmegaGeometry <- requireRight (faceGeometrySet (refinedTriangulation result) finalFaces)+  assertLocalPublicationStats+    ("publication-separated-" <> label <> " seam")+    seamPublication+  assertLocalPublicationStats+    ("publication-separated-" <> label <> " refinement")+    refinementPublication+  unless+    ( publicationUnboxedDirtyBasePages seamPublication+        + publicationUnboxedDirtyAppendedPages seamPublication+        > 0+    ) $+    fail ("publication-separated-" <> label <> " seam published no appended unboxed writes")+  unless+    ( publicationUnboxedDirtyBasePages refinementPublication+        + publicationUnboxedDirtyAppendedPages refinementPublication+        > 0+    ) $+    fail ("publication-separated-" <> label <> " refinement published no appended unboxed writes")+  unless (refinementComplete result) $+    fail ("publication-separated-" <> label <> " exhausted its finite local refinement budget")+  unless (refinementInterfaceBoundaryReads receipt > 0) $+    fail ("publication-separated-" <> label <> " performed no positive Gamma-boundary descent")+  unless (refinementAddedVertices result > 0) $+    fail ("publication-separated-" <> label <> " performed no positive local refinement")+  case validateTriangulation (refinedTriangulation result) of+    [] -> pure ()+    violations -> fail ("publication-separated-" <> label <> " invalid: " <> show violations)+  putStrLn+    ( "publication-separated-"+        <> label+        <> "-base-faces="+        <> show (numFaces base)+        <> " extension-faces="+        <> show (numFaces extension)+        <> " receipt: omega="+        <> show (Set.size permitted)+        <> " b-faces="+        <> show (V.length (constrainedSeamRightFaceEvidence joinedReceipt))+        <> " j-faces="+        <> show (V.length (constrainedSeamJoinFaces joinedReceipt))+        <> " a-constraints="+        <> show (constrainedSeamLeftConstraintCount joinedReceipt)+        <> " gamma="+        <> show (Set.size interface)+        <> " final-omega="+        <> show (V.length (refinementFinalPermittedFaces receipt))+        <> " steiner="+        <> show (refinementAddedVertices result)+    )+  renderPublicationStats+    ("publication-separated-" <> label <> "-seam-publication")+    seamPublication+  putStrLn+    ( "publication-separated-"+        <> label+        <> "-seam-cached-frontier-point-reads="+        <> show (constrainedSeamCachedFrontierPointReads joinedReceipt)+    )+  renderPublicationStats+    ("publication-separated-" <> label <> "-refinement-publication")+    refinementPublication+  putStrLn+    ( "publication-separated-"+        <> label+        <> "-validation-closure: faces="+        <> show (validationClosureFaces validationClosure)+        <> " directed-edges="+        <> show (validationClosureDirectedEdges validationClosure)+        <> " vertices="+        <> show (validationClosureVertices validationClosure)+        <> " interface-pairs="+        <> show (validationClosureInterfacePairs validationClosure)+        <> " constraint-pairs="+        <> show (validationClosureConstraintPairs validationClosure)+    )+  let (unboxedOverlayPages, boxedMaterializedPages) = publicationPageReceipt (refinedTriangulation result)+  putStrLn+    ( "publication-separated-"+        <> label+        <> "-observed-final-pages: unboxed-overlay="+        <> show unboxedOverlayPages+        <> " boxed-materialized="+        <> show boxedMaterializedPages+        <> " local-touched-edges="+        <> show (V.length (refinementTouchedEdges receipt))+        <> " local-created-faces="+        <> show (V.length (refinementCreatedFaces receipt))+    )+  pure+    ExtensionLocalityReceipt+      { extensionLocalitySeamPublication = seamPublication+      , extensionLocalityRefinementPublication = refinementPublication+      , extensionLocalityCachedFrontierPointReads = constrainedSeamCachedFrontierPointReads joinedReceipt+      , extensionLocalityValidationClosure = validationClosure+      , extensionLocalityRefinementStats = refinementStats result+      , extensionLocalityFinalOmegaGeometry = finalOmegaGeometry+      , extensionLocalityAddedVertices = refinementAddedVertices result+      , extensionLocalityFinalOmegaFaces = Set.size finalFaces+      , extensionLocalityTouchedEdges = V.length (refinementTouchedEdges receipt)+      , extensionLocalityCreatedFaces = V.length (refinementCreatedFaces receipt)+      , extensionLocalityInterfaceReads = refinementInterfaceBoundaryReads receipt+      , extensionLocalityBoundaryCrossings = refinementAttemptedBoundaryCrossings receipt+      }++renderPublicationStats :: String -> PublicationStats -> IO ()+renderPublicationStats label stats =+  putStrLn+    ( label+        <> ": unboxed-base-enumerations="+        <> show (publicationUnboxedBasePageEnumerations stats)+        <> " unboxed-base-opens="+        <> show (publicationUnboxedBasePageOpens stats)+        <> " unboxed-base-freezes="+        <> show (publicationUnboxedBasePageFreezes stats)+        <> " unboxed-dirty-base-pages="+        <> show (publicationUnboxedDirtyBasePages stats)+        <> " unboxed-dirty-appended-pages="+        <> show (publicationUnboxedDirtyAppendedPages stats)+        <> " unboxed-copied-cells="+        <> show (publicationUnboxedCopiedCells stats)+        <> " boxed-base-enumerations="+        <> show (publicationBoxedBasePageEnumerations stats)+        <> " boxed-base-opens="+        <> show (publicationBoxedBasePageOpens stats)+        <> " boxed-base-freezes="+        <> show (publicationBoxedBasePageFreezes stats)+        <> " boxed-dirty-base-pages="+        <> show (publicationBoxedDirtyBasePages stats)+        <> " boxed-dirty-appended-pages="+        <> show (publicationBoxedDirtyAppendedPages stats)+        <> " boxed-copied-cells="+        <> show (publicationBoxedCopiedCells stats)+    )++benchmarkPersistentSetOperations :: Int -> Int -> IO ()+benchmarkPersistentSetOperations baseCount deltaCount = do+  let baseSites = randomPoints 0xcbbb9d5dc1059ed8 baseCount+      removedSites = take deltaCount baseSites+      retainedSites = drop deltaCount baseSites+      extensionSites =+        fmap+          (\(Point x y) -> Point (1.2 + 0.1 * x) y)+          (randomPoints 0x629a292a367cd507 deltaCount)+  base <- geometryMesh baseSites+  removed <- geometryMesh removedSites+  retained <- geometryMesh retainedSites+  extension <- geometryMesh extensionSites+  empty <- requireRight (unions [])+  _ <- evaluate (force (base, removed, retained, extension, empty))+  putStrLn ("set-publication-base-sites: " <> show (numVertices base))+  putStrLn ("set-publication-delta-sites: " <> show (numVertices removed))+  _ <- benchmarkValidatedSetOperation "set-publication-difference-right-empty" (difference base empty)+  _ <- benchmarkValidatedSetOperation "set-publication-symmetric-difference-left-empty" (symmetricDifference empty base)+  _ <- benchmarkValidatedSetOperation "set-publication-symmetric-difference-right-empty" (symmetricDifference base empty)+  benchmarkPublishedSetOperation+    "set-publication-difference-skew"+    (difference base removed)+    (pure retained)+  benchmarkPublishedSetOperation+    "set-publication-intersection-skew"+    (intersection base retained)+    (pure retained)+  benchmarkPublishedSetOperation+    "set-publication-symmetric-difference-disjoint-skew"+    (symmetricDifference base extension)+    (geometryMesh (baseSites <> extensionSites))+  benchmarkPublishedSetOperation+    "set-publication-symmetric-difference-small-output"+    (symmetricDifference base retained)+    (pure removed)++benchmarkPublishedSetOperation :: String -> Either BuildError Mesh -> IO Mesh -> IO ()+benchmarkPublishedSetOperation label operation expectedWitness = do+  result <- benchmarkValidatedSetOperation label operation+  observedCanonical <-+    timedValue+      (label <> "-explicit-canonicalize")+      (evaluate . force =<< requireRight (canonicalize result))+  expected <- expectedWitness+  expectedCanonical <- evaluate . force =<< requireRight (canonicalize expected)+  unless (observedCanonical == expectedCanonical) $+    fail (label <> " disagreed with the independently rebuilt witness")++benchmarkValidatedSetOperation :: String -> Either BuildError Mesh -> IO Mesh+benchmarkValidatedSetOperation label operation = do+  result <- timedValue label (evaluate . force =<< requireRight operation)+  case validateTriangulation result of+    [] -> pure ()+    violations -> fail (label <> " invalid: " <> show violations)+  pure result++-- | The same operand sizes at three overlap fractions. A join is sized by the+-- union, so wholly overlapping operands must cost what one of them costs.+benchmarkOverlap :: Int -> IO ()+benchmarkOverlap total = do+  let sites = randomPoints 0x2545f4914f6cdd1d total+      half = total `div` 2+  disjointLeft <- geometryMesh (take half sites)+  disjointRight <- geometryMesh (drop half sites)+  halfLeft <- geometryMesh (take half sites)+  halfRight <- geometryMesh (drop (half `div` 2) (take (half + half `div` 2) sites))+  sameLeft <- geometryMesh (take half sites)+  sameRight <- geometryMesh (reverse (take half sites))+  _ <- evaluate (force (disjointLeft, disjointRight, halfLeft, halfRight, sameLeft, sameRight))+  _ <- timedValue "join-overlap-000" (requireRight (union disjointLeft disjointRight))+  _ <- timedValue "join-overlap-050" (requireRight (union halfLeft halfRight))+  _ <- timedValue "join-overlap-100" (requireRight (union sameLeft sameRight))+  pure ()++-- | 'unions' is a balanced tournament and not a fold, which is a cost claim+-- and therefore has to be measured rather than asserted. A fold republishes an+-- accumulator that grows by one shard per step.+--+-- This lane once reported the fold as the faster of the two, which was true and+-- was not a fact about the schedules: @joinBalanced@ carried no specialization,+-- so every join inside the tournament ran through a dictionary while+-- the left-associated schedule at a known element type ran specialized. The tournament was+-- paying twice for arithmetic, and that swamped the asymptotic gap it was+-- supposed to be demonstrating.+--+-- The shards are dealt round-robin, so every one of them spans the whole extent+-- and no join in the tournament is separable. That is deliberate: it is the+-- adversarial sharding, and it measures the operator with no structure to+-- exploit. 'benchmarkSpatialTournament' is the same tournament over the+-- sharding a caller who wanted it to be fast would actually choose.+benchmarkTournament :: Int -> Int -> IO ()+benchmarkTournament total shardCount = do+  let sites = randomPoints 0x14057b7ef767814f total+      indexed = zip [0 :: Int ..] sites+  shards <-+    traverse+      (\shard -> geometryMesh [site | (index, site) <- indexed, index `mod` shardCount == shard])+      [0 .. shardCount - 1]+  _ <- evaluate (force shards)+  _ <- timedValue "join-tournament" (requireRight (unions shards))+  _ <- timedValue "join-left-fold" (requireRight (unionsLeftAssociated shards))+  pure ()++-- | Where the tournament's advantage over the fold actually appears.+--+-- A fold republishes an accumulator that grows by one shard per step, so it+-- rebuilds @Θ(nk)@ sites over @k@ shards where halving rebuilds @Θ(n log k)@.+-- That is a statement about @k@, and at the sixteen shards the lane above uses+-- the predicted factor is barely two — small enough to be swamped by the+-- per-join costs both schedules pay fifteen times each. This sweep is here+-- because a cost claim that only holds asymptotically has to say at what size+-- it starts holding, and the answer has to be measured rather than asserted.+benchmarkTournamentScaling :: Int -> IO ()+benchmarkTournamentScaling total =+  mapM_+    ( \shardCount -> do+        let sites = randomPoints 0x9e3779b97f4a7c15 total+            indexed = zip [0 :: Int ..] sites+        shards <-+          traverse+            (\shard -> geometryMesh [site | (index, site) <- indexed, index `mod` shardCount == shard])+            [0 .. shardCount - 1]+        _ <- evaluate (force shards)+        _ <- timedValue ("join-shards-" <> show shardCount <> "-tournament") (requireRight (unions shards))+        _ <- timedValue ("join-shards-" <> show shardCount <> "-fold") (requireRight (unionsLeftAssociated shards))+        pure ()+    )+    [4 :: Int, 16, 64]+++-- | The same tournament over shards cut by abscissa rather than dealt.+--+-- This is the workload a seam schedule exists for, and the only one where it+-- can pay off more than once. Shards cut into contiguous x-ranges are pairwise+-- separated; so is every intermediate result, because the union of two adjacent+-- ranges is a range. Every one of the fifteen joins in the tournament is+-- therefore separable — the tournament /is/ the divide-and-conquer recursion,+-- entered from the leaves.+--+-- Against the reference schedule this must cost about what the dealt+-- tournament costs, since a rebuild cannot tell the two shardings apart. That+-- agreement is the baseline; the gap that opens between these two lanes is the+-- whole return on a merge kernel.+benchmarkSpatialTournament :: Int -> Int -> IO ()+benchmarkSpatialTournament total shardCount = do+  let sites = randomPoints 0x3c6ef372fe94f82a total+      ordered = sortBy (comparing (\(Point x _) -> x)) sites+      width = (total + shardCount - 1) `div` shardCount+  shards <-+    traverse+      (\shard -> geometryMesh (take width (drop (shard * width) ordered)))+      [0 .. shardCount - 1]+  _ <- evaluate (force shards)+  _ <- timedValue "join-spatial-tournament" (requireRight (unions shards))+  pure ()++-- | The renumbering pass on its own, against the construction it follows.+benchmarkCanonicalize :: Int -> IO ()+benchmarkCanonicalize total = do+  let sites = randomPoints 0x27d4eb2f165667c5 total+  mesh <- geometryMesh sites+  _ <- evaluate (force mesh)+  _ <- timedValue "canonicalize-alone" (evaluate . force =<< requireRight (canonicalize mesh))+  pure ()++-- | The shared canonical rebuild boundary under half overlap, on both its+-- geometry-only specializations and its annotation-preserving surface. Setup+-- and source publication are forced before every clock; the measurements are+-- therefore the exact site classification, rebuild, canonical publication and+-- payload transport the public operations own.+benchmarkSetAlgebra :: Int -> IO ()+benchmarkSetAlgebra total = do+  let common = total `quot` 2+      sites = randomPoints 0x6A09E667F3BCC909 (total + common)+      leftPoints = take total sites+      rightPoints = drop common sites+  leftGeometry <- geometryMesh leftPoints+  rightGeometry <- geometryMesh rightPoints+  emptyGeometry <- requireRight (unions [])+  _ <- evaluate (force (leftGeometry, rightGeometry, emptyGeometry))+  _ <- timedValue "set-intersection-unit" (requireRight (intersection leftGeometry rightGeometry))+  _ <- timedValue "set-difference-unit" (requireRight (difference leftGeometry rightGeometry))+  _ <-+    timedValue+      "set-symmetric-difference-unit"+      (requireRight (symmetricDifference leftGeometry rightGeometry))+  _ <-+    timedValue+      "set-difference-right-empty"+      (requireRight (difference leftGeometry emptyGeometry))+  _ <-+    timedValue+      "set-symmetric-difference-left-empty"+      (requireRight (symmetricDifference emptyGeometry leftGeometry))+  _ <- timedValue "set-relation-half-overlap" (evaluate (siteRelation leftGeometry rightGeometry))+  leftAnnotated <- siteMesh leftPoints+  rightAnnotated <- siteMesh rightPoints+  _ <- evaluate (force (leftAnnotated, rightAnnotated))+  _ <-+    timedValue+      "set-intersection-annotated"+      (requireRight (intersectionWith (,) leftAnnotated rightAnnotated))+  _ <-+    timedValue+      "set-difference-annotated"+      (requireRight (difference leftAnnotated rightAnnotated))+  _ <-+    timedValue+      "set-symmetric-difference-annotated"+      (requireRight (symmetricDifference leftAnnotated rightAnnotated))+  pure ()+++canonical :: [Point] -> [Point]+canonical points = [Point x y | (x, y) <- dropAdjacentDuplicates (sort [(x, y) | Point x y <- points])]++dropAdjacentDuplicates :: Eq a => [a] -> [a]+dropAdjacentDuplicates (first : second : rest)+  | first == second = dropAdjacentDuplicates (second : rest)+  | otherwise = first : dropAdjacentDuplicates (second : rest)+dropAdjacentDuplicates rest = rest++geometryMesh :: [Point] -> IO Mesh+geometryMesh points = requireRight (delaunayGeometry (V.fromList points))++siteMesh :: [Point] -> IO SiteMesh+siteMesh points =+  buildTriangulation <$> requireRight (delaunay unitElementDefaults (V.fromList points))++unionsLeftAssociated :: [Mesh] -> Either BuildError Mesh+unionsLeftAssociated meshes = unions [] >>= \identity -> foldM union identity meshes
+ bench/layer/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import qualified Moonlight.Triangulation.LayerBench as LayerBench++main :: IO ()+main = do+  fixtures <- LayerBench.prepareFixtures+  LayerBench.runBenchmarks fixtures
+ bench/layer/Moonlight/Triangulation/LayerBench.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++-- | Timing and allocation evidence for exact affine envelopes and layer+-- composition. Manual lanes use only the pre-existing public operations a+-- caller otherwise has to compose and discard.+module Moonlight.Triangulation.LayerBench+  ( LayerBenchFixtures+  , prepareFixtures+  , runBenchmarks+  ) where++import Control.DeepSeq (NFData)+import Control.Monad (foldM)+import Data.Bifunctor (first)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Map.Strict as Map+import GHC.Generics (Generic)+import Moonlight.Triangulation+  ( AffineForm (..)+  , ExactArea+  , ExactRational+  , OverlayResult+  , PlanarLayer+  , PlanarRegion+  , PolygonComponent+  , exactAreaValue+  , exactLoop+  , exactPoint+  , layerCovers+  , overlayAll+  , overlayConfusion+  , overlayLayers+  , overlayMass+  , overlayPlanarLayer+  , overlaySelectedRegion+  , planarLayer+  , planarLayerOutsideLabel+  , planarLayerRegions+  , planarRegion+  , polygonComponent+  , regionValuations+  , upperEnvelope+  , valuationArea+  )+import Test.Tasty.Bench (bench, bgroup, defaultMain, nf)++data LayerBenchFixtures = LayerBenchFixtures+  { envelopeWindow :: !PolygonComponent+  , envelopeForms16 :: !(Map.Map Int AffineForm)+  , envelopeForms64 :: !(Map.Map Int AffineForm)+  , envelopeForms169 :: !(Map.Map Int AffineForm)+  , overlayLayers8 :: !(NonEmpty (PlanarLayer Bool))+  , overlayLayers16 :: !(NonEmpty (PlanarLayer Bool))+  , measuredOverlay :: !(OverlayResult Bool Bool)+  , coverageLayer :: !(PlanarLayer Bool)+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++prepareFixtures :: IO LayerBenchFixtures+prepareFixtures = do+  window <- rectangleComponent (-20) (-20) 20 20+  layers8 <- prepareLayerFamily 8+  layers16 <- prepareLayerFamily 16+  left <- rectangleLayer 0 0 60 100+  right <- rectangleLayer 40 0 100 100+  massOverlay <- requireRight "mass benchmark overlay" (overlayLayers left right)+  windowRegion <- requireRight "coverage benchmark region" (planarRegion [window])+  completeCoverage <-+    requireRight+      "coverage benchmark layer"+      (planarLayer False (Map.singleton True windowRegion))+  pure+    LayerBenchFixtures+      { envelopeWindow = window+      , envelopeForms16 = affineForms 16+      , envelopeForms64 = affineForms 64+      , envelopeForms169 = affineForms 169+      , overlayLayers8 = layers8+      , overlayLayers16 = layers16+      , measuredOverlay = massOverlay+      , coverageLayer = completeCoverage+      }++runBenchmarks :: LayerBenchFixtures -> IO ()+runBenchmarks fixtures =+  defaultMain+    [ bgroup+        "exact affine upper envelope"+        [ bench "n=16" (nf (upperEnvelope (envelopeWindow fixtures)) (envelopeForms16 fixtures))+        , bench "n=64" (nf (upperEnvelope (envelopeWindow fixtures)) (envelopeForms64 fixtures))+        , bench "n=169" (nf (upperEnvelope (envelopeWindow fixtures)) (envelopeForms169 fixtures))+        ]+    , bgroup+        "n-ary overlay"+        [ bench "balanced/n=8" (nf balancedOverlay (overlayLayers8 fixtures))+        , bench "left-associated/n=8" (nf leftAssociatedOverlay (overlayLayers8 fixtures))+        , bench "balanced/n=16" (nf balancedOverlay (overlayLayers16 fixtures))+        , bench "left-associated/n=16" (nf leftAssociatedOverlay (overlayLayers16 fixtures))+        ]+    , bgroup+        "overlay analytics"+        [ bench "mass/direct" (nf directMass (measuredOverlay fixtures))+        , bench "mass/publish-and-value" (nf publishedMass (measuredOverlay fixtures))+        , bench "confusion/direct" (nf directConfusion (measuredOverlay fixtures))+        , bench "confusion/repeated-publication" (nf publishedConfusion (measuredOverlay fixtures))+        , bench+            "coverage/complete"+            (nf (coverageResult (coverageLayer fixtures)) (envelopeWindow fixtures))+        ]+    ]++balancedOverlay+  :: NonEmpty (PlanarLayer Bool)+  -> Either String (PlanarLayer (NonEmpty Bool))+balancedOverlay = first show . overlayAll++leftAssociatedOverlay+  :: NonEmpty (PlanarLayer Bool)+  -> Either String (PlanarLayer (NonEmpty Bool))+leftAssociatedOverlay (firstLayer :| remainingLayers) = do+  initial <- singletonLabelLayer firstLayer+  liftedRemaining <- traverse singletonLabelLayer remainingLayers+  foldM overlayNext initial liftedRemaining+ where+  overlayNext left right = do+    result <- first show (overlayLayers left right)+    flattenPublicLayer (overlayPlanarLayer result)++singletonLabelLayer+  :: PlanarLayer Bool+  -> Either String (PlanarLayer (NonEmpty Bool))+singletonLabelLayer layer =+  first show+    ( planarLayer+        (planarLayerOutsideLabel layer :| [])+        ( Map.fromList+            [ (label :| [], region)+            | (label, region) <- Map.toAscList (planarLayerRegions layer)+            ]+        )+    )++flattenPublicLayer+  :: PlanarLayer (NonEmpty Bool, NonEmpty Bool)+  -> Either String (PlanarLayer (NonEmpty Bool))+flattenPublicLayer layer =+  first show+    ( planarLayer+        (uncurry (<>) (planarLayerOutsideLabel layer))+        ( Map.fromList+            [ (leftLabels <> rightLabels, region)+            | ((leftLabels, rightLabels), region) <- Map.toAscList (planarLayerRegions layer)+            ]+        )+    )++directMass :: OverlayResult Bool Bool -> Either String ExactArea+directMass = first show . overlayMass (== (True, True))++publishedMass :: OverlayResult Bool Bool -> Either String ExactArea+publishedMass result = do+  region <- first show (overlaySelectedRegion (== (True, True)) result)+  valuationArea <$> first show (regionValuations region)++directConfusion :: OverlayResult Bool Bool -> Map.Map (Bool, Bool) ExactRational+directConfusion = fmap exactAreaValue . overlayConfusion++publishedConfusion+  :: OverlayResult Bool Bool+  -> Either String (Map.Map (Bool, Bool) ExactRational)+publishedConfusion result =+  Map.fromList+    <$> traverse+      (\labels -> (labels,) . exactAreaValue <$> publishedPairMass labels)+      [(False, True), (True, False), (True, True)]+ where+  publishedPairMass labels = do+    region <- first show (overlaySelectedRegion (== labels) result)+    valuationArea <$> first show (regionValuations region)++coverageResult+  :: PlanarLayer Bool+  -> PolygonComponent+  -> Either String ()+coverageResult layer = first show . layerCovers layer++prepareLayerFamily :: Int -> IO (NonEmpty (PlanarLayer Bool))+prepareLayerFamily count = do+  layers <- traverse prepareLayer [0 .. count - 1]+  case layers of+    firstLayer : remaining -> pure (firstLayer :| remaining)+    [] -> fail "layer benchmark requires a positive family size"+ where+  prepareLayer index =+    rectangleLayer+      (-64 + fromIntegral ((7 * index) `mod` 31))+      (-64 + fromIntegral ((11 * index) `mod` 29))+      (32 + fromIntegral ((13 * index) `mod` 31))+      (32 + fromIntegral ((17 * index) `mod` 29))++rectangleLayer :: Integer -> Integer -> Integer -> Integer -> IO (PlanarLayer Bool)+rectangleLayer minimumX minimumY maximumX maximumY = do+  region <- rectangleRegion minimumX minimumY maximumX maximumY+  requireRight "benchmark rectangle layer" (planarLayer False (Map.singleton True region))++rectangleRegion :: Integer -> Integer -> Integer -> Integer -> IO PlanarRegion+rectangleRegion minimumX minimumY maximumX maximumY = do+  component <- rectangleComponent minimumX minimumY maximumX maximumY+  requireRight "benchmark rectangle region" (planarRegion [component])++rectangleComponent :: Integer -> Integer -> Integer -> Integer -> IO PolygonComponent+rectangleComponent minimumX minimumY maximumX maximumY = do+  loop <-+    requireRight+      "benchmark rectangle loop"+      ( exactLoop+          ( exactPoint (fromInteger minimumX) (fromInteger minimumY)+              :| [ exactPoint (fromInteger maximumX) (fromInteger minimumY)+                 , exactPoint (fromInteger maximumX) (fromInteger maximumY)+                 , exactPoint (fromInteger minimumX) (fromInteger maximumY)+                 ]+          )+      )+  requireRight "benchmark rectangle component" (polygonComponent loop [])++affineForms :: Int -> Map.Map Int AffineForm+affineForms count =+  Map.fromAscList+    [ (index, tangentForm index)+    | index <- [0 .. count - 1]+    ]+ where+  tangentForm index =+    let coordinateX = fromIntegral (index `mod` 17 - 8)+        coordinateY = fromIntegral (index `div` 17 - 5)+     in AffineForm+          (negate (coordinateX * coordinateX + coordinateY * coordinateY))+          (2 * coordinateX)+          (2 * coordinateY)++requireRight :: Show failure => String -> Either failure value -> IO value+requireRight label = either (fail . ((label <> ": ") <>) . show) pure
+ bench/power/Main.hs view
@@ -0,0 +1,9 @@+module Main (main) where++import qualified Moonlight.Triangulation.PowerBench as PowerBench++main :: IO ()+main = do+  cases <- PowerBench.prepareCases+  PowerBench.reportCases cases+  PowerBench.runBenchmarks cases
+ bench/power/Moonlight/Triangulation/PowerBench.hs view
@@ -0,0 +1,536 @@+-- | Tasty-bench lanes for the exact bounded power-diagram owner.  The timed+-- lanes force the public result, while the one-shot report keeps the+-- structural receipt and a shared incremental allocation observation outside+-- the timing sample.  One construction is revealed, its diagram is forced,+-- and only then is the additional receipt-reachable section measured.+module Moonlight.Triangulation.PowerBench+  ( PowerBenchCase+  , prepareCases+  , reportCases+  , runBenchmarks+  ) where++import BenchMeasure (requireRight)+import BenchSupport (randomPoints)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Data.Foldable (traverse_)+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Vector as Vector+import GHC.Conc.Sync (getAllocationCounter, setAllocationCounter)+import Moonlight.Triangulation+  ( BoundedPowerDiagram+  , ConvexPolygon+  , Point (Point)+  , PowerDiagramError+  , PowerDiagramReceipt+  , PowerSite+  , PowerWeight+  , RegularEditError+  , RegularEditResult+  , RegularTriangulation+  , RegularTriangulationReceipt+  , boundedPowerDiagram+  , boundedPowerDiagramFromRegular+  , convexPolygon+  , exactPoint+  , powerDiagramActiveBoundaries+  , powerDiagramCoincidentDominatedCells+  , powerDiagramCoincidentEquivalentCells+  , powerDiagramDomainVertices+  , powerDiagramBoundaryCompatibilityChecks+  , powerDiagramEmptyCells+  , powerDiagramExactIntersections+  , powerDiagramFinalCoordinateBitGrowth+  , powerDiagramFinalCoordinateBits+  , powerDiagramFinalDenominatorBits+  , powerDiagramInputSites+  , powerDiagramLowerDimensionalCells+  , powerDiagramMaximumAffineCoefficientBits+  , powerDiagramMaximumInputBits+  , powerDiagramPeakIntermediateBitGrowth+  , powerDiagramPeakIntermediateCoordinateBits+  , powerDiagramMaximumCellConstraints+  , powerDiagramPublishedCells+  , powerDiagramOracleCells+  , powerDiagramRegularEdges+  , powerDiagramRegularFaces+  , powerDiagramSubmittedSiteConstraints+  , powerSite+  , powerSiteLabel+  , powerSitePosition+  , powerSiteWeight+  , powerWeight+  , powerWeightExact+  , powerWeightFromExact+  , insertRegularSite+  , removeRegularSite+  , reweightRegularSites+  , regularTriangulation+  , regularEditChangedSites+  , regularEditTriangulation+  , regularEditTransitions+  , regularSiteDisposition+  , regularSites+  , RegularSiteDisposition (RegularSiteHidden)+  )+import System.Mem (performGC)+import Test.Tasty.Bench (Benchmark, bench, bgroup, defaultMain, nf)++data PowerBenchFamily+  = WellConditioned+  | NearParallel+  | CollinearSlopes+  deriving stock (Eq, Ord, Show)++data PowerBenchCase = PowerBenchCase+  { powerBenchLabel :: !String+  , powerBenchDomain :: !ConvexPolygon+  , powerBenchSites :: !(NonEmpty (PowerSite Int))+  , powerBenchRegular :: !(RegularTriangulation Int)+  , powerBenchInsertionBase :: !(RegularTriangulation Int)+  , powerBenchInsertedSite :: !(PowerSite Int)+  , powerBenchReweight :: !PowerWeight+  , powerBenchCommonShift :: !(Map.Map Int PowerWeight)+  , powerBenchCoincidentLabel :: !Int+  , powerBenchCoincidentRegular :: !(RegularTriangulation Int)+  , powerBenchCoincidentReweight :: !PowerWeight+  , powerBenchHiddenEdit :: !(Maybe HiddenEditFixture)+  }++data HiddenEditFixture = HiddenEditFixture+  { hiddenEditLabel :: !Int+  , hiddenEditLowerWeight :: !PowerWeight+  }++type PowerResult =+  Either (PowerDiagramError Int) (BoundedPowerDiagram Int, PowerDiagramReceipt)++type DiagramResult =+  Either (PowerDiagramError Int) (BoundedPowerDiagram Int)++type RegularResult =+  Either+    (PowerDiagramError Int)+    (RegularTriangulation Int, RegularTriangulationReceipt)++type RegularEditBenchmarkResult =+  Either (RegularEditError Int) (RegularEditResult Int)++type RegularEditObservation =+  Either (RegularEditError Int) (Int, Int, Maybe (RegularSiteDisposition Int))++siteCounts :: [Int]+siteCounts = [16, 64, 128, 169, 256, 512, 2048]++families :: [PowerBenchFamily]+families = [WellConditioned, NearParallel, CollinearSlopes]++-- | Deterministic, fixed-domain fixture bands include the exhibit scale and a+-- larger scaling point.  Ordinary and nearly parallel families expose exact+-- clipping cost; the collinear family exposes upper-chain classification.+prepareCases :: IO [PowerBenchCase]+prepareCases =+  traverse prepareCase [(family, count) | family <- families, count <- siteCounts]++prepareCase :: (PowerBenchFamily, Int) -> IO PowerBenchCase+prepareCase (family, siteCount) = do+  domain <-+    requireRight+      ( convexPolygon+          ( exactPoint (-1) (-1)+              :| [exactPoint 1 (-1), exactPoint 1 1, exactPoint (-1) 1]+          )+      )+  sites <-+    traverse (prepareSite family) (zip [0 ..] (fixturePoints family siteCount))+  case NonEmpty.nonEmpty sites of+    Nothing -> fail "power benchmark fixture requires at least one site"+    Just nonEmptySites -> do+      regular <- requireRight (regularTriangulation nonEmptySites)+      insertionBaseSites <-+        case NonEmpty.nonEmpty (NonEmpty.init nonEmptySites) of+          Nothing -> fail "power edit benchmark requires at least two sites"+          Just baseSites -> pure baseSites+      insertionBase <- requireRight (regularTriangulation insertionBaseSites)+      replacementWeight <- requireRight (powerWeight 17)+      subordinateWeight <- requireRight (powerWeight (-1048576))+      subordinateReweight <- requireRight (powerWeight (-2097152))+      let representativeSite = NonEmpty.head nonEmptySites+          commonShift =+            Map.fromList+              [ ( powerSiteLabel site+                , powerWeightFromExact (powerWeightExact (powerSiteWeight site) + 1)+                )+              | site <- NonEmpty.toList nonEmptySites+              ]+      subordinateSite <-+        requireRight+          (powerSite siteCount (powerSitePosition representativeSite) subordinateWeight)+      subordinateInsertion <-+        requireRight (insertRegularSite subordinateSite (fst regular))+      let preparedRegular = fst regular+          hiddenEdit =+            fmap+              (\site ->+                 HiddenEditFixture+                   { hiddenEditLabel = powerSiteLabel site+                   , hiddenEditLowerWeight = subordinateWeight+                   })+              ( List.find+                  (\site ->+                     regularSiteDisposition (powerSiteLabel site) preparedRegular+                       == Just RegularSiteHidden)+                  (regularSites preparedRegular)+              )+      pure+        PowerBenchCase+          { powerBenchLabel = familyLabel family <> "/n=" <> show siteCount+          , powerBenchDomain = domain+          , powerBenchSites = nonEmptySites+          , powerBenchRegular = preparedRegular+          , powerBenchInsertionBase = fst insertionBase+          , powerBenchInsertedSite = NonEmpty.last nonEmptySites+          , powerBenchReweight = replacementWeight+          , powerBenchCommonShift = commonShift+          , powerBenchCoincidentLabel = powerSiteLabel subordinateSite+          , powerBenchCoincidentRegular = regularEditTriangulation subordinateInsertion+          , powerBenchCoincidentReweight = subordinateReweight+          , powerBenchHiddenEdit = hiddenEdit+          }++fixturePoints :: PowerBenchFamily -> Int -> [Point]+fixturePoints family siteCount =+  case family of+    WellConditioned -> randomPoints 0x9e3779b97f4a7c15 siteCount+    NearParallel -> nearParallelPoints siteCount+    CollinearSlopes -> collinearSlopePoints siteCount++nearParallelPoints :: Int -> [Point]+nearParallelPoints siteCount =+  [ Point+      (fromIntegral index / fromIntegral (siteCount + 1) * 1.8 - 0.9)+      (fromIntegral index / fromIntegral (siteCount + 1) * 1.8e-6 - 0.9e-6)+  | index <- [1 .. siteCount]+  ]++collinearSlopePoints :: Int -> [Point]+collinearSlopePoints siteCount =+  [ Point (fromIntegral index / 1024 - 0.5) 0+  | index <- [0 .. siteCount - 1]+  ]++familyLabel :: PowerBenchFamily -> String+familyLabel WellConditioned = "power-well-conditioned"+familyLabel NearParallel = "power-near-parallel"+familyLabel CollinearSlopes = "power-collinear-slopes"++prepareSite :: PowerBenchFamily -> (Int, Point) -> IO (PowerSite Int)+prepareSite family (label, point) = do+  let weightValue =+        case family of+          CollinearSlopes+            | odd label -> -(2 / 1048576)+            | otherwise -> 0+          WellConditioned -> fromIntegral (label `mod` 9 - 4) / 256+          NearParallel -> fromIntegral (label `mod` 9 - 4) / 256+  weight <- requireRight (powerWeight weightValue)+  requireRight (powerSite label point weight)++-- | Print one receipt and one allocation probe per fixture.  Tasty-bench+-- remains the authority for timing; this report is the derived structural+-- view that timing samples cannot carry.+reportCases :: [PowerBenchCase] -> IO ()+reportCases cases = do+  putStrLn "moonlight-triangulation exact bounded power-diagram benchmark"+  putStrLn+    "receipt-overhead-method: reveal one shared construction, force its diagram, then measure only the additional receipt-reachable allocation; strict work incurred while revealing the pair is not attributed"+  traverse_ reportCase cases++reportCase :: PowerBenchCase -> IO ()+reportCase benchmarkCase = do+  (sharedResult, allocation) <- measureSharedAllocation benchmarkCase+  case sharedResult of+    Left failure -> fail (powerBenchLabel benchmarkCase <> ": " <> show failure)+    Right (_, receipt) -> do+      putStrLn (renderReceipt (powerBenchLabel benchmarkCase) receipt)+      putStrLn+        ( powerBenchLabel benchmarkCase+            <> "-allocated-bytes/shared-full: "+            <> show (sharedFullAllocation allocation)+        )+      putStrLn+        ( powerBenchLabel benchmarkCase+            <> "-allocated-bytes/shared-through-diagram: "+            <> show (sharedDiagramAllocation allocation)+        )+      putStrLn+        ( powerBenchLabel benchmarkCase+            <> "-allocated-bytes/incremental-receipt-reachable-overhead: "+            <> show (sharedReceiptReachableAllocation allocation)+        )++runBenchmarks :: [PowerBenchCase] -> IO ()+runBenchmarks cases = defaultMain [bgroup "exact bounded power diagram" (concatMap caseBenchmarks cases)]++caseBenchmarks :: PowerBenchCase -> [Benchmark]+caseBenchmarks benchmarkCase =+  [ bench+      (powerBenchLabel benchmarkCase <> "/regular-topology")+      (nf constructRegularTopology benchmarkCase)+  , bench+      (powerBenchLabel benchmarkCase <> "/construct-with-receipt")+      (nf construct benchmarkCase)+  , bench+      (powerBenchLabel benchmarkCase <> "/construct-diagram-only")+      (nf constructDiagramOnly benchmarkCase)+  , bench+      (powerBenchLabel benchmarkCase <> "/clip-prepared-regular")+      (nf constructFromRegular benchmarkCase)+  , bench+      (powerBenchLabel benchmarkCase <> "/insert-local-observation")+      (nf observeInsertion benchmarkCase)+  , bench+      (powerBenchLabel benchmarkCase <> "/insert-and-normalize")+      (nf insertAndNormalize benchmarkCase)+  , bench+      (powerBenchLabel benchmarkCase <> "/remove-local-observation")+      (nf observeRemoval benchmarkCase)+  , bench+      (powerBenchLabel benchmarkCase <> "/remove-and-normalize")+      (nf removeAndNormalize benchmarkCase)+  , bench+      (powerBenchLabel benchmarkCase <> "/reweight-local-observation")+      (nf observeReweight benchmarkCase)+  , bench+      (powerBenchLabel benchmarkCase <> "/reweight-and-normalize")+      (nf reweightAndNormalize benchmarkCase)+  , bench+      (powerBenchLabel benchmarkCase <> "/common-weight-shift")+      (nf shiftEveryWeight benchmarkCase)+  ]+    <> topologyPreservingBenchmarks benchmarkCase++topologyPreservingBenchmarks :: PowerBenchCase -> [Benchmark]+topologyPreservingBenchmarks benchmarkCase =+  [ bench+      (powerBenchLabel benchmarkCase <> "/remove-coincident-subordinate")+      (nf removeCoincidentSubordinate benchmarkCase)+  , bench+      (powerBenchLabel benchmarkCase <> "/reweight-coincident-subordinate")+      (nf reweightCoincidentSubordinate benchmarkCase)+  ]+    <> maybe [] hiddenBenchmarks (powerBenchHiddenEdit benchmarkCase)+ where+  hiddenBenchmarks hidden =+    [ bench+        (powerBenchLabel benchmarkCase <> "/remove-hidden")+        (nf (removeHidden benchmarkCase) hidden)+    , bench+        (powerBenchLabel benchmarkCase <> "/reweight-hidden-downward")+        (nf (reweightHiddenDownward benchmarkCase) hidden)+    ]++construct :: PowerBenchCase -> PowerResult+construct benchmarkCase =+  boundedPowerDiagram+    (powerBenchDomain benchmarkCase)+    (powerBenchSites benchmarkCase)++constructDiagramOnly :: PowerBenchCase -> DiagramResult+constructDiagramOnly = fmap fst . construct++constructRegularTopology :: PowerBenchCase -> RegularResult+constructRegularTopology = regularTriangulation . powerBenchSites++constructFromRegular :: PowerBenchCase -> PowerResult+constructFromRegular benchmarkCase =+  boundedPowerDiagramFromRegular+    (powerBenchDomain benchmarkCase)+    (powerBenchRegular benchmarkCase)++insertAndNormalize+  :: PowerBenchCase+  -> RegularEditBenchmarkResult+insertAndNormalize benchmarkCase =+  insertRegularSite+    (powerBenchInsertedSite benchmarkCase)+    (powerBenchInsertionBase benchmarkCase)++observeInsertion+  :: PowerBenchCase+  -> RegularEditObservation+observeInsertion benchmarkCase =+  observeRegularEdit+    (powerSiteLabel (powerBenchInsertedSite benchmarkCase))+    (insertAndNormalize benchmarkCase)++removeAndNormalize+  :: PowerBenchCase+  -> RegularEditBenchmarkResult+removeAndNormalize benchmarkCase =+  removeRegularSite+    (powerSiteLabel (powerBenchInsertedSite benchmarkCase))+    (powerBenchRegular benchmarkCase)++observeRemoval+  :: PowerBenchCase+  -> RegularEditObservation+observeRemoval benchmarkCase =+  observeRegularEdit+    (powerSiteLabel (powerBenchInsertedSite benchmarkCase))+    (removeAndNormalize benchmarkCase)++reweightAndNormalize+  :: PowerBenchCase+  -> RegularEditBenchmarkResult+reweightAndNormalize benchmarkCase =+  reweightRegularSites+    ( Map.singleton+        (powerSiteLabel (powerBenchInsertedSite benchmarkCase))+        (powerBenchReweight benchmarkCase)+    )+    (powerBenchRegular benchmarkCase)++observeReweight+  :: PowerBenchCase+  -> RegularEditObservation+observeReweight benchmarkCase =+  observeRegularEdit+    (powerSiteLabel (powerBenchInsertedSite benchmarkCase))+    (reweightAndNormalize benchmarkCase)++observeRegularEdit+  :: Int+  -> RegularEditBenchmarkResult+  -> RegularEditObservation+observeRegularEdit focus =+  fmap+    (\editResult ->+       ( Set.size (regularEditChangedSites editResult)+       , Vector.length (regularEditTransitions editResult)+       , regularSiteDisposition+           focus+           (regularEditTriangulation editResult)+       ))++shiftEveryWeight+  :: PowerBenchCase+  -> RegularEditBenchmarkResult+shiftEveryWeight benchmarkCase =+  reweightRegularSites+    (powerBenchCommonShift benchmarkCase)+    (powerBenchRegular benchmarkCase)++removeCoincidentSubordinate+  :: PowerBenchCase+  -> RegularEditBenchmarkResult+removeCoincidentSubordinate benchmarkCase =+  removeRegularSite+    (powerBenchCoincidentLabel benchmarkCase)+    (powerBenchCoincidentRegular benchmarkCase)++reweightCoincidentSubordinate+  :: PowerBenchCase+  -> RegularEditBenchmarkResult+reweightCoincidentSubordinate benchmarkCase =+  reweightRegularSites+    ( Map.singleton+        (powerBenchCoincidentLabel benchmarkCase)+        (powerBenchCoincidentReweight benchmarkCase)+    )+    (powerBenchCoincidentRegular benchmarkCase)++removeHidden+  :: PowerBenchCase+  -> HiddenEditFixture+  -> RegularEditBenchmarkResult+removeHidden benchmarkCase fixture =+  removeRegularSite (hiddenEditLabel fixture) (powerBenchRegular benchmarkCase)++reweightHiddenDownward+  :: PowerBenchCase+  -> HiddenEditFixture+  -> RegularEditBenchmarkResult+reweightHiddenDownward benchmarkCase fixture =+  reweightRegularSites+    (Map.singleton (hiddenEditLabel fixture) (hiddenEditLowerWeight fixture))+    (powerBenchRegular benchmarkCase)++data SharedPowerAllocation = SharedPowerAllocation+  { sharedFullAllocation :: !Integer+  , sharedDiagramAllocation :: !Integer+  , sharedReceiptReachableAllocation :: !Integer+  }++measureSharedAllocation+  :: PowerBenchCase+  -> IO (PowerResult, SharedPowerAllocation)+measureSharedAllocation benchmarkCase = do+  performGC+  setAllocationCounter maxBound+  allocationStart <- getAllocationCounter+  sharedResult <- evaluate (construct benchmarkCase)+  case sharedResult of+    Left failure -> do+      forcedFailure <- evaluate (force failure)+      allocationEnd <- getAllocationCounter+      let total = allocationDifference allocationStart allocationEnd+      pure+        ( Left forcedFailure+        , SharedPowerAllocation total total 0+        )+    Right (diagram, receipt) -> do+      forcedDiagram <- evaluate (force diagram)+      allocationAfterDiagram <- getAllocationCounter+      forcedReceipt <- evaluate (force receipt)+      allocationAfterReceipt <- getAllocationCounter+      pure+        ( Right (forcedDiagram, forcedReceipt)+        , SharedPowerAllocation+            { sharedFullAllocation =+                allocationDifference allocationStart allocationAfterReceipt+            , sharedDiagramAllocation =+                allocationDifference allocationStart allocationAfterDiagram+            , sharedReceiptReachableAllocation =+                allocationDifference allocationAfterDiagram allocationAfterReceipt+            }+        )++allocationDifference :: Integral amount => amount -> amount -> Integer+allocationDifference before after = toInteger (max 0 (before - after))++renderReceipt :: String -> PowerDiagramReceipt -> String+renderReceipt label receipt =+  unwords+    [ label <> "-receipt:"+    , field "input-sites" powerDiagramInputSites+    , field "domain-vertices" powerDiagramDomainVertices+    , field "submitted-site-constraints" powerDiagramSubmittedSiteConstraints+    , field "active-boundaries" powerDiagramActiveBoundaries+    , field "boundary-compatibility-checks" powerDiagramBoundaryCompatibilityChecks+    , field "exact-intersections" powerDiagramExactIntersections+    , field "published" powerDiagramPublishedCells+    , field "lower-dimensional" powerDiagramLowerDimensionalCells+    , field "empty" powerDiagramEmptyCells+    , field "coincident-equivalent" powerDiagramCoincidentEquivalentCells+    , field "coincident-dominated" powerDiagramCoincidentDominatedCells+    , field "regular-faces" powerDiagramRegularFaces+    , field "regular-edges" powerDiagramRegularEdges+    , field "oracle-cells" powerDiagramOracleCells+    , field "maximum-cell-constraints" powerDiagramMaximumCellConstraints+    , field "input-bits" powerDiagramMaximumInputBits+    , field "affine-bits" powerDiagramMaximumAffineCoefficientBits+    , field "peak-coordinate-bits" powerDiagramPeakIntermediateCoordinateBits+    , field "final-coordinate-bits" powerDiagramFinalCoordinateBits+    , field "final-denominator-bits" powerDiagramFinalDenominatorBits+    , field "peak-growth-bits" powerDiagramPeakIntermediateBitGrowth+    , field "final-growth-bits" powerDiagramFinalCoordinateBitGrowth+    ]+ where+  field :: Show value => String -> (PowerDiagramReceipt -> value) -> String+  field name project = name <> "=" <> show (project receipt)
+ bench/publication/PublicationMain.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.JoinBench as JoinBench++main :: IO ()+main = JoinBench.publicationBenchmarks
+ bench/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,443 @@+{-# 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+  )+import BenchMeasure (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.Internal.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+             (disjointRectangles size)+         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+          (disjointRectangles size)+      )+  region <- requireRight (planarRegion components)+  valuations <-+    timedValue+      ("planar-region-valuations-n" <> show size)+      (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 (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 (disjointRectangles size)+        <*> 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]+          ]++disjointRectangles :: Int -> [(Int, Int, Int, Int)]+disjointRectangles size =+  [ (3 * index, 0, 3 * index + 1, 1)+  | index <- [0 .. size - 1]+  ]+{-# INLINE disjointRectangles #-}++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/spade-compare/hs-alpha/Main.hs view
@@ -0,0 +1,66 @@+-- | Narrow Haskell interpreter for the opt-in alpha-persistence diagnostic.+module Main (main) where++import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Data.Vector qualified as Vector+import Moonlight.Triangulation.Bench.SpadeCompare.Alpha+  ( alphaPersistenceReceipt+  , renderAlphaPersistenceReceipt+  )+import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints)+import Moonlight.Triangulation.Bench.SpadeCompare.Lane+  ( LaneKind (AlphaPersistenceLane)+  , LaneObstruction+  , LaneRequest (..)+  , parseLaneRequest+  , renderLaneObstruction+  )+import Moonlight.Triangulation.Bench.SpadeCompare.Timing (measureLane)+import System.Environment (getArgs)+import System.Exit (ExitCode (ExitFailure), exitWith)+import System.IO (hPutStrLn, stderr)++main :: IO ()+main = do+  arguments <- getArgs+  case arguments of+    ["alpha-receipt", rawCount] ->+      either refuseLane reportReceipt+        (parseLaneRequest "alpha-persistence" rawCount "0")+    ["bench-one", lane, first, second] ->+      either refuseLane runAlphaLane (parseLaneRequest lane first second)+    _ -> refuseUsage++runAlphaLane :: LaneRequest -> IO ()+runAlphaLane request@(LaneRequest AlphaPersistenceLane pointCount _) = do+  points <-+    evaluate+      (force (Vector.fromList (randomPoints 0x9e3779b97f4a7c15 pointCount)))+  measureLane request (requireResult (alphaPersistenceReceipt points))+runAlphaLane _ = refuseUsage++reportReceipt :: LaneRequest -> IO ()+reportReceipt (LaneRequest AlphaPersistenceLane pointCount _) = do+  let points = Vector.fromList (randomPoints 0x9e3779b97f4a7c15 pointCount)+  receipt <- requireResult (alphaPersistenceReceipt points)+  putStrLn (renderAlphaPersistenceReceipt receipt)+reportReceipt _ = refuseUsage++requireResult :: Show obstruction => Either obstruction value -> IO value+requireResult result =+  case result of+    Left obstruction -> do+      hPutStrLn stderr ("alpha persistence refused: " <> show obstruction)+      exitWith (ExitFailure 1)+    Right value -> pure value++refuseLane :: LaneObstruction -> IO value+refuseLane obstruction = do+  hPutStrLn stderr (renderLaneObstruction obstruction)+  exitWith (ExitFailure 2)++refuseUsage :: IO value+refuseUsage = do+  hPutStrLn stderr "usage: moonlight-triangulation-alpha-spade-referent (alpha-receipt COUNT | bench-one alpha-persistence COUNT 0)"+  exitWith (ExitFailure 2)
+ bench/spade-compare/hs/Main.hs view
@@ -0,0 +1,286 @@+-- | Haskell half of the spade external referent.+--+-- @moonlight-triangulation@ is a port of the Rust @spade@ crate, so spade is the+-- referent that grades it. Both halves generate their inputs from the same LCG+-- with the same seeds and emit their gate output in the same encoding, so+-- neither side can reformat a disagreement into agreement.+--+-- Vertex handles are NOT comparable across the two implementations — both bulk+-- loaders reorder. Anything naming a vertex names it by input index or by+-- coordinate, never by handle.+{-# LANGUAGE DataKinds #-}++module Main (main) where++import Control.DeepSeq (NFData, force)+import Control.Exception (evaluate)+import Control.Monad.ST (runST)+import Data.Word (Word64)+import Moonlight.Triangulation.Internal.Mutable (freezeTriangulation, thawTriangulation)+import System.Environment (getArgs)+import System.Exit (exitWith, ExitCode (ExitFailure))+import System.IO (hPutStrLn, stderr)+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.BulkLoad+import Moonlight.Triangulation.Cdt+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.HintGenerator+import Moonlight.Triangulation.Interpolation+import Moonlight.Triangulation.PointLocation+import Moonlight.Triangulation.Types+import Moonlight.Triangulation.Bench.SpadeCompare.Constraint+import Moonlight.Triangulation.Bench.SpadeCompare.Dcel+import Moonlight.Triangulation.Bench.SpadeCompare.Delaunay+import Moonlight.Triangulation.Bench.SpadeCompare.Gates+import Moonlight.Triangulation.Bench.SpadeCompare.Hierarchy+import Moonlight.Triangulation.Bench.SpadeCompare.Interpolation+import Moonlight.Triangulation.Bench.SpadeCompare.Intersection+import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints)+import Moonlight.Triangulation.Bench.SpadeCompare.Lane+import Moonlight.Triangulation.Bench.SpadeCompare.Removal+import Moonlight.Triangulation.Bench.SpadeCompare.Support+import Moonlight.Triangulation.Bench.SpadeCompare.Timing (measureLane)+import Moonlight.Triangulation.Bench.SpadeCompare.Voronoi++main :: IO ()+main = do+  arguments <- getArgs+  case arguments of+    ["gate", directory] -> writeGate directory+    ["divergence", path] -> writeDivergence path+    ["inventory-csv"] -> putStr renderInventoryCsv+    ["inventory-human"] -> putStr renderInventoryHuman+    ["lane-specs", laneClass] -> either refuseLane putStr (renderLaneSpecs laneClass)+    ["snapshot-specs"] -> putStr renderSnapshotSpecs+    ["bench-one", lane, first, second] ->+      either refuseLane runLane (parseLaneRequest lane first second)+    ["counters", budget] -> reportRefinementCounters (read budget)+    ["sweep-stats", count] -> reportSweepStats (read count)+    ["removal-audit", count, removals] -> reportRemovalAudit (read count) (read removals)+    ["removal-context", count, index] -> reportRemovalContext (read count) (read index)+    ["fresh-suffix", count, dropped, path] -> writeFreshSuffix (read count) (read dropped) path+    ["interp-audit", count, queries] -> reportInterpolationAudit (read count) (read queries)+    ["interp-context", count] -> reportInterpolationContext (read count) Nothing+    ["interp-context", count, index] -> reportInterpolationContext (read count) (Just (read index))+    ["interp-locate-audit", count, queries] -> reportInterpolationLocateAudit (read count) (read queries)+    ["interp-cavity-audit", count, queries] -> reportInterpolationCavityAudit (read count) (read queries)+    _ -> do+      hPutStrLn stderr "usage: moonlight-triangulation-spade-referent (gate DIR | divergence FILE | inventory-csv | inventory-human | lane-specs CLASS | snapshot-specs | bench-one LANE A B | counters BUDGET | sweep-stats COUNT | removal-audit COUNT REMOVALS | removal-context COUNT INDEX | fresh-suffix COUNT DROPPED PATH | interp-audit COUNT QUERIES | interp-context COUNT [INDEX])"+      exitWith (ExitFailure 2)++refuseLane :: LaneObstruction -> IO value+refuseLane obstruction = do+  hPutStrLn stderr (renderLaneObstruction obstruction)+  exitWith (ExitFailure 2)++-- Everything each lane needs before the clock starts. Handle resolution and+-- input generation are setup, not work.+runLane :: LaneRequest -> IO ()+runLane request@(LaneRequest lane first second) = case lane of+  -- The input vector is forced here rather than inside 'measure'. A lazy+  -- 'V.fromList' handed to the clock puts the generator, the list, every boxed+  -- coordinate, and the vector's own construction inside the lane — none of+  -- which the Rust side pays, because it builds its @Vec@ before its @Instant@.+  BulkLoadLane -> do+    points <- evaluate (force (V.fromList (randomPoints 0x9e3779b97f4a7c15 first)))+    measure (require (delaunayGeometry points))+  IncrementalLane -> do+    points <- evaluate (force (V.fromList (randomPoints 0x9e3779b97f4a7c15 first)))+    measure (insertAllIncrementally points)+  -- One immutable snapshot per point. This is deliberately not a cross-+  -- language lane: spade's referent is timed only on the mutable session+  -- operation, while this stress lane is paired with the Haskell session+  -- reference by the driver.+  SnapshotInsertLane -> do+    points <- evaluate (force (V.fromList (randomPoints 0x9e3779b97f4a7c15 first)))+    measure (insertAllPersistently points)+  -- The angular index both bulk loaders open with, given one angle to work+  -- with. The input stays in general position, so the load runs the ordinary+  -- face-building path from the third point on and every insertion locates by+  -- walking; what degrades is the hull lookup that walk starts from, whose+  -- buckets all collapse into one. This lane is that degradation and nothing+  -- else — the face-less path it does NOT reach is "degenerate-line" below.+  SweepAngleCollapseLane -> do+    points <- evaluate (force (V.fromList (nearCollinearPoints 0x9e3779b97f4a7c15 first)))+    measure (buildTriangulation <$> require (delaunay unitElementDefaults points))+  -- Exactly collinear input never builds a face. Moonlight recognizes that+  -- section after radial admission and glues its complete DCEL chain once;+  -- Spade still locates against the growing face-less mesh per insertion.+  DegenerateLineLane -> do+    points <- evaluate (force (V.fromList (exactlyCollinearPoints first)))+    measure (buildTriangulation <$> require (delaunay unitElementDefaults points))+  BatchSweepLane -> do+    points <- evaluate (force (V.fromList (randomPoints 0x9e3779b97f4a7c15 first)))+    measure (buildTriangulation <$> require (insertMany (empty unitElementDefaults) points))+  NearestLane -> do+    triangulation <- buildTriangulation <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x0123456789abcdef first)))+    hierarchy <- require (buildHierarchyHint defaultHierarchyBranchFactor triangulation)+    queries <- requireQueryPoints (V.fromList (randomPoints 0x3141592653589793 second)) >>= evaluate . force+    measure (evaluate (V.sum (V.map (resolve triangulation hierarchy) queries)))+  CdtRecoveryLane -> do+    let points = V.fromList (randomPoints 0x94d049bb133111eb first)+    base <- fromDelaunay . buildTriangulation <$> require (delaunay unitElementDefaults points)+    queryPoints <- requireQueryPoints points+    handles <- evaluate (force (V.map (locateVertex base) queryPoints))+    pairs <-+      evaluate+        ( force+            (V.fromList [(handles V.! a, handles V.! b) | (a, b) <- constraintPairs first second])+        )+    measure (evaluate (recover base pairs))+  -- The same constraint program, requested one edge at a time through the+  -- singleton entry point instead of as a batch. The endpoints are handed over+  -- as points rather than handles because that is what this entry point takes;+  -- the strict side's counterpart takes points too, so both pay the same two+  -- locates per request.+  ConstraintIncrementalLane -> do+    let points = V.fromList (randomPoints 0x94d049bb133111eb first)+    base <- fromDelaunay . buildTriangulation <$> require (delaunay unitElementDefaults points)+    requests <-+      evaluate+        ( force+            [ (points V.! fromIndex, points V.! toIndex)+            | (fromIndex, toIndex) <- constraintPairs first second+            ]+        )+    measure (evaluate (length (snd (addConstraintsIncrementally base requests))))+  ConstraintSplitLane -> do+    (base, handles) <- splitBandCdt first+    resolved <- evaluate (force handles)+    measure (evaluate (numVertices (splitConstraints base resolved)))+  PublicationFloorLane -> do+    triangulation <- delaunayOf first+    measure $ do+      reopened <- require+        ( V.foldl'+            reopenTriangulation+            (Right triangulation)+            (V.enumFromN (0 :: Int) second)+        )+      evaluate (numVertices reopened)+  -- Removal by coordinate, against the same input prefix on both sides. The+  -- build is setup on both sides; the measured region is the removals alone.+  RemovalLane -> do+    let input = randomPoints 0x9e3779b97f4a7c15 first+    points <- evaluate (force (V.fromList input))+    base <- buildTriangulation <$> require (delaunay unitElementDefaults points)+    removals <- evaluate (force (V.fromList (take second input)))+    measure (removeAllByCoordinate base removals)+  -- One immutable snapshot per removal. Like snapshot insertion, this is a+  -- Haskell-only publication stress lane paired with the session reference;+  -- it is not a spade timing ratio.+  SnapshotRemovalLane -> do+    let input = randomPoints 0x9e3779b97f4a7c15 first+    points <- evaluate (force (V.fromList input))+    base <- buildTriangulation <$> require (delaunay unitElementDefaults points)+    removals <- evaluate (force (V.fromList (take second input)))+    measure (removeAllPersistently base removals)+  -- The hierarchy lanes. spade's hint generator maintains itself from inside+  -- the triangulation, so an insert or a removal there is the whole maintenance+  -- cost; here the hierarchy is a separate value and the maintenance is a+  -- separate call, and both are inside the clock.+  HierarchyIncrementalLane -> do+    points <- evaluate (force (V.fromList (randomPoints 0x9e3779b97f4a7c15 first)))+    measure (insertAllWithHierarchy points)+  HierarchyDuplicateLane -> do+    base <- hierarchyOf first+    duplicates <- evaluate (force (V.fromList (randomPoints 0x9e3779b97f4a7c15 second)))+    measure (reinsertAllWithHierarchy base duplicates)+  HierarchyRemovalLane -> do+    let input = randomPoints 0x9e3779b97f4a7c15 first+    base <- hierarchyOf first+    removals <- evaluate (force (V.fromList (take second input)))+    measure (removeAllWithHierarchy base removals)+  HierarchyRemovalOnlyLane -> do+    let input = randomPoints 0x9e3779b97f4a7c15 first+    (triangulation, _) <- hierarchyOf first+    removals <- evaluate (force (V.fromList (take second input)))+    measure (removeAllByCoordinate triangulation removals)+  HierarchyRebuildOnlyLane -> do+    let input = randomPoints 0x9e3779b97f4a7c15 first+    (triangulation, hierarchy) <- hierarchyOf first+    removals <- evaluate (force (V.fromList (take second input)))+    surviving <- removeAllByCoordinate triangulation removals+    measure (require (rebuildHierarchyHint hierarchy surviving))+  -- Sibson weights through the reusable workspace; the strict side holds the+  -- same buffers behind its NaturalNeighbor handle. The sum forces every+  -- weight, the way the nearest lane's index sum forces every search.+  InterpolationLane -> do+    triangulation <- buildTriangulation <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x0123456789abcdef first)))+    workspace <- newNaturalNeighborWorkspace triangulation+    queries <- requireQueryPoints (V.fromList (randomPoints 0x2718281828459045 second)) >>= evaluate . force+    measure (interpolationWeightSum workspace queries)+  -- The dual. Both sides hold it as a view of the primal mesh rather than as a+  -- second structure, so the mesh is setup on both and the sweep alone is timed.+  VoronoiSweepLane -> do+    triangulation <- delaunayOf first+    measure (evaluate (voronoiSweep triangulation))+  DcelWalkLane -> do+    triangulation <- delaunayOf first+    measure (evaluate (dcelWalk triangulation))+  AlphaPersistenceLane ->+    refuseLane AlphaPersistenceRequiresSpecializedRunner+  -- Corridor walks between interior endpoints. Both sides locate the start on a+  -- face and step edge to edge from there.+  IntersectionLane -> do+    triangulation <- delaunayOf first+    chords <- requireQueryChords (intersectionChords second) >>= evaluate . force+    measure (evaluate (intersectionWalk triangulation chords))+  -- The same walk from outside the hull. spade steps around the hull from the+  -- edge its locate returned; this side has no such entry and scans every+  -- vertex and every edge to find where the line goes in, once per query.+  IntersectionOutsideLane -> do+    triangulation <- delaunayOf first+    chords <- requireQueryChords (outsideChords second) >>= evaluate . force+    measure (evaluate (intersectionWalk triangulation chords))+  RefineLane -> do+    let (points, constraints) = refinementInput+    cdt <- buildTriangulation <$> require (constrainedDelaunay unitElementDefaults points constraints)+    let parameters = defaultRefinementParameters+          { refineMaxAdditionalVertices = Just first+          , refineMaxArea = Just 0.5+          , refineMaxRadiusEdgeRatio = Just 1.0+          , refineExcludeOuterFaces = True+          , refineKeepConstraintEdges = False+          }+    measure (refinementAddedVertices <$> require (refine id parameters (cdt :: ConstrainedDelaunayTriangulation Point)))+ where+  reopenTriangulation state _ = do+    triangulation <- state+    runST $ do+      mutable <- thawTriangulation (numVertices triangulation) triangulation+      freezeTriangulation mutable++  measure :: NFData value => IO value -> IO ()+  measure = measureLane request++  -- The answer is summed rather than merely tested for presence. A 'Maybe'+  -- scrutinised only to its outer constructor can be a 'Just' wrapping a thunk,+  -- and the lane would then time the allocation of a search rather than the+  -- search; the strict side has no such option and must be matched.+  resolve triangulation hierarchy query =+    let hint = case hierarchyHint hierarchy query of+          Just (VertexHint vertex) -> Just vertex+          _ -> Nothing+     in case nearestNeighbor triangulation hint query of+          Nothing -> 0 :: Word64+          Just (VertexId vertex, _) -> fromIntegral vertex++  locateVertex cdt point = case locatePoint cdt point of+    OnVertex vertex -> vertex+    other -> error ("input point is not a vertex: " <> show other)++  recover triangulation pairs =+    case recoverConstraints triangulation pairs of+      Left failure -> error (show failure)+      Right batch ->+        V.length+          ( V.filter+              (\outcome ->+                case outcome of+                  ConstraintAccepted _ _ -> True+                  ConstraintRejected _ -> False+              )+              (constraintBatchOutcomes batch)+          )
+ bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Alpha.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Matched end-to-end alpha-persistence work and its canonical receipt.+-- Input generation remains outside the timed action; Delaunay construction,+-- exact alpha births, cellular lowering, one reduction, and all critical-birth+-- Betti queries remain inside it.+module Moonlight.Triangulation.Bench.SpadeCompare.Alpha+  ( AlphaPersistenceObstruction (..)+  , AlphaPersistenceReceipt (..)+  , alphaPersistenceReceipt+  , renderAlphaPersistenceReceipt+  ) where++import Control.DeepSeq (NFData)+import Data.Bifunctor (first)+import Data.Bits (xor)+import Data.List (intercalate)+import Data.Vector (Vector)+import Data.Vector.Unboxed qualified as UnboxedVector+import Data.Word (Word64)+import GHC.Generics (Generic)+import Moonlight.Homology.Boundary+  ( degreeCardinality+  )+import Moonlight.Homology.Chain+  ( HomologicalDegree (..)+  , HomologyFailure+  , PersistencePair (..)+  )+import Moonlight.Homology.Persistence+  ( criticalBettiTableValues+  , filteredBaseComplex+  , filteredCriticalValues+  , mod2PersistentPairsWithCriticalBettiTable+  )+import Moonlight.Triangulation.Alpha+  ( AlphaFiltrationError+  , alphaFiltration+  )+import Moonlight.Triangulation.BulkLoad (delaunayGeometry)+import Moonlight.Triangulation.CellComplex+  ( DCELError+  , filteredAlphaComplex+  )+import Moonlight.Triangulation.Types+  ( BuildError+  , Point+  )++data AlphaPersistenceObstruction+  = AlphaPersistenceBuildRefused !BuildError+  | AlphaPersistenceBirthRefused !AlphaFiltrationError+  | AlphaPersistenceLoweringRefused !DCELError+  | AlphaPersistenceReductionRefused !HomologyFailure+  deriving stock (Eq, Show)++data AlphaPersistenceReceipt = AlphaPersistenceReceipt+  { alphaReceiptCriticalBirths :: !Int+  , alphaReceiptVertexCells :: !Int+  , alphaReceiptEdgeCells :: !Int+  , alphaReceiptFaceCells :: !Int+  , alphaReceiptFinitePairs :: !Int+  , alphaReceiptEssentialPairs :: !Int+  , alphaReceiptProfileChecksum :: !Word64+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++alphaPersistenceReceipt+  :: Vector Point+  -> Either AlphaPersistenceObstruction AlphaPersistenceReceipt+alphaPersistenceReceipt points = do+  triangulation <-+    first AlphaPersistenceBuildRefused (delaunayGeometry points)+  filtration <-+    first AlphaPersistenceBirthRefused (alphaFiltration triangulation)+  filtered <-+    first AlphaPersistenceLoweringRefused (filteredAlphaComplex filtration)+  (pairs, criticalBettiTable) <-+    first AlphaPersistenceReductionRefused+      (mod2PersistentPairsWithCriticalBettiTable filtered)+  let criticalBirths = filteredCriticalValues filtered+      finite = filteredBaseComplex filtered+      isFinitePair = maybe False (const True) . persistenceDeath+  pure+    AlphaPersistenceReceipt+      { alphaReceiptCriticalBirths = length criticalBirths+      , alphaReceiptVertexCells = degreeCardinality finite (HomologicalDegree 0)+      , alphaReceiptEdgeCells = degreeCardinality finite (HomologicalDegree 1)+      , alphaReceiptFaceCells = degreeCardinality finite (HomologicalDegree 2)+      , alphaReceiptFinitePairs = length (filter isFinitePair pairs)+      , alphaReceiptEssentialPairs = length (filter (not . isFinitePair) pairs)+      , alphaReceiptProfileChecksum =+          UnboxedVector.foldl'+            mixChecksum+            fnvOffset+            (criticalBettiTableValues criticalBettiTable)+      }++mixChecksum :: Word64 -> Int -> Word64+mixChecksum accumulator value =+  (accumulator `xor` fromIntegral value) * fnvPrime++fnvOffset :: Word64+fnvOffset = 14695981039346656037++fnvPrime :: Word64+fnvPrime = 1099511628211++renderAlphaPersistenceReceipt :: AlphaPersistenceReceipt -> String+renderAlphaPersistenceReceipt receipt =+  intercalate+    ","+    ( fmap+        show+        [ fromIntegral (alphaReceiptCriticalBirths receipt) :: Word64+        , fromIntegral (alphaReceiptVertexCells receipt)+        , fromIntegral (alphaReceiptEdgeCells receipt)+        , fromIntegral (alphaReceiptFaceCells receipt)+        , fromIntegral (alphaReceiptFinitePairs receipt)+        , fromIntegral (alphaReceiptEssentialPairs receipt)+        , alphaReceiptProfileChecksum receipt+        ]+    )
+ bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Constraint.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE DataKinds #-}++-- | Constraint recovery and splitting lanes and their gates.+module Moonlight.Triangulation.Bench.SpadeCompare.Constraint where++import Data.Primitive.PrimArray (indexPrimArray, sizeofPrimArray)+import System.FilePath ((</>))+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.Cdt+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Bench.SpadeCompare.Support+import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints)++-- | Disjoint split cells, stacked in y: the points, the vertical constraints+-- the build starts from, and the crossing requests. Band @i@ carries a+-- constraint from (16, 4i) to (16, 4i + 2) and a crossing request from+-- (0, 4i + a) to (32, 4i + b), with a and b jittered inside the band, so every+-- request crosses exactly one constraint and no request reaches another band.+--+-- The geometry is chosen so the split point is not merely close on the two+-- sides but identical. spade solves the two line equations by Cramer's rule and+-- this side walks the parametric form; here every coefficient either vanishes+-- or is a power of two, both reduce to one rounding of @u + (v - u) / 2@, and+-- neither can round it differently. A generic crossing would leave the two+-- formulas free to disagree in the last bit and there would be nothing to gate.+splitBands :: Int -> (V.Vector Point, V.Vector (Int, Int), [(Int, Int)])+splitBands bandCount =+  ( V.fromList (concatMap bandPoints (zip [0 ..] jitter))+  , V.fromList [(4 * index, 4 * index + 1) | index <- [0 .. bandCount - 1]]+  , [(4 * index + 2, 4 * index + 3) | index <- [0 .. bandCount - 1]]+  )+ where+  jitter = randomPoints 0x51ed270b7c1fd1a3 bandCount++  bandPoints (index, Point offsetX offsetY) =+    let base = 4 * fromIntegral (index :: Int)+     in [ Point 16 base+        , Point 16 (base + 2)+        , Point 0 (base + 1 + 0.5 * offsetX)+        , Point 32 (base + 1 + 0.5 * offsetY)+        ]++-- | The same constraint program the batch recovery runs, one request at a time+-- through the persistent singleton entry point. A request whose corridor is+-- blocked by an existing constraint is refused and the previous triangulation+-- stands, which is what the strict side's 'can_add_constraint' guard arranges.+addConstraintsIncrementally+  :: ConstrainedDelaunayTriangulation Point+  -> [(Point, Point)]+  -> (ConstrainedDelaunayTriangulation Point, [Int])+addConstraintsIncrementally base requests =+  case foldl' step (base, []) (zip [0 ..] requests) of+    (triangulation, accepted) -> (triangulation, reverse accepted)+ where+  step (triangulation, accepted) (index, (from, to)) =+    case addConstraintEdge triangulation from to of+      Left (ConstraintIntersection _) -> (triangulation, accepted)+      Left failure -> error (show failure)+      Right result -> (constraintRecoveryTriangulation result, index : accepted)++-- | Splitting requests, one per band, carried by the batch verb: one+-- transaction for every corridor, published once -- the shape of the strict+-- side's fold over one mutable CDT, which publishes nothing between splits.+-- Every crossed constraint is split at the intersection rather than refused,+-- so every request is accepted. Splitting appends vertices and never removes+-- one, so the handles resolved before the first request stay valid through+-- the last.+splitConstraints+  :: ConstrainedDelaunayTriangulation Point+  -> [(VertexId, VertexId)]+  -> ConstrainedDelaunayTriangulation Point+splitConstraints base requests =+  case addConstraintsAndSplit id base (V.fromList requests) of+    Left failure -> error (show failure)+    Right result -> constraintRecoveryTriangulation result++-- | The singleton constraint program's accepted request indices and final+-- constrained edge set. A blocked request must be refused at the same index on+-- both sides, or the two are not running the same program.+writeConstraintIncrementalGate :: FilePath -> Int -> Int -> IO ()+writeConstraintIncrementalGate directory pointCount constraintCount = do+  let points = V.fromList (randomPoints 0x94d049bb133111eb pointCount)+      requests =+        [ (points V.! fromIndex, points V.! toIndex)+        | (fromIndex, toIndex) <- constraintPairs pointCount constraintCount+        ]+  base <- fromDelaunay . buildTriangulation <$> require (delaunay unitElementDefaults points)+  let (recovered, accepted) = addConstraintsIncrementally base requests+      prefix =+        directory+          </> ("constraint-incremental-" <> show pointCount <> "-" <> show constraintCount)+  writeFile (prefix <> "-accepted.txt") (unlines (map show accepted))+  writeFile (prefix <> "-constraints.txt") (unlines (canonicalConstraintEdges recovered))++-- | Both the split vertices and the constrained edges they carve. The edge set+-- names every vertex by coordinate, so a split point that landed one ulp away+-- on one side shows up here rather than hiding behind a matching edge count.+writeConstraintSplitGate :: FilePath -> Int -> IO ()+writeConstraintSplitGate directory bandCount = do+  (base, handles) <- splitBandCdt bandCount+  let split = splitConstraints base handles+      prefix = directory </> ("constraint-split-" <> show bandCount)+  writeFile (prefix <> "-edges.txt") (unlines (canonicalEdges split))+  writeFile (prefix <> "-constraints.txt") (unlines (canonicalConstraintEdges split))++-- | The banded CDT and the crossing requests named by handle. Handle resolution+-- goes through the build's own input mapping rather than a locate, which is the+-- constraint gate's convention; the strict side has no such mapping and locates+-- instead. Either way both name the vertex standing at the same coordinate.+splitBandCdt+  :: Int+  -> IO (ConstrainedDelaunayTriangulation Point, [(VertexId, VertexId)])+splitBandCdt bandCount = do+  let (points, constraints, crossings) = splitBands bandCount+  built <- require (constrainedDelaunay unitElementDefaults points constraints)+  let mapping = buildInputVertices built+      len = sizeofPrimArray mapping+      resolve index+        | index >= 0 && index < len = VertexId (indexPrimArray mapping index)+        | otherwise = error ("split band endpoint is out of range: " <> show index)+  pure+    ( buildTriangulation built+    , [(resolve fromIndex, resolve toIndex) | (fromIndex, toIndex) <- crossings]+    )++writeConstraintGate :: FilePath -> IO ()+writeConstraintGate directory = do+  let points = V.fromList (randomPoints 0x94d049bb133111eb 8000)+      requestIndices = V.fromList (constraintPairs 8000 800)+  built <- require (delaunay unitElementDefaults points)+  let mapping = buildInputVertices built+      len = sizeofPrimArray mapping+  requests <-+    V.mapM+      (\(fromIndex, toIndex) ->+        let mFrom = if fromIndex >= 0 && fromIndex < len then Just (VertexId (indexPrimArray mapping fromIndex)) else Nothing+            mTo = if toIndex >= 0 && toIndex < len then Just (VertexId (indexPrimArray mapping toIndex)) else Nothing+        in case (mFrom, mTo) of+          (Just from, Just to) -> pure (from, to)+          _ -> fail "constraint gate endpoint is out of range"+      )+      requestIndices+  batch <-+    require+      ( recoverConstraints+          (fromDelaunay (buildTriangulation built))+          requests+      )+  let accepted =+        V.ifoldr+          (\index outcome indices ->+            case outcome of+              ConstraintAccepted _ _ -> index : indices+              ConstraintRejected _ -> indices+          )+          []+          (constraintBatchOutcomes batch)+  writeFile+    (directory </> "cdt-accepted-8000-800.txt")+    (unlines (map show accepted))+  writeFile+    (directory </> "cdt-constraints-8000-800.txt")+    (unlines (canonicalConstraintEdges (constraintBatchTriangulation batch)))
+ bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Dcel.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE DataKinds #-}++-- | The primal DCEL traversal gate and the walk lane.+module Moonlight.Triangulation.Bench.SpadeCompare.Dcel where++import Data.List (sort)+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (allFaces, directedEdges)+import Moonlight.Triangulation.Handles.Iterators.HullIterator (hullEdges)+import System.FilePath ((</>))+import Moonlight.Triangulation+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Bench.SpadeCompare.Support++-- | Every iterator over the mesh that spade also offers. The hull cycle and+-- each vertex's counterclockwise link are cycles with no determined starting+-- point and are rotated; the inner faces are a set and are sorted. The+-- enumerator lengths are stated because they are the only cross-comparable+-- claim the fixed and dynamic iterators make: their elements are handles, and+-- handles do not cross implementations.+writeDcelWalkGate :: FilePath -> Int -> IO ()+writeDcelWalkGate directory count = do+  triangulation <- delaunayOf count+  writeFile+    (directory </> ("dcel-hull-" <> show count <> ".txt"))+    (unlines (hullGateLines triangulation))+  writeFile+    (directory </> ("dcel-circular-" <> show count <> ".txt"))+    (unlines (circularGateLines triangulation))+  writeFile+    (directory </> ("dcel-faces-" <> show count <> ".txt"))+    (unlines (innerFaceGateLines triangulation))++hullGateLines :: DelaunayTriangulation Point -> [String]+hullGateLines triangulation =+  ("hull-size " <> show (length ring)) : rotateToSmallest ring+ where+  ring =+    [ coordHex (vertexPoint triangulation (origin triangulation edge))+        <> coordHex (vertexPoint triangulation (destination triangulation edge))+    | edge <- hullEdges triangulation+    ]++circularGateLines :: DelaunayTriangulation Point -> [String]+circularGateLines triangulation =+  [ "vertices " <> show (length (vertices triangulation))+  , "directed-edges " <> show (length (directedEdges triangulation))+  , "undirected-edges " <> show (length (undirectedEdges triangulation))+  , "all-faces " <> show (length (allFaces triangulation))+  , "inner-faces " <> show (length (innerFaces triangulation))+  ]+    <> sort+      [ coordHex (vertexPoint triangulation vertex) <> concat (rotateToSmallest ring)+      | vertex <- vertices triangulation+      , let ring =+              [ coordHex (vertexPoint triangulation (destination triangulation edge))+              | edge <- vertexOutgoingEdges triangulation vertex+              ]+      ]++innerFaceGateLines :: DelaunayTriangulation Point -> [String]+innerFaceGateLines triangulation =+  sort+    [ concat (sort (map (coordHex . vertexPoint triangulation) [a, b, c]))+    | face <- innerFaces triangulation+    , Just (a, b, c) <- [innerFaceVertices triangulation face]+    ]++-- | Every traversal the DCEL offers, in one pass: the hull cycle, each vertex's+-- counterclockwise link, and each inner face's vertex triple. The coordinates+-- are summed so that no step can be satisfied by a thunk.+dcelWalk :: DelaunayTriangulation Point -> (Double, Int)+dcelWalk triangulation = overFaces (overVertices (overHull (0, 0)))+ where+  overHull accumulator =+    foldl' (\acc edge -> charge acc (origin triangulation edge)) accumulator (hullEdges triangulation)++  overVertices accumulator = foldl' overLink accumulator (vertices triangulation)++  overLink accumulator vertex =+    foldl'+      (\acc edge -> charge acc (destination triangulation edge))+      accumulator+      (vertexOutgoingEdges triangulation vertex)++  overFaces accumulator = foldl' overCorners accumulator (innerFaces triangulation)++  overCorners accumulator face =+    case innerFaceVertices triangulation face of+      Nothing -> accumulator+      Just (a, b, c) -> foldl' charge accumulator [a, b, c]++  charge (!total, !count) vertex =+    let Point x y = vertexPoint triangulation vertex+     in (total + x + y, count + 1)
+ bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Delaunay.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE DataKinds #-}++-- | Bulk-load, incremental, nearest, and refinement lanes and their gates.+module Moonlight.Triangulation.Bench.SpadeCompare.Delaunay where++import Control.Exception (evaluate)+import Data.Foldable (traverse_)+import System.Exit (exitWith, ExitCode (ExitFailure))+import System.FilePath ((</>))+import System.IO (hPutStrLn, stderr)+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.BulkLoad+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.HintGenerator+import Moonlight.Triangulation.Session+import Moonlight.Triangulation.Types+import Moonlight.Triangulation.Bench.SpadeCompare.Support+import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints)++writeBulkLoadGate :: FilePath -> Int -> IO ()+writeBulkLoadGate directory count = do+  triangulation <-+    require+      ( delaunayGeometry+          (V.fromList (randomPoints 0x9e3779b97f4a7c15 count))+      )+  writeFile+    (directory </> ("bulk-load-" <> show count <> "-edges.txt"))+    (unlines (canonicalEdges triangulation))++writeIncrementalGate :: FilePath -> Int -> IO ()+writeIncrementalGate directory count = do+  triangulation <-+    insertAllIncrementally+      (V.fromList (randomPoints 0x9e3779b97f4a7c15 count))+  writeFile+    (directory </> ("incremental-" <> show count <> "-edges.txt"))+    (unlines (canonicalEdges triangulation))++writeNearestGate :: FilePath -> IO ()+writeNearestGate directory = do+  let pointCount = 20000+      queryCount = 5000+  triangulation <-+    buildTriangulation+      <$> require+        ( delaunay+            unitElementDefaults+            (V.fromList (randomPoints 0x0123456789abcdef pointCount))+        )+  hierarchy <- require (buildHierarchyHint defaultHierarchyBranchFactor triangulation)+  queries <- requireQueryPoints (randomPoints 0x3141592653589793 queryCount)+  writeFile+    (directory </> "nearest-20000-5000.txt")+    (unlines (map (nearestAnswer triangulation hierarchy) queries))++writeRefinementGate :: FilePath -> Int -> IO ()+writeRefinementGate directory steinerBudget = do+  let (points, constraints) = refinementInput+      parameters =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just steinerBudget+          , refineMaxArea = Just 0.5+          , refineMaxRadiusEdgeRatio = Just 1.0+          , refineExcludeOuterFaces = True+          , refineKeepConstraintEdges = False+          }+  cdtBuild <- require (constrainedDelaunay unitElementDefaults points constraints)+  refined <-+    require+      ( refine+          id+          parameters+          (buildTriangulation cdtBuild :: ConstrainedDelaunayTriangulation Point)+      )+  let triangulation = refinedTriangulation refined+      prefix = directory </> ("refine-" <> show steinerBudget)+      completion = if refinementComplete refined then "1" else "0"+      summary =+        [ "added " <> show (refinementAddedVertices refined)+        , "vertices " <> show (numVertices triangulation)+        , "edges " <> show (numUndirectedEdges triangulation)+        , "inner-faces " <> show (numInnerFaces triangulation)+        , "excluded " <> show (V.length (refinementExcludedFaces refined))+        , "complete " <> completion+        ]+  writeFile (prefix <> "-summary.txt") (unlines summary)+  writeFile (prefix <> "-edges.txt") (unlines (canonicalEdges triangulation))+  writeFile+    (prefix <> "-constraints.txt")+    (unlines (canonicalConstraintEdges triangulation))++-- | Arrival-order insertion through immutable snapshots. The artifact proves+-- final-state agreement with Spade; it is not a cross-language timing row.+writePersistentGate :: FilePath -> Int -> IO ()+writePersistentGate directory count = do+  triangulation <-+    insertAllPersistently (V.fromList (randomPoints 0x9e3779b97f4a7c15 count))+  writeFile+    (directory </> ("persistent-" <> show count <> "-edges.txt"))+    (unlines (canonicalEdges triangulation))++writeSweepAngleGate :: FilePath -> Int -> IO ()+writeSweepAngleGate directory count = do+  triangulation <-+    buildTriangulation+      <$> require+        ( delaunay+            unitElementDefaults+            (V.fromList (nearCollinearPoints 0x9e3779b97f4a7c15 count))+        )+  writeFile+    (directory </> ("sweep-angle-collapse-" <> show count <> "-edges.txt"))+    (unlines (canonicalEdges triangulation))++-- | The degenerate chain, pinned by the only thing it has: its edges.+--+-- There are no faces to compare and no circumcentres to argue about, so unlike+-- every other gate here this one has no per-side half and no exclusion. The+-- answer is @n - 1@ consecutive segments and the two sides either both produce+-- it or one of them is wrong.+writeDegenerateLineGate :: FilePath -> Int -> IO ()+writeDegenerateLineGate directory count = do+  triangulation <-+    buildTriangulation+      <$> require+        (delaunay unitElementDefaults (V.fromList (exactlyCollinearPoints count)))+  writeFile+    (directory </> ("degenerate-line-" <> show count <> "-edges.txt"))+    (unlines (canonicalEdges triangulation))++-- Arrival-order insertion with one publication: the transactional comparison+-- against Spade's @&mut self@ insertion. The per-operation snapshot fold is+-- measured separately as Moonlight publication stress.+insertAllIncrementally+  :: V.Vector Point+  -> IO (DelaunayTriangulation Point)+insertAllIncrementally points =+  evaluate+    ( case either (error . show) id+        ( withSession+            (empty unitElementDefaults)+            (V.length points)+            (V.mapM_ insertVertex points)+        ) of+        (_, frozen, _) -> frozen+    )++insertAllPersistently+  :: V.Vector Point+  -> IO (DelaunayTriangulation Point)+insertAllPersistently =+  V.foldM'+    (\triangulation point ->+      insertionTriangulation <$> require (insert triangulation point)+    )+    (empty unitElementDefaults)++-- | The refinement lane's own counters, so the worklist question is answered by+-- measurement rather than by assertion.+--+-- @faceChecks@ is not a worklist counter: the terminal audit runs the complete+-- face evaluation over every final inner face without popping anything. So the+-- amplification ratio is @pops / steiner@, and @faceChecks - pops@ should equal+-- the final inner-face count less any pop discarded as excluded.+-- | The circle sweep's placement split, on the same generator the bulk lanes+-- use. A point takes the fast path when the hull edge its own angle selected+-- has the point strictly to its left; otherwise it is deferred to a generic+-- insertion after the sweep finishes. spade takes the identical branch on+-- @is_on_right_side_or_on_line@ and its own source calls that fallback "very+-- slow", so a materially non-zero skip count is wasted work in the bulk lane+-- rather than a curiosity. @seed + fast + skipped@ must exhaust the unique+-- points; this reports the identity rather than asserting it silently.+reportSweepStats :: Int -> IO ()+reportSweepStats count = do+  let points = V.fromList (randomPoints 0x9e3779b97f4a7c15 count)+  built <- require (delaunay unitElementDefaults points)+  let stats = buildStats (built :: BuildResult 'Unconstrained Point () () ())+      seeded = statSpatialSeedPoints stats+      fast = statSweepFastPoints stats+      skippedPoints = statSweepSkippedPoints stats+      unique = statUniquePoints stats+      accounted = seeded + fast + skippedPoints+      share :: Int -> String+      share value+        | unique == 0 = "n/a"+        | otherwise = show (100 * fromIntegral value / fromIntegral unique :: Double) <> "%"+  traverse_+    putStrLn+    [ "input-points " <> show (statInputPoints stats)+    , "unique-points " <> show unique+    , "duplicate-points " <> show (statDuplicatePoints stats)+    , "seed-points " <> show seeded+    , "sweep-fast-points " <> show fast+    , "sweep-skipped-points " <> show skippedPoints+    , "skipped-share " <> share skippedPoints+    , "accounted " <> show accounted+    , "identity-holds " <> show (accounted == unique)+    , "edge-flips " <> show (statEdgeFlips stats)+    , "hull-insertions " <> show (statHullInsertions stats)+    , "legalization-max-stack " <> show (statLegalizationMaxStack stats)+    ]+  if accounted == unique+    then pure ()+    else do+      hPutStrLn+        stderr+        ( "sweep-stats: seed + fast + skipped = "+            <> show accounted+            <> " but unique = "+            <> show unique+        )+      exitWith (ExitFailure 1)++reportRefinementCounters :: Int -> IO ()+reportRefinementCounters budget = do+  let (points, constraints) = refinementInput+      parameters =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just budget+          , refineMaxArea = Just 0.5+          , refineMaxRadiusEdgeRatio = Just 1.0+          , refineExcludeOuterFaces = True+          , refineKeepConstraintEdges = False+          }+  cdt <- buildTriangulation <$> require (constrainedDelaunay unitElementDefaults points constraints)+  result <-+    require (refine id parameters (cdt :: ConstrainedDelaunayTriangulation Point))+  let stats = refinementStats result+      steiner = statSteinerPoints stats+      pops = statRefinementQueuePops stats+      checks = statRefinementFaceChecks stats+      inner = numInnerFaces (refinedTriangulation result)+      excluded = V.length (refinementExcludedFaces result)+      ratio :: Int -> Int -> String+      ratio numerator denominator+        | denominator == 0 = "n/a"+        | otherwise =+            show (fromIntegral numerator / fromIntegral denominator :: Double)+  traverse_+    putStrLn+    [ "budget " <> show budget+    , "steiner " <> show steiner+    , "queue-pops " <> show pops+    , "face-checks " <> show checks+    , "inner-faces " <> show inner+    , "excluded " <> show excluded+    , "edge-flips " <> show (statEdgeFlips stats)+    , "location-walk-steps " <> show (statLocationWalkSteps stats)+    , "complete " <> show (refinementComplete result)+    , "pops/steiner " <> ratio pops steiner+    , "checks/steiner " <> ratio checks steiner+    , "flips/steiner " <> ratio (statEdgeFlips stats) steiner+    , "walk-steps/steiner " <> ratio (statLocationWalkSteps stats) steiner+    , "checks-minus-pops " <> show (checks - pops)+    -- Every face check is now a queue pop. The terminal audit used to make the+    -- difference equal the final inner-face count; if this ever reads False+    -- again, a second whole-mesh quality pass has come back.+    , "no-second-pass " <> show (checks == pops)+    ]
+ bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Gates.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE DataKinds #-}++-- | The artifact rosters: every gate the binary writes, and the divergence set.+module Moonlight.Triangulation.Bench.SpadeCompare.Gates where++import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Data.Bifunctor (first)+import Data.Foldable (traverse_)+import System.Directory (createDirectoryIfMissing)+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.BulkLoad+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Removal+import Moonlight.Triangulation.Types+import Moonlight.Triangulation.Bench.SpadeCompare.Constraint+import Moonlight.Triangulation.Bench.SpadeCompare.Dcel+import Moonlight.Triangulation.Bench.SpadeCompare.Delaunay+import Moonlight.Triangulation.Bench.SpadeCompare.Hierarchy+import Moonlight.Triangulation.Bench.SpadeCompare.Interpolation+import Moonlight.Triangulation.Bench.SpadeCompare.Intersection+import Moonlight.Triangulation.Bench.SpadeCompare.Removal+import Moonlight.Triangulation.Bench.SpadeCompare.Support+import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints)+import Moonlight.Triangulation.Bench.SpadeCompare.Voronoi++-- | The exact observable mesh egress retained by the persistent witnesses.+--+-- These artifacts validate immutable predecessor and final-state agreement;+-- they are not Spade timing ratios. Snapshot publication is measured only on+-- the Haskell side against its session reference.+--+-- The cross-language gate already compares the canonical-edge projection.+-- This witness additionally retains the geometry-labelled circular DCEL+-- section, so an isolated or face-less predecessor cannot change unseen.  It+-- deliberately observes geometric topology rather than internal storage, and+-- remains a gate-only sink outside every timed lane.+data PersistentEndpoint = PersistentEndpoint+  { persistentEndpointVertices :: !Int+  , persistentEndpointUndirectedEdges :: !Int+  , persistentEndpointInnerFaces :: !Int+  , persistentEndpointCanonicalEdges :: ![String]+  , persistentEndpointCircularDcel :: ![String]+  }+  deriving (Eq, Show)++-- | Every retained section is named by its operation and completed edit count,+-- never by a formatting-only string.+data PersistentWitnessLabel+  = PersistentInsertionWitness !Int+  | PersistentRemovalWitness !Int+  deriving (Eq, Show)++-- | A preserved immutable section together with its authoritative egress at+-- capture time.  Insert and removal each supply one concrete use, so this is+-- the shared gate algebra rather than a second triangulation representation.+data PersistentSnapshotWitness = PersistentSnapshotWitness+  { persistentSnapshotLabel :: !PersistentWitnessLabel+  , persistentSnapshotEndpoint :: !PersistentEndpoint+  , persistentSnapshotTriangulation :: !(DelaunayTriangulation Point)+  }++-- | Complete typed refusal surface for the persistence gate.  The public+-- operations already return 'BuildError'; the witness transports it instead+-- of manufacturing a stringly failure.  A changed snapshot carries its exact+-- observed endpoint so the gate failure is inspectable without a unilateral+-- artifact.+data PersistentSnapshotObstruction+  = PersistentInitialBuildRefused !BuildError+  | PersistentInsertionRefused !Int !BuildError+  | PersistentRemovalRefused !Int !BuildError+  | PersistentRemovalTargetMissing !Int+  | PersistentSnapshotChanged+      !PersistentWitnessLabel+      !PersistentEndpoint+      !PersistentEndpoint+  deriving Show++persistentEndpoint+  :: DelaunayTriangulation Point+  -> IO PersistentEndpoint+persistentEndpoint triangulation = do+  edges <- evaluate (force (canonicalEdges triangulation))+  circular <- evaluate (force (circularGateLines triangulation))+  pure $!+    PersistentEndpoint+      { persistentEndpointVertices = numVertices triangulation+      , persistentEndpointUndirectedEdges = numUndirectedEdges triangulation+      , persistentEndpointInnerFaces = numInnerFaces triangulation+      , persistentEndpointCanonicalEdges = edges+      , persistentEndpointCircularDcel = circular+      }++capturePersistentSnapshot+  :: PersistentWitnessLabel+  -> DelaunayTriangulation Point+  -> IO PersistentSnapshotWitness+capturePersistentSnapshot label triangulation = do+  endpoint <- persistentEndpoint triangulation+  pure+    PersistentSnapshotWitness+      { persistentSnapshotLabel = label+      , persistentSnapshotEndpoint = endpoint+      , persistentSnapshotTriangulation = triangulation+      }++verifyPersistentSnapshot+  :: PersistentSnapshotWitness+  -> IO (Either PersistentSnapshotObstruction ())+verifyPersistentSnapshot witness = do+  observed <- persistentEndpoint (persistentSnapshotTriangulation witness)+  pure+    ( if observed == persistentSnapshotEndpoint witness+        then Right ()+        else+          Left+            ( PersistentSnapshotChanged+                (persistentSnapshotLabel witness)+                (persistentSnapshotEndpoint witness)+                observed+            )+    )++verifyPersistentSnapshots :: [PersistentSnapshotWitness] -> IO (Either PersistentSnapshotObstruction ())+verifyPersistentSnapshots = fmap sequence_ . traverse verifyPersistentSnapshot++assertPersistentSnapshot+  :: Either PersistentSnapshotObstruction value+  -> IO value+assertPersistentSnapshot = require++-- | Fixed sparse checkpoints of a longer immutable chain.  Each one has later+-- edits behind it, so the test distinguishes persistence from merely producing+-- the correct final mesh.+persistentCheckpoint :: Int -> Bool+persistentCheckpoint index = index `elem` [0, 1, 2, 7, 31, 63]++verifyPersistentInsertionSnapshots :: IO ()+verifyPersistentInsertionSnapshots = do+  let points = V.fromList (randomPoints 0x9e3779b97f4a7c15 96)+      initial = empty unitElementDefaults+  initialWitness <- capturePersistentSnapshot (PersistentInsertionWitness 0) initial+  (final, witnesses) <-+    V.ifoldM'+      (\(current, preserved) index point -> do+        nextTriangulation <-+          assertPersistentSnapshot+            ( insertionTriangulation+                <$> first (PersistentInsertionRefused index) (insert current point)+            )+        if persistentCheckpoint index+          then do+            witness <- capturePersistentSnapshot (PersistentInsertionWitness (index + 1)) nextTriangulation+            pure (nextTriangulation, preserved <> [witness])+          else pure (nextTriangulation, preserved)+      )+      (initial, [initialWitness])+      points+  -- Force the terminal endpoint as an out-of-clock comparable sink before+  -- checking predecessors; its edge projection is the same projection the+  -- Rust gate emits for the timed lanes.+  _ <- persistentEndpoint final+  assertPersistentSnapshot =<< verifyPersistentSnapshots witnesses++verifyPersistentRemovalSnapshots :: IO ()+verifyPersistentRemovalSnapshots = do+  let points = V.fromList (randomPoints 0x9e3779b97f4a7c15 128)+      removals = V.take 96 points+  initial <-+    buildTriangulation+      <$> assertPersistentSnapshot+        (first PersistentInitialBuildRefused (delaunay unitElementDefaults points))+  initialWitness <- capturePersistentSnapshot (PersistentRemovalWitness 0) initial+  (final, witnesses) <-+    V.ifoldM'+      (\(current, preserved) index point -> do+        outcome <-+          assertPersistentSnapshot+            (first (PersistentRemovalRefused index) (locateAndRemove current point))+        nextTriangulation <-+          case outcome of+            Nothing -> assertPersistentSnapshot (Left (PersistentRemovalTargetMissing index))+            Just removal -> pure (removalTriangulation removal)+        if persistentCheckpoint index+          then do+            witness <- capturePersistentSnapshot (PersistentRemovalWitness (index + 1)) nextTriangulation+            pure (nextTriangulation, preserved <> [witness])+          else pure (nextTriangulation, preserved)+      )+      (initial, [initialWitness])+      removals+  _ <- persistentEndpoint final+  assertPersistentSnapshot =<< verifyPersistentSnapshots witnesses++-- | The Haskell side's immutable-contract gate.  It emits no extra artifact:+-- adding a unilateral file would make the cross-language artifact diff fail.+-- Its selected predecessor sections are instead verified before the existing+-- shared endpoint artifacts are written.+verifyPersistentSnapshotWitnesses :: IO ()+verifyPersistentSnapshotWitnesses = do+  verifyPersistentInsertionSnapshots+  verifyPersistentRemovalSnapshots++-- | Pin the exact output of every timed workload before comparing its cost.+-- Persistent witness artifacts above are final-state agreement gates, not+-- cross-language timing rows.+writeGate :: FilePath -> IO ()+writeGate directory = do+  createDirectoryIfMissing True directory+  verifyPersistentSnapshotWitnesses+  traverse_ (writeBulkLoadGate directory) [1000, 10000]+  traverse_ (writeIncrementalGate directory) [1000, 10000]+  writeNearestGate directory+  writeConstraintGate directory+  traverse_ (writeRefinementGate directory) [625, 2500]+  traverse_ (uncurry (writeRemovalGate directory)) [(1000, 250), (10000, 2500)]+  traverse_ (uncurry (writeInterpolationGate directory)) [(10000, 1000), (100000, 2000)]+  writeVoronoiGate directory 1000+  writeDcelWalkGate directory 2000+  writeIntersectionGate directory 10000 500+  writeIntersectionVertexGate directory 2000+  -- Persistent artifacts validate final-state agreement only; they are not+  -- Spade timing rows. Their canonical egress is retained for the hard gate.+  writePersistentGate directory 1000+  writePersistentRemovalGate directory 10000 2500+  -- The remaining diagnostic gates. Timing is meaningful only after both+  -- sides have been shown to compute the same canonical result.+  writeConstraintIncrementalGate directory 8000 800+  writeConstraintSplitGate directory 1000+  writeSweepAngleGate directory 2000+  writeDegenerateLineGate directory 2000+  writeHierarchyIncrementalGate directory 1000+  writeHierarchyDuplicateGate directory 10000 500+  writeHierarchyRemovalGate directory 10000 250+  writeIntersectionOutsideGate directory 2000 100++-- | The shapes on which the two implementations classify the constrained+-- domain. They do not agree, so this is a characterization rather than a gate:+-- the committed baselines lock in the known divergence and fail if either side+-- moves. See @README.md@ for the compatibility rule.+divergenceShapes :: [(String, [Point], [(Int, Int)])]+divergenceShapes =+  [ ("flush", square 8 <> [Point 4 4], loop4)+  , ("notched", square 8 <> [Point 13 4, Point 4 4], loop4)+  , ("flush-plus-dangling-segment", square 8 <> [Point 2 2, Point 6 6], loop4 <> [(4, 5)])+  , ("notched-plus-dangling-segment", square 8 <> [Point 13 4, Point 2 2, Point 6 6], loop4 <> [(5, 6)])+  , ( "annulus"+    , square 12 <> [Point 4 4, Point 8 4, Point 8 8, Point 4 8]+    , loop4 <> [(4, 5), (5, 6), (6, 7), (7, 4)]+    )+  ]+ where+  square scale = [Point 0 0, Point scale 0, Point scale scale, Point 0 scale]+  loop4 = [(0, 1), (1, 2), (2, 3), (3, 0)]++writeDivergence :: FilePath -> IO ()+writeDivergence path = do+  rows <- mapM row divergenceShapes+  writeFile path (unlines rows)+ where+  row (label, points, constraints) = do+    built <- require (constrainedDelaunay unitElementDefaults (V.fromList points) (V.fromList constraints))+    let cdt = buildTriangulation built+        parameters =+          defaultRefinementParameters+            { refineMaxAdditionalVertices = Just 0+            , refineExcludeOuterFaces = True+            }+    classified <- require (refine id parameters cdt)+    pure+      ( label+          <> ": inner " <> show (numInnerFaces cdt)+          <> ", excluded " <> show (V.length (refinementExcludedFaces classified))+      )
+ bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Hierarchy.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE DataKinds #-}++-- | Hierarchy-hint lanes, their gates, and the maintained-hint step.+module Moonlight.Triangulation.Bench.SpadeCompare.Hierarchy where++import System.FilePath ((</>))+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.BulkLoad+import Moonlight.Triangulation.HintGenerator+import Moonlight.Triangulation.Math (validatePoint)+import Moonlight.Triangulation.Session+import Moonlight.Triangulation.Bench.SpadeCompare.Support+import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints)++-- | The step both insertion lanes run: one insert, one hierarchy update, and+-- nothing between them. It is what spade's @insert@ does internally through+-- @notify_vertex_inserted@, and both sides carry branch factor 16.+--+-- The point handed to 'updateHierarchyAfterInsertion' is the same binding+-- handed to 'insertVertexAt', never one read back out of the harness's input+-- vector. The mesh stores 'canonicalPoint' of what it was given, so a+-- harness-side copy would part company from it on a signed zero, seed a+-- different nearest neighbour, and move the gate against spade. Same function,+-- same argument, same bits.+hierarchyStep+  :: HierarchyHint+  -> Point+  -> Session s Point () () () HierarchyHint+hierarchyStep hierarchy point = do+  query <- either refuse pure (validatePoint Nothing point)+  (vertex, disposition) <-+    case hierarchyHint hierarchy query of+      Just (VertexHint seed) -> insertVertexAtNearVertex seed point point+      _ -> insertVertexAt point point+  either refuse pure (updateHierarchyAfterInsertion hierarchy point vertex disposition)++-- | Arrival-order insertion with the hierarchy maintained alongside it.+--+-- One session spans the whole run. The hierarchy no longer asks for a+-- triangulation, so the per-point publication that existed only to hand it one+-- is gone: the mesh is thawed once and published once for the program, where+-- before it was once per point. The measured operation is unchanged — still an+-- insert per point with the hint maintained against it, which is spade's loop.+insertAllWithHierarchy+  :: V.Vector Point+  -> IO (DelaunayTriangulation Point, HierarchyHint)+insertAllWithHierarchy points = do+  let base = empty unitElementDefaults+  initial <- require (buildHierarchyHint defaultHierarchyBranchFactor base)+  (hierarchy, mesh, _) <-+    require (withSession base (V.length points) (V.foldM' hierarchyStep initial points))+  pure (mesh, hierarchy)++-- | The same step over a mesh that already holds every point, which is the+-- duplicate lane. Each insert locates a site that is already there and answers+-- 'AlreadyPresent', so the hierarchy comes back unexamined and the level walk+-- is never entered. What remains on the clock is the locate and the+-- disposition test, with no rebuild standing behind either.+reinsertAllWithHierarchy+  :: (DelaunayTriangulation Point, HierarchyHint)+  -> V.Vector Point+  -> IO (DelaunayTriangulation Point, HierarchyHint)+reinsertAllWithHierarchy (triangulation, hierarchy) points =+  case withSession triangulation (V.length points) (V.foldM' hierarchyStep hierarchy points) of+    Left refusal -> fail (show refusal)+    Right (updated, mesh, _) -> pure (mesh, updated)++-- | Remove a program of coordinates through the hierarchy: every locate+-- starts at the hierarchy's nearest sample, one base session publishes once,+-- and the hierarchy of the resulting value is published once.+--+-- No query observes an intermediate hierarchy in this lane. A triangulation+-- and its hierarchy denote their current values rather than the edit history,+-- so the lawful physical schedule is one base session followed by one+-- hierarchy publication — the shape of the strict side's+-- @HierarchyTriangulation@, whose removals also locate through the hierarchy.+removeAllWithHierarchy+  :: (DelaunayTriangulation Point, HierarchyHint)+  -> V.Vector Point+  -> IO (DelaunayTriangulation Point, HierarchyHint)+removeAllWithHierarchy (triangulation, hierarchy) points =+  case removeManyWithHierarchy hierarchy triangulation points of+    Left refusal -> fail (show refusal)+    Right (outcomes, surviving, repaired) -> do+      V.imapM_ checkRemoved outcomes+      pure (surviving, repaired)+ where+  checkRemoved index outcome = case outcome of+    Nothing ->+      error+        ( "removal target is not a vertex: index="+            <> show index+            <> " point="+            <> ( case points V.! index of+                  Point x y -> hex64 x <> "," <> hex64 y+               )+        )+    Just _ -> pure ()++-- | The hierarchy lanes' gate, in two parts. The base mesh alone would not see+-- a hierarchy whose nesting law has drifted, because a search started from a+-- bad hint still walks to the right answer; a hint naming a vertex that does+-- not exist, or one the search cannot walk out of, moves the answers. Both are+-- pinned.+hierarchyGateQueries :: Int+hierarchyGateQueries = 1000++writeHierarchyGate+  :: FilePath+  -> String+  -> (DelaunayTriangulation Point, HierarchyHint)+  -> IO ()+writeHierarchyGate directory label (triangulation, hierarchy) = do+  queries <- requireQueryPoints (randomPoints 0x3141592653589793 hierarchyGateQueries)+  writeFile+    (directory </> (label <> "-edges.txt"))+    (unlines (canonicalEdges triangulation))+  writeFile+    (directory </> (label <> "-nearest.txt"))+    ( unlines+        ( map+            (nearestAnswer triangulation hierarchy)+            queries+        )+    )++writeHierarchyIncrementalGate :: FilePath -> Int -> IO ()+writeHierarchyIncrementalGate directory pointCount = do+  built <- insertAllWithHierarchy (V.fromList (randomPoints 0x9e3779b97f4a7c15 pointCount))+  writeHierarchyGate directory ("hierarchy-incremental-" <> show pointCount) built++writeHierarchyDuplicateGate :: FilePath -> Int -> Int -> IO ()+writeHierarchyDuplicateGate directory pointCount duplicateCount = do+  base <- hierarchyOf pointCount+  built <-+    reinsertAllWithHierarchy+      base+      (V.fromList (randomPoints 0x9e3779b97f4a7c15 duplicateCount))+  writeHierarchyGate+    directory+    ("hierarchy-duplicate-" <> show pointCount <> "-" <> show duplicateCount)+    built++writeHierarchyRemovalGate :: FilePath -> Int -> Int -> IO ()+writeHierarchyRemovalGate directory pointCount removalCount = do+  base <- hierarchyOf pointCount+  built <-+    removeAllWithHierarchy+      base+      (V.fromList (take removalCount (randomPoints 0x9e3779b97f4a7c15 pointCount)))+  writeHierarchyGate+    directory+    ("hierarchy-removal-" <> show pointCount <> "-" <> show removalCount)+    built++-- | A bulk-loaded mesh and the hierarchy over it, which is where the duplicate+-- and removal lanes start. The strict side reaches the same pair through+-- @HierarchyTriangulation::bulk_load@.+hierarchyOf+  :: Int+  -> IO (DelaunayTriangulation Point, HierarchyHint)+hierarchyOf count = do+  triangulation <- delaunayOf count+  hierarchy <- require (buildHierarchyHint defaultHierarchyBranchFactor triangulation)+  pure (triangulation, hierarchy)
+ bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Input.hs view
@@ -0,0 +1,20 @@+-- | Cross-language benchmark input programs. Both Haskell interpreters import+-- this owner directly; neither keeps a private copy of the LCG stream.+module Moonlight.Triangulation.Bench.SpadeCompare.Input+  ( randomPoints+  ) where++import Data.Word (Word64)+import Moonlight.Triangulation.Types (Point (..))++-- | The Rust generator, bit for bit.+randomPoints :: Word64 -> Int -> [Point]+randomPoints seed count = take count (go seed)+ where+  go :: Word64 -> [Point]+  go state =+    let state1 = state * 6364136223846793005 + 1442695040888963407+        state2 = state1 * 6364136223846793005 + 1442695040888963407+        unit :: Word64 -> Double+        unit value = fromIntegral (value `div` 2048) / 9007199254740992+     in Point (2 * unit state1 - 1) (2 * unit state2 - 1) : go state2
+ bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Interpolation.hs view
@@ -0,0 +1,419 @@+{-# LANGUAGE DataKinds #-}++-- | Sibson interpolation lanes, gates, and diagnostics.+module Moonlight.Triangulation.Bench.SpadeCompare.Interpolation where++import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Monad.ST (stToIO)+import GHC.Exts (RealWorld)+import Data.Foldable (traverse_)+import Data.List (sort, sortOn)+import System.Exit (exitWith, ExitCode (ExitFailure))+import System.FilePath ((</>))+import System.IO (hPutStrLn, stderr)+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Interpolation+import Moonlight.Triangulation.Internal.Predicates qualified as Predicates+import Moonlight.Triangulation.Math (isFinite)+import Moonlight.Triangulation.PointLocation+import Moonlight.Triangulation.Types+import Moonlight.Triangulation.Bench.SpadeCompare.Support+import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints)++-- | The Sibson query reports its own cavity size, so the distribution of+-- (cavity faces, neighbours returned) says which step degenerates: a cavity of+-- one face means 'discoverCavity' never expanded, while a larger cavity paired+-- with three neighbours means the cell or the normalization was rejected.+reportInterpolationAudit :: Int -> Int -> IO ()+reportInterpolationAudit pointCount queryCount = do+  triangulation <-+    buildTriangulation+      <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x0123456789abcdef pointCount)))+  workspace <- stToIO (newNaturalNeighborWorkspace triangulation)+  queries <- requireQueryPoints (randomPoints 0x2718281828459045 queryCount)+  pairs <-+    traverse+      ( \query -> do+          (count, _, stats) <-+            stToIO (foldNaturalNeighborWeights (\total _ _ -> total + (1 :: Int)) 0 workspace Nothing query)+          pure ((interpolationCavityFaces stats, count), interpolationUsedFallback stats)+      )+      queries+  let tally =+        [ (representative, 1 + length rest)+        | representative : rest <- groupSorted (sort (map fst pairs))+        ]+      fallbacks = length (filter snd pairs)+  putStrLn ("queries " <> show (length pairs))+  putStrLn ("fallbacks " <> show fallbacks)+  traverse_+    (\((cavity, neighbors), n) -> putStrLn ("cavityFaces=" <> show cavity <> " neighbors=" <> show neighbors <> " count=" <> show n))+    tally+ where+  groupSorted [] = []+  groupSorted (x : xs) = let (same, rest) = span (== x) xs in (x : same) : groupSorted rest++-- | Isolates the cavity flood of the Sibson pipeline: per query, the BFS+-- over 'inCircle' and nothing else. The margin tally counts tests whose+-- determinant is inside the filtered predicate's error bound — the exact+-- dyadic path, which allocates Integer arithmetic per call.+reportInterpolationCavityAudit :: Int -> Int -> IO ()+reportInterpolationCavityAudit pointCount queryCount = do+  triangulation <-+    buildTriangulation+      <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x0123456789abcdef pointCount)))+  queries <- requireQueryPoints (V.fromList (randomPoints 0x2718281828459045 queryCount))+  (faces, tests, margins) <-+    V.foldM'+      ( \(faceAcc, testAcc, marginAcc) query ->+          case locatePoint triangulation query of+            InFace start -> do+              let (!cavitySize, !testCount, !marginCount) = flood triangulation (queryPointValue query) start+              pure (faceAcc + cavitySize, testAcc + testCount, marginAcc + marginCount)+            _ -> pure (faceAcc, testAcc, marginAcc)+      )+      (0 :: Int, 0 :: Int, 0 :: Int)+      queries+  putStrLn ("queries " <> show queryCount)+  putStrLn ("cavity-faces " <> show faces)+  putStrLn ("incircle-tests " <> show tests)+  putStrLn ("exact-path-margins " <> show margins)+ where+  flood triangulation query start = go [start] [] 0 0+   where+    go [] seen tests margins = (length seen, tests, margins)+    go (face : rest) seen tests margins+      | face `elem` seen = go rest seen tests margins+      | otherwise =+          case innerFaceVertices triangulation face of+            Nothing -> go rest seen tests margins+            Just (a, b, c) ->+              let !pa = vertexPoint triangulation a+                  !pb = vertexPoint triangulation b+                  !pc = vertexPoint triangulation c+                  !verdict = Predicates.inCircle pa pb pc query+                  !margins' = if insideMargin pa pb pc query then margins + 1 else margins+               in if verdict == GT+                    then go (adjacent triangulation face ++ rest) (face : seen) (tests + 1) margins'+                    else go rest seen (tests + 1) margins'++  adjacent triangulation face =+    case innerFaceDirectedEdges triangulation face of+      Nothing -> []+      Just (e0, e1, e2) ->+        [ opposite+        | edge <- [e0, e1, e2]+        , let opposite = incidentFace triangulation (reverseEdge edge)+        , opposite /= outerFace+        ]++  -- The branch condition of the filtered Double inCircle, recomputed over+  -- public coordinates: inside the error bound means the exact dyadic path.+  insideMargin (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy) =+    abs determinant <= 1.1102230246251577e-15 * permanent+   where+    !adx = ax - dx+    !ady = ay - dy+    !bdx = bx - dx+    !bdy = by - dy+    !cdx = cx - dx+    !cdy = cy - dy+    !abdet = adx * bdy - bdx * ady+    !bcdet = bdx * cdy - cdx * bdy+    !cadet = cdx * ady - adx * cdy+    !alift = adx * adx + ady * ady+    !blift = bdx * bdx + bdy * bdy+    !clift = cdx * cdx + cdy * cdy+    !determinant = alift * bcdet + blift * cadet + clift * abdet+    !permanent =+      (abs (bdx * cdy) + abs (cdx * bdy)) * alift+        + (abs (cdx * ady) + abs (adx * cdy)) * blift+        + (abs (adx * bdy) + abs (bdx * ady)) * clift++-- | Isolates the locate half of the interpolation lane: same triangulation,+-- same queries, but only 'locatePointWithHint' runs — no cavity, no Sibson.+-- With the allocation of this in hand against the full lane's, the owner of+-- the per-query cost is named by subtraction rather than by guesswork.+reportInterpolationLocateAudit :: Int -> Int -> IO ()+reportInterpolationLocateAudit pointCount queryCount = do+  triangulation <-+    buildTriangulation+      <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x0123456789abcdef pointCount)))+  queries <- requireQueryPoints (V.fromList (randomPoints 0x2718281828459045 queryCount))+  (steps, fallbacks) <-+    V.foldM'+      ( \(stepAcc, fallbackAcc) query -> do+          let (!location, !stats) = locatePointWithHint triangulation Nothing query+          _ <- evaluate (force (show location))+          pure (stepAcc + locationWalkSteps stats, fallbackAcc + (if locationUsedFallback stats then 1 else 0))+      )+      (0 :: Int, 0 :: Int)+      queries+  putStrLn ("queries " <> show queryCount)+  putStrLn ("walk-steps " <> show steps)+  putStrLn ("fallbacks " <> show fallbacks)++-- | The Sibson pipeline re-implemented over public API only, stage by stage,+-- mirroring the library's 'sibsonQuery': cavity flood, boundary collection,+-- loop ordering, insertion cell, stolen-area walks, normalization. The stage+-- sets are order-independent, so where the replica succeeds while the library+-- falls back the workspace layer is convicted, and where it fails the stage's+-- own algorithm is. With no index it tallies the first 1000 gate queries by+-- failing stage; with an index it dumps one query's full geometry.+reportInterpolationContext :: Int -> Maybe Int -> IO ()+reportInterpolationContext pointCount maybeIndex = do+  triangulation <-+    buildTriangulation+      <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x0123456789abcdef pointCount)))+  queries <- requireQueryPoints (V.fromList (randomPoints 0x2718281828459045 1000))+  case maybeIndex of+    Just index -> case queries V.!? index of+      Nothing -> do+        hPutStrLn stderr "interp-context: query index out of range"+        exitWith (ExitFailure 2)+      Just query -> do+        let (_, detail) = replicateQuery triangulation query+        putStrLn ("query " <> pointHex (queryPointValue query))+        traverse_ putStrLn detail+    Nothing -> do+      let reports = map (fst . replicateQuery triangulation) (V.toList queries)+          tally =+            [ (representative, 1 + length rest)+            | representative : rest <- groupByHead (sort reports)+            ]+      putStrLn ("queries " <> show (length reports))+      traverse_ (\(stage, count) -> putStrLn (stage <> " count=" <> show count)) tally+ where+  groupByHead [] = []+  groupByHead (x : xs) = let (same, rest) = span (== x) xs in (x : same) : groupByHead rest++  replicateQuery triangulation queryPoint =+    let query = queryPointValue queryPoint+     in case locatePoint triangulation queryPoint of+      OnVertex _ -> ("special-on-vertex", ["on-vertex"])+      OnEdge edge+        | isBoundaryEdge triangulation (asUndirected edge) -> ("special-boundary-edge", ["boundary-edge"])+        | otherwise ->+            let !left = incidentFace triangulation edge+                !right = incidentFace triangulation (reverseEdge edge)+                !start = if left /= outerFace then left else right+             in sibson triangulation query start+      InFace face -> sibson triangulation query face+      OutsideConvexHull _ -> ("special-outside-hull", ["outside-hull"])+      EmptyTriangulation -> ("special-empty", ["empty"])++  sibson triangulation query startFace =+    let cavity = flood [startFace] []+        boundary =+          [ edge+          | face <- cavity+          , Just (e0, e1, e2) <- [innerFaceDirectedEdges triangulation face]+          , edge <- [e0, e1, e2]+          , let opposite = incidentFace triangulation (reverseEdge edge)+          , opposite == outerFace || not (opposite `elem` cavity)+          ]+        header =+          [ "cavity " <> show (length cavity)+          , "boundary " <> show (length boundary)+          ]+     in case orderLoop boundary of+          Left reason -> ("fail-order", header ++ ["order-failure " <> reason])+          Right ordered+            | length ordered < 3 -> ("fail-order-small", header ++ ["ordered " <> show (length ordered)])+            | otherwise ->+                case insertionCell ordered of+                  Left reason -> ("fail-cell", header ++ ["ordered " <> show (length ordered), "cell-failure " <> reason])+                  Right cell ->+                    let walks = stolenAreas ordered cell+                     in case sequence walks of+                          Left reason -> ("fail-stolen", header ++ ["ordered " <> show (length ordered), "stolen-failure " <> reason])+                          Right areas ->+                            let !total = sum areas+                                !minimumWeight = minimum areas+                                !tolerance = max 1.0e-12 (128 * 2.220446049250313e-16)+                                !clampedTotal = sum (map (max 0) areas)+                                verdict+                                  | any (not . isFinite) areas || total == 0 || minimumWeight < negate tolerance =+                                      Left ("normalize total=" <> show total <> " min=" <> show minimumWeight)+                                  | clampedTotal <= 0 || not (isFinite clampedTotal) =+                                      Left ("clamped-total " <> show clampedTotal)+                                  | otherwise = Right ()+                             in case verdict of+                                  Left reason ->+                                    ( "fail-normalize"+                                    , header+                                        ++ ["ordered " <> show (length ordered)]+                                        ++ ["area " <> show area | area <- areas]+                                        ++ ["normalize-failure " <> reason]+                                    )+                                  Right () ->+                                    ( "sibson-success"+                                    , header+                                        ++ ["ordered " <> show (length ordered)]+                                        ++ zipWith areaLine ordered areas+                                        ++ ["total " <> show total <> " min " <> show minimumWeight]+                                    )+   where+    areaLine edge area =+      "  vertex "+        <> pointHex (vertexPoint triangulation (origin triangulation edge))+        <> " area "+        <> show area++    contains face =+      case innerFaceVertices triangulation face of+        Nothing -> False+        Just (a, b, c) ->+          Predicates.inCircle+            (vertexPoint triangulation a)+            (vertexPoint triangulation b)+            (vertexPoint triangulation c)+            query+            /= LT++    adjacent face =+      case innerFaceDirectedEdges triangulation face of+        Nothing -> []+        Just (e0, e1, e2) ->+          [ opposite+          | edge <- [e0, e1, e2]+          , let opposite = incidentFace triangulation (reverseEdge edge)+          , opposite /= outerFace+          ]++    flood [] seen = seen+    flood (face : rest) seen+      | face `elem` seen = flood rest seen+      | not (contains face) = flood rest seen+      | otherwise = flood (adjacent face ++ rest) (face : seen)++    orderLoop [] = Left "empty-boundary"+    orderLoop boundary@(first : _) = chain first first [] 0+     where+      !count = length boundary+      origins = [(origin triangulation edge, edge) | edge <- boundary]+      chain start current acc index+        | index >= count =+            if current == start then Right (reverse acc) else Left "no-closure"+        | otherwise =+            case lookup (destination triangulation current) origins of+              Nothing ->+                Left+                  ( "broken-chain "+                      <> pointHex (vertexPoint triangulation (destination triangulation current))+                  )+              Just nextEdge+                | nextEdge == start && index + 1 == count -> Right (reverse (current : acc))+                | nextEdge == start -> Left "premature-closure"+                | otherwise -> chain start nextEdge (current : acc) (index + 1)++    relative point = case point of Point x y -> Point (x - qx) (y - qy)+    (qx, qy) = case query of Point x y -> (x, y)++    insertionCell ordered = traverse cellCenter ordered+     where+      cellCenter edge =+        let !from = vertexPoint triangulation (origin triangulation edge)+            !to = vertexPoint triangulation (destination triangulation edge)+         in case circumcenter (relative to) (relative from) (Point 0 0) of+              Nothing ->+                Left+                  ( "edge "+                      <> pointHex from+                      <> " "+                      <> pointHex to+                  )+              Just center -> Right center++    stolenAreas ordered cell =+      let !count = length ordered+          pairs = zip ordered cell+          predecessors = drop (count - 1) pairs ++ take (count - 1) pairs+       in zipWith walk pairs predecessors+     where+      walk (stopEdge, first) (initialEdge, initialPoint) = go initialEdge initialPoint 0 initialPositive initialNegative+       where+        !target = reverseEdge stopEdge+        !limit = numDirectedEdges triangulation + 1+        !initialPositive = px first * py initialPoint+        !initialNegative = py first * px initialPoint+        !vertex = vertexPoint triangulation (origin triangulation stopEdge)+        go lastEdge lastPoint steps positive negative+          | steps >= limit = Left "step-limit"+          | incidentFace triangulation lastEdge == outerFace =+              Left ("outer-face vertex=" <> pointHex vertex <> " steps=" <> show steps)+          | otherwise =+              case innerFaceVertices triangulation (incidentFace triangulation lastEdge) of+                Nothing -> Left "no-face-vertices"+                Just (a, b, c) ->+                  case circumcenter+                    (relative (vertexPoint triangulation a))+                    (relative (vertexPoint triangulation b))+                    (relative (vertexPoint triangulation c)) of+                    Nothing ->+                      Left ("circumcenter vertex=" <> pointHex vertex <> " steps=" <> show steps)+                    Just current ->+                      let !positive' = positive + px lastPoint * py current+                          !negative' = negative + py lastPoint * px current+                          !nextEdge = reverseEdge (next triangulation lastEdge)+                       in if nextEdge == target+                            then Right ((negative' + py current * px first) - (positive' + px current * py first))+                            else go nextEdge current (steps + 1) positive' negative'+      px (Point x _) = x+      py (Point _ y) = y++-- | The interpolation gate, two artifacts per query. The neighbour set is+-- exact-predicate determined over triangulations that already agree+-- bit-for-bit, so it crosses implementations. The weights cannot: each+-- neighbour's stolen area uses the same operation sequence on both sides,+-- but the normalization total accumulates those areas in each side's own+-- neighbour order, and floating-point addition is not associative. The+-- weights are pinned per side in the driver instead.+writeInterpolationGate :: FilePath -> Int -> Int -> IO ()+writeInterpolationGate directory pointCount queryCount = do+  triangulation <- buildTriangulation <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x0123456789abcdef pointCount)))+  workspace <- stToIO (newNaturalNeighborWorkspace triangulation)+  queries <- requireQueryPoints (V.fromList (randomPoints 0x2718281828459045 queryCount))+  (neighborLines, weightLines) <-+    V.foldM'+      ( \(neighborAcc, weightAcc) query -> do+          (entries, _, _) <- stToIO (foldNaturalNeighborWeights (\acc vertex weight -> (vertex, weight) : acc) [] workspace Nothing query)+          let sortedEntries =+                sortOn+                  (\(x, y, _) -> (x, y))+                  [ case vertexPoint triangulation vertex of+                      Point x y -> (x, y, weight)+                  | (vertex, weight) <- entries+                  ]+              queryHex = case queryPointValue query of Point x y -> hex64 x <> hex64 y+          pure+            ( queryHex <> concatMap (\(x, y, _) -> hex64 x <> hex64 y) sortedEntries : neighborAcc+            , queryHex <> concatMap (\(x, y, weight) -> hex64 x <> hex64 y <> hex64 weight) sortedEntries : weightAcc+            )+      )+      ([], [])+      queries+  writeFile+    (directory </> ("interpolation-" <> show pointCount <> "-" <> show queryCount <> "-neighbors.txt"))+    (unlines (reverse neighborLines))+  writeFile+    (directory </> ("interpolation-" <> show pointCount <> "-" <> show queryCount <> "-weights.txt"))+    (unlines (reverse weightLines))++-- | The sum of one query's Sibson weights through the reusable workspace —+-- the allocation-free path, matching what the strict side's buffer reuse+-- does inside its measured region.+interpolationWeightSum+  :: NaturalNeighborWorkspace RealWorld 'Unconstrained Point () () ()+  -> V.Vector QueryPoint+  -> IO Double+interpolationWeightSum workspace =+  V.foldM'+    ( \total query -> do+        (weightSum, _, _) <- stToIO (foldNaturalNeighborWeights (\acc _ weight -> acc + weight) 0 workspace Nothing query)+        pure (total + weightSum)+    )+    0
+ bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Intersection.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DataKinds #-}++-- | Corridor-walk lanes, their inputs, and their gates.+module Moonlight.Triangulation.Bench.SpadeCompare.Intersection where++import Data.List (sortOn)+import Data.Word (Word64)+import System.FilePath ((</>))+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.IntersectionIterator+import Moonlight.Triangulation.Bench.SpadeCompare.Support+import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints)++-- | Query endpoints pulled inward. The generator fills [-1, 1]^2, so a point+-- with both coordinates inside [-0.5, 0.5] is strictly inside the hull of a+-- few thousand of them and locating it lands on a face. A chord that starts+-- OUTSIDE the hull makes endpoint choice and local hull entry observable, so+-- those chords remain the separate "intersection-outside" cliff lane.+interiorQueryPoints :: Word64 -> Int -> [Point]+interiorQueryPoints seed count =+  [Point (0.5 * x) (0.5 * y) | Point x y <- randomPoints seed count]++-- | Query origins pushed away from the dense centre so the corpus repeatedly+-- exercises outside-hull entry rather than only face-to-face corridors.+exteriorQueryPoints :: Word64 -> Int -> [Point]+exteriorQueryPoints seed count =+  [Point (4 * x) (4 * y) | Point x y <- randomPoints seed count]++intersectionChords :: Int -> [(Point, Point)]+intersectionChords queryCount =+  zip+    (interiorQueryPoints 0x3141592653589793 queryCount)+    (interiorQueryPoints 0x2718281828459045 queryCount)++outsideChords :: Int -> [(Point, Point)]+outsideChords queryCount =+  zip+    (exteriorQueryPoints 0x243f6a8885a308d3 queryCount)+    (interiorQueryPoints 0x2718281828459045 queryCount)++-- | One line per query: the line's own endpoints, then its intersection+-- sequence in the order the walk reports it. Every branch of the walk turns on+-- an orientation predicate over a mesh that already agrees bit for bit, so the+-- whole sequence is exactly determined and crosses implementations — order+-- included, which is why nothing here is sorted.+writeIntersectionGate :: FilePath -> Int -> Int -> IO ()+writeIntersectionGate directory pointCount queryCount = do+  triangulation <- delaunayOf pointCount+  chords <- requireQueryChords (intersectionChords queryCount)+  writeFile+    (directory </> ("intersection-" <> show pointCount <> "-" <> show queryCount <> "-chords.txt"))+    (unlines (map (intersectionLine triangulation) chords))++writeIntersectionOutsideGate :: FilePath -> Int -> Int -> IO ()+writeIntersectionOutsideGate directory pointCount queryCount = do+  triangulation <- delaunayOf pointCount+  chords <- requireQueryChords (outsideChords queryCount)+  writeFile+    ( directory+        </> ("intersection-outside-" <> show pointCount <> "-" <> show queryCount <> ".txt")+    )+    (unlines (map (intersectionLine triangulation) chords))++-- | Lines whose endpoints are mesh vertices, which is the only way to reach the+-- vertex and overlap branches of the walk at all: over generated doubles no+-- chord lands exactly on a site, so a gate built from chords alone exercises+-- one branch of three. The first family joins vertices the constraint+-- generator's index pairs select, which starts and ends the walk on a vertex;+-- the second runs along an existing edge, which is the only shape that produces+-- an overlap. Both name their endpoints by coordinate, the second from a list+-- both sides sort by the same encoding, because vertex handles do not cross.+writeIntersectionVertexGate :: FilePath -> Int -> IO ()+writeIntersectionVertexGate directory pointCount = do+  triangulation <- delaunayOf pointCount+  let sites = V.fromList (randomPoints 0x9e3779b97f4a7c15 pointCount)+      joins =+        [ (sites V.! fromIndex, sites V.! toIndex)+        | (fromIndex, toIndex) <- constraintPairs pointCount intersectionVertexLines+        ]+      alongEdges = take intersectionVertexLines (sortedEdgeEndpoints triangulation)+  queryLines <- requireQueryChords (joins <> alongEdges)+  writeFile+    (directory </> ("intersection-vertexlines-" <> show pointCount <> ".txt"))+    (unlines (map (intersectionLine triangulation) queryLines))++intersectionVertexLines :: Int+intersectionVertexLines = 100++sortedEdgeEndpoints+  :: DelaunayTriangulation Point+  -> [(Point, Point)]+sortedEdgeEndpoints triangulation =+  map snd+    ( sortOn+        fst+        [ (coordHex first <> coordHex second, (first, second))+        | edge <- undirectedEdges triangulation+        , let (from, to) = undirectedEndpoints triangulation edge+              p = vertexPoint triangulation from+              q = vertexPoint triangulation to+              (first, second) = if pointKey p <= pointKey q then (p, q) else (q, p)+        ]+    )+ where+  pointKey (Point x y) = (x, y)++intersectionLine+  :: DelaunayTriangulation Point+  -> (QueryPoint, QueryPoint)+  -> String+intersectionLine triangulation (from, to) =+  coordHex (queryPointValue from)+    <> coordHex (queryPointValue to)+    <> concatMap (encodeIntersection triangulation) (lineIntersections triangulation from to)++encodeIntersection+  :: DelaunayTriangulation Point+  -> Intersection+  -> String+encodeIntersection triangulation event = case event of+  VertexIntersection vertex -> "V" <> coordHex (vertexPoint triangulation vertex)+  EdgeIntersection edge -> "E" <> directedHex edge+  EdgeOverlap edge -> "O" <> directedHex edge+ where+  directedHex edge =+    coordHex (vertexPoint triangulation (origin triangulation edge))+      <> coordHex (vertexPoint triangulation (destination triangulation edge))++-- | The corridor walk, counted. 'lineIntersections' materializes its answer, so+-- forcing the spine forces every step that produced it; spade's iterator is+-- lazy and is consumed by the same count.+intersectionWalk+  :: DelaunayTriangulation Point+  -> [(QueryPoint, QueryPoint)]+  -> Int+intersectionWalk triangulation =+  foldl' (\total (from, to) -> total + length (lineIntersections triangulation from to)) 0
+ bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Lane.hs view
@@ -0,0 +1,302 @@+-- | The closed comparison vocabulary and its boundary projections.+--+-- The driver executes these requests, the report orders and names them, and+-- the Haskell runner interprets their command constructors. None of those+-- boundaries authors another lane universe.+module Moonlight.Triangulation.Bench.SpadeCompare.Lane+  ( LaneClass (..)+  , LaneKind (..)+  , LaneRequest (..)+  , LaneObstruction (..)+  , laneKindName+  , laneRequestLabel+  , parseLaneRequest+  , renderInventoryCsv+  , renderInventoryHuman+  , renderLaneSpecs+  , renderLaneObstruction+  , renderSnapshotSpecs+  ) where++import Data.List (find, intercalate)+import Text.Read (readMaybe)++data LaneClass+  = ParityLane+  | CliffLane+  deriving stock (Eq, Show)++-- | Every benchmark command understood by the Moonlight runner. The board is+-- a closed subset of this vocabulary; the remaining constructors are focused+-- diagnostics rather than Spade comparison rows.+data LaneKind+  = BulkLoadLane+  | IncrementalLane+  | SnapshotInsertLane+  | SweepAngleCollapseLane+  | DegenerateLineLane+  | BatchSweepLane+  | NearestLane+  | CdtRecoveryLane+  | ConstraintIncrementalLane+  | ConstraintSplitLane+  | PublicationFloorLane+  | RemovalLane+  | SnapshotRemovalLane+  | HierarchyIncrementalLane+  | HierarchyDuplicateLane+  | HierarchyRemovalLane+  | HierarchyRemovalOnlyLane+  | HierarchyRebuildOnlyLane+  | InterpolationLane+  | VoronoiSweepLane+  | DcelWalkLane+  | AlphaPersistenceLane+  | IntersectionLane+  | IntersectionOutsideLane+  | RefineLane+  deriving stock (Bounded, Enum, Eq, Show)++data LaneRequest = LaneRequest+  { laneRequestKind :: !LaneKind+  , laneRequestFirst :: !Int+  , laneRequestSecond :: !Int+  }+  deriving stock (Eq, Show)++data LaneObstruction+  = UnknownLane !String+  | UnknownLaneClass !String+  | MalformedWorkSize !String+  | NegativeWorkSize !Int+  | AlphaPersistenceRequiresSpecializedRunner+  deriving stock (Eq, Show)++data LaneSpec = LaneSpec+  { laneSpecClass :: !LaneClass+  , laneSpecRequest :: !LaneRequest+  , laneSpecDisplay :: !String+  }++data SnapshotStressSpec = SnapshotStressSpec+  { snapshotSessionRequest :: !LaneRequest+  , snapshotPublicationRequest :: !LaneRequest+  , snapshotDisplay :: !String+  }++laneKindName :: LaneKind -> String+laneKindName = \case+  BulkLoadLane -> "bulk-load"+  IncrementalLane -> "incremental"+  SnapshotInsertLane -> "snapshot-insert"+  SweepAngleCollapseLane -> "sweep-angle-collapse"+  DegenerateLineLane -> "degenerate-line"+  BatchSweepLane -> "batch-sweep"+  NearestLane -> "nearest"+  CdtRecoveryLane -> "cdt-recovery"+  ConstraintIncrementalLane -> "constraint-incremental"+  ConstraintSplitLane -> "constraint-split"+  PublicationFloorLane -> "publication-floor"+  RemovalLane -> "removal"+  SnapshotRemovalLane -> "snapshot-removal"+  HierarchyIncrementalLane -> "hierarchy-incremental"+  HierarchyDuplicateLane -> "hierarchy-duplicate"+  HierarchyRemovalLane -> "hierarchy-removal"+  HierarchyRemovalOnlyLane -> "hierarchy-removal-only"+  HierarchyRebuildOnlyLane -> "hierarchy-rebuild-only"+  InterpolationLane -> "interpolation"+  VoronoiSweepLane -> "voronoi-sweep"+  DcelWalkLane -> "dcel-walk"+  AlphaPersistenceLane -> "alpha-persistence"+  IntersectionLane -> "intersection"+  IntersectionOutsideLane -> "intersection-outside"+  RefineLane -> "refine"++laneRequestLabel :: LaneRequest -> String+laneRequestLabel request =+  intercalate+    "-"+    [ laneKindName (laneRequestKind request)+    , show (laneRequestFirst request)+    , show (laneRequestSecond request)+    ]++parseLaneRequest :: String -> String -> String -> Either LaneObstruction LaneRequest+parseLaneRequest rawKind rawFirst rawSecond =+  LaneRequest+    <$> parseLaneKind rawKind+    <*> parseWorkSize rawFirst+    <*> parseWorkSize rawSecond++renderLaneObstruction :: LaneObstruction -> String+renderLaneObstruction = \case+  UnknownLane lane -> "unknown benchmark lane: " <> lane+  UnknownLaneClass laneClass -> "unknown benchmark lane class: " <> laneClass+  MalformedWorkSize raw -> "benchmark work size is not an integer: " <> raw+  NegativeWorkSize size -> "benchmark work size is negative: " <> show size+  AlphaPersistenceRequiresSpecializedRunner ->+    "alpha-persistence is owned by moonlight-triangulation-alpha-spade-referent"++renderInventoryCsv :: String+renderInventoryCsv =+  unlines+    ( fmap renderBoardLane boardLaneSpecs+        <> fmap renderSnapshotLane snapshotStressSpecs+    )+ where+  renderBoardLane specification =+    csvRow+      [ "lane"+      , laneClassName (laneSpecClass specification)+      , laneRequestLabel (laneSpecRequest specification)+      , laneSpecDisplay specification+      ]++  renderSnapshotLane specification =+    csvRow+      [ "lane"+      , "snapshot"+      , laneRequestLabel (snapshotPublicationRequest specification)+      , snapshotDisplay specification+      , laneRequestLabel (snapshotSessionRequest specification)+      ]++renderInventoryHuman :: String+renderInventoryHuman =+  concatMap renderClass [ParityLane, CliffLane]+    <> "snapshot lanes ("+    <> show (length snapshotStressSpecs)+    <> ")\n"+    <> concatMap renderSnapshot snapshotStressSpecs+ where+  renderClass laneClass =+    let specifications = laneSpecs laneClass+     in laneClassName laneClass+          <> " lanes ("+          <> show (length specifications)+          <> ")\n"+          <> concatMap+            ((<> "\n") . ("  " <>) . laneRequestLabel . laneSpecRequest)+            specifications++  renderSnapshot specification =+    "  "+      <> laneRequestLabel (snapshotPublicationRequest specification)+      <> " against "+      <> laneRequestLabel (snapshotSessionRequest specification)+      <> "\n"++renderLaneSpecs :: String -> Either LaneObstruction String+renderLaneSpecs rawClass =+  unlines . fmap (renderRequestWords . laneSpecRequest) . laneSpecs+    <$> parseLaneClass rawClass++renderSnapshotSpecs :: String+renderSnapshotSpecs =+  unlines+    ( fmap+        ( \specification ->+            renderRequestWords (snapshotSessionRequest specification)+              <> " "+              <> renderRequestWords (snapshotPublicationRequest specification)+        )+        snapshotStressSpecs+    )++parseLaneKind :: String -> Either LaneObstruction LaneKind+parseLaneKind raw =+  maybe+    (Left (UnknownLane raw))+    Right+    (find ((== raw) . laneKindName) [minBound .. maxBound])++parseLaneClass :: String -> Either LaneObstruction LaneClass+parseLaneClass = \case+  "parity" -> Right ParityLane+  "cliff" -> Right CliffLane+  other -> Left (UnknownLaneClass other)++parseWorkSize :: String -> Either LaneObstruction Int+parseWorkSize raw =+  maybe+    (Left (MalformedWorkSize raw))+    (\size -> if size < 0 then Left (NegativeWorkSize size) else Right size)+    (readMaybe raw)++laneClassName :: LaneClass -> String+laneClassName = \case+  ParityLane -> "parity"+  CliffLane -> "cliff"++laneSpecs :: LaneClass -> [LaneSpec]+laneSpecs laneClass = filter ((== laneClass) . laneSpecClass) boardLaneSpecs++renderRequestWords :: LaneRequest -> String+renderRequestWords request =+  unwords+    [ laneKindName (laneRequestKind request)+    , show (laneRequestFirst request)+    , show (laneRequestSecond request)+    ]++csvRow :: [String] -> String+csvRow = intercalate "," . fmap csvField++csvField :: String -> String+csvField field+  | any (`elem` [',', '"', '\n', '\r']) field =+      '"' : concatMap escapeQuote field <> "\""+  | otherwise = field+ where+  escapeQuote '"' = "\"\""+  escapeQuote character = [character]++boardLaneSpecs :: [LaneSpec]+boardLaneSpecs =+  [ parity BulkLoadLane 1000 0 "Bulk load, 1k points"+  , parity BulkLoadLane 10000 0 "Bulk load, 10k"+  , parity IncrementalLane 1000 0 "Incremental insert, 1k"+  , parity IncrementalLane 10000 0 "Incremental insert, 10k"+  , parity IncrementalLane 500000 0 "Incremental insert, 500k"+  , parity NearestLane 20000 5000 "Nearest, 5k queries / 20k points"+  , parity CdtRecoveryLane 8000 800 "CDT recovery, 800 / 8k"+  , parity RefineLane 625 0 "Refinement, 625 Steiner"+  , parity RefineLane 2500 0 "Refinement, 2,500 Steiner"+  , parity RemovalLane 1000 250 "Removal, 250 / 1k"+  , parity RemovalLane 10000 2500 "Removal, 2.5k / 10k"+  , parity RemovalLane 100000 25000 "Removal, 25k / 100k"+  , parity InterpolationLane 10000 1000 "Interpolation, 1k queries / 10k"+  , parity InterpolationLane 100000 2000 "Interpolation, 2k queries / 100k"+  , parity VoronoiSweepLane 1000 0 "Voronoi dual sweep, 1k sites"+  , parity DcelWalkLane 2000 0 "DCEL traversal, 2k points"+  , parity IntersectionLane 10000 500 "Line intersection, 500 chords / 10k"+  , parity DegenerateLineLane 2000 0 "Exactly collinear bulk chain, 2k"+  , cliff ConstraintIncrementalLane 8000 800 "Constraint one at a time, 800 / 8k"+  , cliff ConstraintSplitLane 1000 0 "Constraint split, 1k crossings"+  -- This deliberately stays at 1k while its parity twin also reaches 10k.+  , cliff HierarchyIncrementalLane 1000 0 "Hierarchy insert, 1k"+  , cliff HierarchyDuplicateLane 10000 500 "Hierarchy duplicate insert, 500 / 10k"+  , cliff HierarchyRemovalLane 10000 250 "Hierarchy removal, 250 / 10k"+  , cliff SweepAngleCollapseLane 2000 0 "Sweep hull index at one angle, 2k"+  , cliff IntersectionOutsideLane 2000 100 "Line intersection from outside the hull, 100 / 2k"+  ]+ where+  parity :: LaneKind -> Int -> Int -> String -> LaneSpec+  parity kind first second display =+    LaneSpec ParityLane (LaneRequest kind first second) display++  cliff :: LaneKind -> Int -> Int -> String -> LaneSpec+  cliff kind first second display =+    LaneSpec CliffLane (LaneRequest kind first second) display++snapshotStressSpecs :: [SnapshotStressSpec]+snapshotStressSpecs =+  [ SnapshotStressSpec+      (LaneRequest IncrementalLane 1000 0)+      (LaneRequest SnapshotInsertLane 1000 0)+      "Insert snapshots, 1k points"+  , SnapshotStressSpec+      (LaneRequest RemovalLane 10000 2500)+      (LaneRequest SnapshotRemovalLane 10000 2500)+      "Removal snapshots, 2.5k / 10k"+  ]
+ bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Removal.hs view
@@ -0,0 +1,428 @@+{-# LANGUAGE DataKinds #-}++-- | Removal lanes, their gates, and the removal diagnostics.+module Moonlight.Triangulation.Bench.SpadeCompare.Removal where++import Control.Monad (when)+import Data.Foldable (traverse_)+import Data.List (sortOn)+import System.Exit (exitWith, ExitCode (ExitFailure))+import System.FilePath ((</>))+import System.IO (hPutStrLn, stderr)+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Internal.Predicates qualified as Predicates+import Moonlight.Triangulation.PointLocation+import Moonlight.Triangulation.Removal+import Moonlight.Triangulation.Session+import Moonlight.Triangulation.Types+import Moonlight.Triangulation.Bench.SpadeCompare.Support+import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints)++-- | The removal gate: a deterministic prefix of the input, removed by+-- coordinate, and the surviving canonical edge set. Delaunay triangulations+-- of point sets in general position are unique, so the survivor is forced+-- and both implementations must agree bit-for-bit.+writeRemovalGate :: FilePath -> Int -> Int -> IO ()+writeRemovalGate directory pointCount removalCount = do+  let points = randomPoints 0x9e3779b97f4a7c15 pointCount+  triangulation <- buildTriangulation <$> require (delaunay unitElementDefaults (V.fromList points))+  surviving <- removeAllByCoordinate triangulation (V.fromList (take removalCount points))+  writeFile+    (directory </> ("removal-" <> show pointCount <> "-" <> show removalCount <> "-edges.txt"))+    (unlines (canonicalEdges surviving))++-- | Remove vertices by coordinate inside one session: one O(n) dense thaw and+-- publication for the whole program, then O(degree) topology work per removal.+-- The snapshot 'locateAndRemove' fold pays that O(n) boundary per removal.+removeAllByCoordinate+  :: DelaunayTriangulation Point+  -> V.Vector Point+  -> IO (DelaunayTriangulation Point)+removeAllByCoordinate triangulation removals =+  case withSession triangulation 0 (removeManyAt removals) of+    Left refusal -> fail (show refusal)+    Right (outcomes, surviving, _) -> do+      V.imapM_ checkRemoved outcomes+      pure surviving+ where+  checkRemoved index outcome = case outcome of+    Nothing ->+      error+        ( "removal target is not a vertex: index="+            <> show index+            <> " point="+            <> ( case removals V.! index of+                  Point x y -> hex64 x <> "," <> hex64 y+               )+        )+    Just _ -> pure ()++-- | Removal by coordinate through the persistent entry point: a thaw and a+-- publication per removal, against the session fold's one of each for the whole+-- program. Same removals, same order, same survivor — only the price differs.+removeAllPersistently+  :: DelaunayTriangulation Point+  -> V.Vector Point+  -> IO (DelaunayTriangulation Point)+removeAllPersistently =+  V.foldM'+    (\current point -> do+      outcome <- require (locateAndRemove current point)+      case outcome of+        Nothing -> fail ("removal target is not a vertex: " <> pointHex point)+        Just result -> pure (removalTriangulation result)+    )++writePersistentRemovalGate :: FilePath -> Int -> Int -> IO ()+writePersistentRemovalGate directory pointCount removalCount = do+  let points = randomPoints 0x9e3779b97f4a7c15 pointCount+  base <- buildTriangulation <$> require (delaunay unitElementDefaults (V.fromList points))+  surviving <- removeAllPersistently base (V.fromList (take removalCount points))+  writeFile+    ( directory+        </> ("persistent-removal-" <> show pointCount <> "-" <> show removalCount <> "-edges.txt")+    )+    (unlines (canonicalEdges surviving))++-- | Removal audited against the one oracle that needs no second implementation:+-- the Delaunay triangulation of a point set in general position is unique, so+-- removing a prefix must leave exactly the triangulation a fresh bulk load of+-- the survivors produces. Reports the first removal at which that identity+-- breaks, so a divergence is dated rather than merely observed.+--+-- Every removal also reports the handle swap-compaction relocated into the+-- freed slot, and that handle is the caller's only re-anchor after a removal+-- invalidates the rest. An out-of-range or misnamed handle is invisible to the+-- edge-set oracle, so it is checked here against the vertex the mesh moved.+reportRemovalAudit :: Int -> Int -> IO ()+reportRemovalAudit pointCount removalCount = do+  let allPoints = V.fromList (randomPoints 0x9e3779b97f4a7c15 pointCount)+  base <- buildTriangulation <$> require (delaunay unitElementDefaults allPoints)+  let step current index+        | index >= removalCount = putStrLn ("clean-through " <> show removalCount)+        | otherwise =+            case allPoints V.!? index of+              Nothing -> putStrLn ("input-exhausted-at-removal " <> show index)+              Just point -> do+                outcome <- require (locateAndRemove current point)+                case outcome of+                  Nothing -> putStrLn ("located-nothing-at-removal " <> show index)+                  Just result -> do+                    let nextTriangulation = removalTriangulation result+                        movedPoint =+                          vertexPoint current (VertexId (fromIntegral (numVertices current - 1)))+                    case removalOutcomeSwap (removalOutcome result) of+                      Nothing+                        | vertexPoint current (VertexId (fromIntegral (numVertices current - 1))) /= point ->+                            putStrLn ("swap-handle-missing-at-removal " <> show index)+                        | otherwise -> pure ()+                      Just (swappedIn@(VertexId rawSwappedIn), _)+                        | toInteger rawSwappedIn >= toInteger (numVertices nextTriangulation) ->+                            putStrLn+                              ( "swap-handle-out-of-range-at-removal "+                                  <> show index+                                  <> " handle="+                                  <> show rawSwappedIn+                                  <> " vertices="+                                  <> show (numVertices nextTriangulation)+                              )+                        | vertexPoint nextTriangulation swappedIn /= movedPoint ->+                            putStrLn+                              ( "swap-handle-misnamed-at-removal "+                                  <> show index+                                  <> " handle="+                                  <> show rawSwappedIn+                              )+                        | otherwise -> pure ()+                    fresh <-+                      buildTriangulation+                        <$> require (delaunay unitElementDefaults (V.drop (index + 1) allPoints))+                    let removalEdges = canonicalEdges nextTriangulation+                        freshEdges = canonicalEdges fresh+                    if removalEdges == freshEdges+                      then step nextTriangulation (index + 1)+                      else do+                        let (onlyRemoval, onlyFresh) = sortedDifference removalEdges freshEdges+                        putStrLn ("diverged-at-removal " <> show index)+                        putStrLn+                          ( "removed-point "+                              <> case point of+                                Point x y -> hex64 x <> "," <> hex64 y+                          )+                        putStrLn ("removal-vertices " <> show (numVertices nextTriangulation))+                        putStrLn ("fresh-vertices " <> show (numVertices fresh))+                        putStrLn ("removal-edges " <> show (length removalEdges))+                        putStrLn ("fresh-edges " <> show (length freshEdges))+                        putStrLn ("only-in-removal " <> show (length onlyRemoval))+                        putStrLn ("only-in-fresh " <> show (length onlyFresh))+                        let (invertedRemoval, illegalRemoval) = meshHealth nextTriangulation+                            (invertedFresh, illegalFresh) = meshHealth fresh+                        putStrLn ("removal-inverted-faces " <> show invertedRemoval)+                        putStrLn ("removal-illegal-half-edges " <> show illegalRemoval)+                        putStrLn ("fresh-inverted-faces " <> show invertedFresh)+                        putStrLn ("fresh-illegal-half-edges " <> show illegalFresh)+                        traverse_ (putStrLn . ("  removal-only " <>)) (take 8 onlyRemoval)+                        traverse_ (putStrLn . ("  fresh-only " <>)) (take 8 onlyFresh)+  step base 0++-- | The geometry around one removal, reconstructed with public API only. For+-- an interior removal the cavity border is the cyclic link of the removed+-- vertex, and nothing but a drain flip can destroy one of those non-star+-- edges: cleanup removes only the star, and swap-remove touches only the+-- removed vertex. The reported hull predicate guards that interpretation.+-- The fan origin 'remeshRing' would pick is also public: 'collectOutgoing'+-- starts at the stored out-edge, so the origin is the destination of that+-- edge.+reportRemovalContext :: Int -> Int -> IO ()+reportRemovalContext pointCount target = do+  let allPoints = V.fromList (randomPoints 0x9e3779b97f4a7c15 pointCount)+  case allPoints V.!? target of+    Nothing -> do+      hPutStrLn stderr "removal-context: target index out of range"+      exitWith (ExitFailure 2)+    Just removedPoint -> do+      base <- buildTriangulation <$> require (delaunay unitElementDefaults allPoints)+      before <- removeAllByCoordinate base (V.take target allPoints)+      after <- removeAllByCoordinate before (V.singleton removedPoint)+      fresh <- buildTriangulation <$> require (delaunay unitElementDefaults (V.drop (target + 1) allPoints))+      lab <- buildTriangulation <$> require (delaunay unitElementDefaults (V.drop target allPoints))+      removedQuery <- require (mkQueryPoint removedPoint)+      putStrLn ("lab-clean " <> show (canonicalEdges before == canonicalEdges lab))+      case locatePoint before removedQuery of+        OnVertex removedVertex -> do+          let ring = ringOf before removedVertex+              ringPoints = map snd ring+              ringMember point = any (== point) ringPoints+              rOnHull = any (\(edge, _) -> incidentFace before edge == outerFace) ring+              afterPairs = canonicalEdgePairs after+              freshPairs = canonicalEdgePairs fresh+              borderPairs = cyclicPairs ringPoints+              destroyedBorder = [pair | pair <- borderPairs, not (any (== pair) afterPairs)]+              removalOnly = [pair | pair <- afterPairs, not (any (== pair) freshPairs)]+              freshOnly = [pair | pair <- freshPairs, not (any (== pair) afterPairs)]+          putStrLn ("r-on-hull " <> show rOnHull)+          putStrLn ("ring-size " <> show (length ringPoints))+          traverse_+            (\(index, (_, point)) -> putStrLn ("  ring " <> show index <> " " <> pointHex point))+            (zip [(0 :: Int) ..] ring)+          putStrLn ("border-edges-before " <> show (length borderPairs))+          putStrLn ("border-edges-destroyed " <> show (length destroyedBorder))+          traverse_+            (\(p, q) -> putStrLn ("  destroyed " <> pointHex p <> " " <> pointHex q))+            destroyedBorder+          case ringPoints of+            [] -> putStrLn "fan-unavailable empty-ring"+            fanOriginPoint : ringTail ->+              if rOnHull+                then putStrLn "fan-unavailable hull-removal"+                else do+                  let fanOrientations =+                        zipWith3+                          (\index p q -> (index, p, q, Predicates.orient2d fanOriginPoint p q))+                          [(1 :: Int) ..]+                          ringTail+                          (drop 1 ringTail)+                      fanCandidates =+                        zipWith3+                          ( \(index, priorPoint) current following ->+                              ( index+                              , current+                              , Predicates.orient2d priorPoint following fanOriginPoint == GT+                                  && Predicates.orient2d following priorPoint current == GT+                              , Predicates.inCircle current fanOriginPoint priorPoint following+                              )+                          )+                          (zip [(2 :: Int) ..] ringTail)+                          (drop 1 ringTail)+                          (drop 2 ringTail)+                  putStrLn ("fan-origin " <> pointHex fanOriginPoint)+                  putStrLn+                    ( "fan-inverted "+                        <> show (length [() | (_, _, _, verdict) <- fanOrientations, verdict == LT])+                        <> " of "+                        <> show (length fanOrientations)+                    )+                  traverse_+                    ( \(index, p, q, verdict) ->+                        when (verdict == LT) $+                          putStrLn+                            ( "  fan-inverted-at "+                                <> show index+                                <> " "+                                <> pointHex fanOriginPoint+                                <> " "+                                <> pointHex p+                                <> " "+                                <> pointHex q+                            )+                    )+                    fanOrientations+                  traverse_+                    ( \(index, current, convex, circle) ->+                        putStrLn+                          ( "  fan-candidate "+                              <> show index+                              <> " "+                              <> pointHex current+                              <> "->"+                              <> pointHex fanOriginPoint+                              <> " convex="+                              <> show convex+                              <> " incircle="+                              <> show circle+                          )+                    )+                    fanCandidates+          putStrLn ("only-in-removal " <> show (length removalOnly))+          traverse_+            ( \(p, q) ->+                putStrLn+                  ( "  removal-only "+                      <> pointHex p+                      <> " "+                      <> pointHex q+                      <> " ring="+                      <> show (ringMember p, ringMember q)+                  )+            )+            removalOnly+          putStrLn ("only-in-fresh " <> show (length freshOnly))+          traverse_+            ( \(p, q) ->+                putStrLn+                  ( "  fresh-only "+                      <> pointHex p+                      <> " "+                      <> pointHex q+                      <> " ring="+                      <> show (ringMember p, ringMember q)+                  )+            )+            freshOnly+          let inverted = invertedFaces after+          putStrLn ("inverted-faces " <> show (length inverted))+          traverse_+            ( \(p, q, r) ->+                putStrLn+                  ( "  inverted-face "+                      <> pointHex p+                      <> " "+                      <> pointHex q+                      <> " "+                      <> pointHex r+                      <> " ring="+                      <> show (ringMember p, ringMember q, ringMember r)+                  )+            )+            inverted+        other -> putStrLn ("locate-unexpected " <> show other)+ where+  ringOf triangulation vertex =+    case vertexOutEdge triangulation vertex of+      Nothing -> []+      Just start -> walk start start []+   where+    walk start current acc =+      let ringVertex = destination triangulation current+          nextEdge = counterClockwise triangulation current+          acc' = (current, vertexPoint triangulation ringVertex) : acc+       in if nextEdge == start+            then reverse acc'+            else walk start nextEdge acc'++  cyclicPairs (first : second : rest) =+    zipWith canonicalPair (first : second : rest) ((second : rest) ++ [first])+  cyclicPairs _ = []++  canonicalEdgePairs triangulation =+    sortOn+      (\(p, q) -> (pointKey p, pointKey q))+      [ canonicalPair p q+      | edge <- undirectedEdges triangulation+      , let (from, to) = undirectedEndpoints triangulation edge+            p = vertexPoint triangulation from+            q = vertexPoint triangulation to+      ]++  canonicalPair p q =+    if pointKey p <= pointKey q then (p, q) else (q, p)++  pointKey (Point x y) = (x, y)++  invertedFaces triangulation =+    [ (vertexPoint triangulation a, vertexPoint triangulation b, vertexPoint triangulation c)+    | face <- innerFaces triangulation+    , Just (a, b, c) <- [innerFaceVertices triangulation face]+    , Predicates.orient2d+        (vertexPoint triangulation a)+        (vertexPoint triangulation b)+        (vertexPoint triangulation c)+        == LT+    ]++-- | Two independent health measures, which together decide what a divergence+-- means. Delaunay's theorem says a /valid/ triangulation with no locally+-- illegal edge is globally Delaunay — so a mesh that differs from the fresh+-- build while carrying no illegal edge cannot be a valid triangulation, and+-- one carrying illegal edges was simply left under-legalized.+meshHealth+  :: Triangulation mode vertex directed undirected face+  -> (Int, Int)+meshHealth triangulation =+  ( length [() | face <- innerFaces triangulation, not (isCounterClockwise face)]+  , length+      [ ()+      | face <- innerFaces triangulation+      , edge <- faceEdgeList face+      , edgeIsIllegal edge+      ]+  )+ where+  faceEdgeList face = case innerFaceDirectedEdges triangulation face of+    Nothing -> []+    Just (e0, e1, e2) -> [e0, e1, e2]++  isCounterClockwise face = case innerFaceVertices triangulation face of+    Nothing -> True+    Just (a, b, c) ->+      Predicates.orient2d+        (vertexPoint triangulation a)+        (vertexPoint triangulation b)+        (vertexPoint triangulation c)+        == GT++  edgeIsIllegal edge =+    let twin = reverseEdge edge+     in incidentFace triangulation twin /= outerFace+          && Predicates.inCircle+            (vertexPoint triangulation (origin triangulation edge))+            (vertexPoint triangulation (destination triangulation edge))+            (vertexPoint triangulation (destination triangulation (next triangulation edge)))+            (vertexPoint triangulation (destination triangulation (next triangulation twin)))+            == GT++-- | The Delaunay triangulation of the survivors, built from scratch. Diffed+-- against a removal result it decides whether that result is the Delaunay+-- triangulation it is required to be.+writeFreshSuffix :: Int -> Int -> FilePath -> IO ()+writeFreshSuffix pointCount dropped path = do+  triangulation <-+    buildTriangulation+      <$> require+        ( delaunay+            unitElementDefaults+            (V.drop dropped (V.fromList (randomPoints 0x9e3779b97f4a7c15 pointCount)))+        )+  writeFile path (unlines (canonicalEdges triangulation))++-- | Symmetric difference of two ascending lists, by merge.+sortedDifference :: Ord a => [a] -> [a] -> ([a], [a])+sortedDifference [] right = ([], right)+sortedDifference left [] = (left, [])+sortedDifference left@(l : ls) right@(r : rs)+  | l == r = sortedDifference ls rs+  | l < r = let (onlyLeft, onlyRight) = sortedDifference ls right in (l : onlyLeft, onlyRight)+  | otherwise = let (onlyLeft, onlyRight) = sortedDifference left rs in (onlyLeft, r : onlyRight)
+ bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Support.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE DataKinds #-}++-- | Input generation, canonical encoding, and the shared build helpers.+module Moonlight.Triangulation.Bench.SpadeCompare.Support where++import Data.List (sort)+import Data.Word (Word64)+import GHC.Float (castDoubleToWord64)+import Numeric (showHex)+import qualified Data.Vector as V+import Moonlight.Triangulation+import Moonlight.Triangulation.Bench.SpadeCompare.Input (randomPoints)+import Moonlight.Triangulation.HintGenerator++-- | The same generated points flattened onto a sliver a picometre thick. No+-- coordinate becomes equal to another and no four points become cocircular, so+-- the input stays in general position and the load stays on the ordinary+-- face-building path; what collapses is the angular spread the bulk loaders+-- index their hulls by. That collapse is the whole of what this input+-- measures, and it does not reach the face-less location path — that one needs+-- exact collinearity, which 'exactlyCollinearPoints' supplies and gates.+nearCollinearPoints :: Word64 -> Int -> [Point]+nearCollinearPoints seed count =+  [Point x (y * 1.0e-12) | Point x y <- randomPoints seed count]++-- | Points on one exact line: @(i, 0)@, every coordinate an integer that a+-- 'Double' holds exactly. No three are in general position, so 'orient2d'+-- returns an exact zero on both sides and no face is ever built.+--+-- Uniqueness does not need general position, only one valid answer. A+-- collinear set admits exactly one triangulation — the chain of consecutive+-- segments, @n - 1@ of them and no triangle — so the canonical edge set is+-- fully determined and gates bit for bit against the strict side. Both+-- implementations state that same count as their own degenerate Euler+-- invariant, which is what makes this a shared answer rather than a+-- coincidence.+exactlyCollinearPoints :: Int -> [Point]+exactlyCollinearPoints count = [Point (fromIntegral index) 0 | index <- [0 .. count - 1]]++hex64 :: Double -> String+hex64 value =+  let raw = showHex (castDoubleToWord64 value) ""+   in replicate (16 - length raw) '0' <> raw++-- | Canonical edge set: each undirected edge as its two endpoint coordinates in+-- IEEE-754 bit patterns, endpoint-ordered then globally sorted. Formatting+-- cannot introduce a spurious disagreement and rounding cannot hide a real one.+canonicalEdges :: Triangulation mode vertex directed undirected face -> [String]+canonicalEdges triangulation =+  sort+    [ encodeCanonicalEdge first second+    | edge <- undirectedEdges triangulation+    , let (from, to) = undirectedEndpoints triangulation edge+          p = vertexPoint triangulation from+          q = vertexPoint triangulation to+          (first, second) = if key p <= key q then (p, q) else (q, p)+    ]+ where+  key (Point x y) = (x, y)++canonicalConstraintEdges+  :: ConstrainedDelaunayTriangulation vertex+  -> [String]+canonicalConstraintEdges triangulation =+  sort+    [ encodeCanonicalEdge first second+    | edge <- constraintEdges triangulation+    , let (from, to) = undirectedEndpoints triangulation edge+          p = vertexPoint triangulation from+          q = vertexPoint triangulation to+          (first, second) =+            if pointKey p <= pointKey q+              then (p, q)+              else (q, p)+    ]+ where+  pointKey (Point x y) = (x, y)++encodeCanonicalEdge :: Point -> Point -> String+encodeCanonicalEdge (Point ax ay) (Point bx by) =+  concatMap hex64 [ax, ay, bx, by]++coordHex :: Point -> String+coordHex (Point x y) = hex64 x <> hex64 y++-- | A cycle, rotated to begin at its smallest encoded element.+--+-- Both implementations keep one entry edge per vertex and per face — whichever+-- their builder wrote last — so the two walk the same cycle from different+-- places. Rotating pins the order, which the mesh determines, and declines to+-- pin the starting point, which it does not. The rotation compares the encoded+-- strings rather than the coordinates so that both sides order by the same+-- comparison: the bit pattern of a negative double does not sort in numeric+-- order, so a Haskell 'Ord' on 'Point' and a Rust @partial_cmp@ on a tuple+-- would each have to be argued to agree where two byte strings simply do.+rotateToSmallest :: [String] -> [String]+rotateToSmallest [] = []+rotateToSmallest ring =+  let !smallest = minimum ring+      (before, after) = break (== smallest) ring+   in after <> before++require :: Show failure => Either failure value -> IO value+require (Left failure) = fail (show failure)+require (Right value) = pure value++requireQueryPoints+  :: Traversable container+  => container Point+  -> IO (container QueryPoint)+requireQueryPoints = require . traverse mkQueryPoint++requireQueryChords+  :: Traversable container+  => container (Point, Point)+  -> IO (container (QueryPoint, QueryPoint))+requireQueryChords =+  require+    . traverse+      (\(from, to) -> (,) <$> mkQueryPoint from <*> mkQueryPoint to)++delaunayOf :: Int -> IO (DelaunayTriangulation Point)+delaunayOf count =+  buildTriangulation <$> require (delaunay unitElementDefaults (V.fromList (randomPoints 0x9e3779b97f4a7c15 count)))++-- | One line per query: the coordinates of the nearest vertex the hierarchy+-- routed the search to, or @none@.+nearestAnswer+  :: DelaunayTriangulation Point+  -> HierarchyHint+  -> QueryPoint+  -> String+nearestAnswer triangulation hierarchy query =+  let hint = case hierarchyHint hierarchy query of+        Just (VertexHint vertex) -> Just vertex+        _ -> Nothing+   in case nearestNeighbor triangulation hint query of+        Nothing -> "none"+        Just (vertex, _) ->+          let Point x y = vertexPoint triangulation vertex+           in hex64 x <> hex64 y++pointHex :: Point -> String+pointHex (Point x y) = hex64 x <> "," <> hex64 y++constraintPairs :: Int -> Int -> [(Int, Int)]+constraintPairs pointCount constraintCount =+  take constraintCount+    [ (a, b)+    | index <- [0 ..]+    , let a = index `mod` pointCount+          b = (index * 6151 + pointCount `quot` 2) `mod` pointCount+    , a /= b+    ]++-- | A closed square with no dangling constraint. The interior segment used by+-- the package's own benchmark is outside spade's documented "closed shape"+-- contract and makes it refuse the whole domain — not a workload the two can be+-- timed on.+refinementInput :: (V.Vector Point, V.Vector (Int, Int))+refinementInput =+  ( V.fromList [Point 0 0, Point 64 0, Point 64 64, Point 0 64]+  , V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)]+  )
+ bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Timing.hs view
@@ -0,0 +1,23 @@+-- | The single fresh-process timing boundary shared by both Haskell runners.+module Moonlight.Triangulation.Bench.SpadeCompare.Timing+  ( measureLane+  ) where++import Control.DeepSeq (NFData, force)+import Control.Exception (evaluate)+import GHC.Clock (getMonotonicTimeNSec)+import Moonlight.Triangulation.Bench.SpadeCompare.Lane+  ( LaneRequest+  , laneRequestLabel+  )+import System.Mem (performGC)++-- | Time exactly one fully forced iteration. Input construction belongs to+-- each interpreter before this boundary; the driver supplies fresh processes.+measureLane :: NFData value => LaneRequest -> IO value -> IO ()+measureLane request work = do+  performGC+  start <- getMonotonicTimeNSec+  _ <- work >>= evaluate . force+  stop <- getMonotonicTimeNSec+  putStrLn (laneRequestLabel request <> "," <> show (stop - start))
+ bench/spade-compare/hs/Moonlight/Triangulation/Bench/SpadeCompare/Voronoi.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE DataKinds #-}++-- | The Voronoi dual gate and the dual sweep lane.+module Moonlight.Triangulation.Bench.SpadeCompare.Voronoi where++import Data.List (sort)+import System.FilePath ((</>))+import Moonlight.Triangulation+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Voronoi+import Moonlight.Triangulation.Bench.SpadeCompare.Support++-- | The dual, pinned by its combinatorics and by nothing else.+--+-- Every verb the dual offers resolves a primal element, so its answers are+-- exact over a mesh the bulk-load gate already pins bit for bit. Voronoi vertex+-- POSITIONS are the exception and are deliberately absent from every artifact+-- here: a position is a circumcentre, and the two implementations do not form+-- one the same way. spade takes the reciprocal of the determinant and+-- multiplies by it; this side first rescales both difference vectors by their+-- largest component and only then divides. Each rounds where the other does+-- not, so the positions cannot be bit-identical, and a gate over them would be+-- grading the arithmetic rather than the dual. What IS determined about a+-- position is whether it exists at all, and the vertex artifact pins that.+--+-- Direction vectors are pinned in full: each component is one subtraction of+-- two stored coordinates on both sides, so there is nothing left to round.+writeVoronoiGate :: FilePath -> Int -> IO ()+writeVoronoiGate directory count = do+  triangulation <- delaunayOf count+  let prefix = directory </> ("voronoi-" <> show count)+  writeFile+    (prefix <> "-dual.txt")+    (unlines (sort (map (dualEdgeRecord triangulation) (directedVoronoiEdges triangulation))))+  writeFile (prefix <> "-cells.txt") (unlines (voronoiCellLines triangulation))+  writeFile (prefix <> "-vertices.txt") (unlines (voronoiVertexLines triangulation))++-- | One directed dual edge: the primal edge it names, the site of the dual face+-- to its left, the dual vertex at each end, the destinations its dual @next@+-- and @prev@ reach, and its direction vector. @next@ and @prev@ rotate about+-- the primal origin, so naming them by destination alone loses nothing.+dualEdgeRecord+  :: DelaunayTriangulation Point+  -> DirectedVoronoiEdgeId+  -> String+dualEdgeRecord triangulation edge =+  concat+    [ coordHex (site (origin triangulation primal))+    , coordHex (site (destination triangulation primal))+    , coordHex (site (voronoiFaceSite (voronoiIncidentFace triangulation edge)))+    , dualVertexName triangulation primal (voronoiFrom triangulation edge)+    , dualVertexName triangulation primal (voronoiTo triangulation edge)+    , coordHex (site (destination triangulation (asDelaunayDirectedEdge (voronoiNext triangulation edge))))+    , coordHex (site (destination triangulation (asDelaunayDirectedEdge (voronoiPrevious triangulation edge))))+    , coordHex (voronoiDirectionVector triangulation edge)+    ]+ where+  primal = asDelaunayDirectedEdge edge+  site = vertexPoint triangulation++-- | An inner dual vertex named by the one corner of its dual face that is not+-- an endpoint of the edge the question was asked about — the record already+-- carries the other two, so the apex completes the face. An outer dual vertex+-- is the edge itself and needs no name.+--+-- The @X@ tag cannot be reached: an inner dual vertex names an inner face by+-- construction, and 'innerFaceVertices' refuses only the outer one. spade+-- cannot emit it at all, its dual vertex carrying a face handle already typed+-- inner, so an @X@ appearing here is a disagreement rather than a crash.+dualVertexName+  :: DelaunayTriangulation Point+  -> DirectedEdgeId+  -> VoronoiVertexId+  -> String+dualVertexName _ _ (OuterVoronoiVertex _) = "O"+dualVertexName triangulation primal (InnerVoronoiVertex face) =+  case innerFaceVertices triangulation face of+    Nothing -> "X"+    Just (a, b, c)+      | isApex a -> named a+      | isApex b -> named b+      | otherwise -> named c+ where+  from = origin triangulation primal+  to = destination triangulation primal+  isApex vertex = vertex /= from && vertex /= to+  named vertex = "I" <> coordHex (vertexPoint triangulation vertex)++-- | The dual faces, one line each, plus the three enumerator lengths. The+-- undirected dual carries no artifact of its own: it is the primal undirected+-- edge set relabelled, which every existing edge gate already pins, so its+-- length is the only claim left to make about it.+voronoiCellLines :: DelaunayTriangulation Point -> [String]+voronoiCellLines triangulation =+  [ "faces " <> show (length (voronoiFaces triangulation))+  , "directed " <> show (length (directedVoronoiEdges triangulation))+  , "undirected " <> show (length (undirectedVoronoiEdges triangulation))+  ]+    <> sort+      [ coordHex (vertexPoint triangulation (voronoiFaceSite face)) <> concat (rotateToSmallest ring)+      | face <- voronoiFaces triangulation+      , let ring =+              [ coordHex+                  ( vertexPoint+                      triangulation+                      (destination triangulation (asDelaunayDirectedEdge edge))+                  )+              | edge <- voronoiFaceAdjacentEdges triangulation face+              ]+      ]++-- | The inner dual vertices, keyed by their dual face's three corners. Each+-- line carries whether the vertex has a position — the only exactly determined+-- thing about a circumcentre — and the outgoing triple the dual reports.+voronoiVertexLines :: DelaunayTriangulation Point -> [String]+voronoiVertexLines triangulation =+  sort+    [ concat (sort (map coordHex [site a, site b, site c]))+        <> existence dual+        <> concat (rotateToSmallest (outgoing dual))+    | face <- innerFaces triangulation+    , Just (a, b, c) <- [innerFaceVertices triangulation face]+    , let dual = InnerVoronoiVertex face+    ]+ where+  site = vertexPoint triangulation++  existence dual = case voronoiVertexPosition triangulation dual of+    Nothing -> "N"+    Just _ -> "J"++  outgoing dual = case voronoiVertexOutgoingEdges triangulation dual of+    Nothing -> []+    Just edges ->+      [ coordHex (site (origin triangulation primal)) <> coordHex (site (destination triangulation primal))+      | edge <- edges+      , let primal = asDelaunayDirectedEdge edge+      ]++-- | The whole dual, walked the way spade's own documentation walks it: every+-- dual face, its adjacent dual edges, and the dual vertex each of those runs+-- to. The position of an inner dual vertex is summed rather than merely+-- reached, because a 'Maybe' scrutinised only to its outer constructor can wrap+-- a thunk and the lane would then be timing the allocation of a circumcentre+-- instead of the circumcentre. Unbounded cells are counted, so a dual that+-- stopped classifying hull edges as outer moves the answer rather than the cost.+voronoiSweep :: DelaunayTriangulation Point -> (Double, Int)+voronoiSweep triangulation = foldl' overCell (0, 0) (voronoiFaces triangulation)+ where+  overCell accumulator face =+    foldl' overEdge accumulator (voronoiFaceAdjacentEdges triangulation face)++  overEdge (!total, !unbounded) edge =+    case voronoiVertexPosition triangulation (voronoiTo triangulation edge) of+      Nothing -> (total, unbounded + 1)+      Just (Point x y) -> (total + x + y, unbounded)
+ bench/support/BenchMeasure.hs view
@@ -0,0 +1,45 @@+-- | Shared benchmark clocks, allocation accounting, forcing, and typed-result+-- admission. Domain fixtures live elsewhere so native components can reuse the+-- instrument without importing triangulation machinery.+module BenchMeasure+  ( timedValue+  , timedProjection+  , requireRight+  ) where++import Control.DeepSeq (NFData, force)+import Control.Exception (evaluate)+import GHC.Clock (getMonotonicTimeNSec)+import GHC.Conc.Sync (getAllocationCounter)+import GHC.Stats+  ( RTSStats (max_live_bytes)+  , getRTSStats+  , getRTSStatsEnabled+  )+import System.CPUTime (getCPUTime)++timedValue :: NFData value => String -> IO value -> IO value+timedValue label = timedProjection label id++timedProjection :: NFData observation => String -> (value -> observation) -> IO value -> IO value+timedProjection label observe action = do+  statsEnabled <- getRTSStatsEnabled+  allocationStart <- getAllocationCounter+  wallStart <- getMonotonicTimeNSec+  cpuStart <- getCPUTime+  value <- action+  _ <- evaluate (force (observe value))+  cpuEnd <- getCPUTime+  wallEnd <- getMonotonicTimeNSec+  allocationEnd <- getAllocationCounter+  after <- if statsEnabled then Just <$> getRTSStats else pure Nothing+  putStrLn (label <> "-elapsed: " <> show (fromIntegral (wallEnd - wallStart) / 1.0e9 :: Double) <> "s")+  putStrLn (label <> "-cpu: " <> show (fromIntegral (cpuEnd - cpuStart) / 1.0e12 :: Double) <> "s")+  putStrLn (label <> "-allocated-bytes: " <> show (allocationStart - allocationEnd))+  case after of+    Just right -> putStrLn (label <> "-process-max-live-bytes: " <> show (max_live_bytes right))+    Nothing -> pure ()+  pure value++requireRight :: Show obstruction => Either obstruction value -> IO value+requireRight = either (fail . show) pure
+ bench/support/BenchSupport.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE NumericUnderscores #-}++-- | Deterministic triangulation fixtures shared by the native benchmark slices.+module BenchSupport+  ( randomPoints+  , latticePoints+  , latticeFaceBand+  ) where++import Data.List qualified as List+import Data.Word (Word64)+import Data.Vector qualified as V+import Moonlight.Triangulation.Dcel+  ( faceVertices+  , vertexPoint+  )+import Moonlight.Triangulation.Internal.HandleDefs (FaceId)+import Moonlight.Triangulation.Types+  ( Point (Point)+  , Triangulation+  , pointX+  )++randomPoints :: Word64 -> Int -> [Point]+randomPoints seed count = take count (go seed)+ where+  go :: Word64 -> [Point]+  go state =+    let state1 = state * 6364136223846793005 + 1442695040888963407+        state2 = state1 * 6364136223846793005 + 1442695040888963407+        unit :: Word64 -> Double+        unit value = fromIntegral (value `div` 2048) / 9_007_199_254_740_992+     in Point (2 * unit state1 - 1) (2 * unit state2 - 1) : go state2++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)+    )++latticeFaceBand+  :: Triangulation mode Point directed undirected face+  -> FaceId+  -> Int+latticeFaceBand triangulation face =+  let xSum =+        List.foldl'+          (\accumulator vertex -> accumulator + pointX (vertexPoint triangulation vertex))+          0+          (faceVertices triangulation face)+   in floor (xSum / 3) `quot` 20
+ docs/README.md view
@@ -0,0 +1,24 @@+# Moonlight Triangulation documentation++This page is navigation only. Each question below has one canonical owner;+indexes and retained pictures are derived views of those owners.++| Question | Canonical owner |+| --- | --- |+| Which public operation should I call? | [Package operation index](../README.md#operations) |+| Which library token should I depend on? | [Consumer libraries](../README.md#consumer-libraries) |+| What algebraic laws do meshes satisfy? | [Package algebraic contract](../README.md#algebraic-contract) |+| How are exact power cells and affine envelopes represented? | [Package affine-cell guide](../README.md#exact-power-cells-and-affine-envelopes) |+| How do weighted sites survive insertion, removal, and reweighting? | [Persistent regular-site algebra](./regular-site-algebra.md) |+| How do weighted regular cells become an exact alpha filtration? | [Exact weighted alpha filtration](./weighted-alpha.md) |+| What are the set-operation types? | [Package type signatures](../README.md#set-operation-types) |+| Which execution schedule publishes each result? | [Mesh publication guide](./mesh-publication.md) |+| How do I build and validate components locally? | [Development guide](./development.md) |+| Which workflows are compile-checked? | [Example index](./examples/README.md) |+| How does the C ABI serve Python, TypeScript, and Rust? | [Foreign bindings](../ffi/bindings/README.md) |+| How are exact alpha filtrations lowered into persistence? | [Persistence rose](./persistence-rose/README.md) |+| How is topology tracked across non-nested activation depths? | [Activation zigzag persistence](./activation-zigzag.md) |+| What does one finite alpha interval look like? | [Alpha eclipse](./persistence-rose/alpha-eclipse.md) |+| How does an exact cell set become an incidence category and nerve? | [Category observatory](./category-observatory/README.md) |+| How does Moonlight compare on Spade's construction suite? | [Delaunay construction comparison](./delaunay-compare/README.md) |+| How does Moonlight compare across the broader operation surface? | [Moonlight–Spade operation comparison](../bench/spade-compare/README.md) |
+ docs/activation-zigzag.md view
@@ -0,0 +1,71 @@+# Activation zigzag persistence++Use `Moonlight.Triangulation.Zigzag` when independently observed activation+point clouds do not form a monotone filtration. Each point carries a stable+label, each depth carries its own coordinates and exact squared-radius alpha+threshold, and adjacent observations meet through the canonical cospan++```text+K(depth i) -> K(depth i) union K(depth i+1) <- K(depth i+1).+```++The union is the compatibility context, not another sampled depth. Returned+interval endpoints therefore alternate between `ObservedDepth` and+`AdjacentDepthUnion`; both endpoints are inclusive.++## Use++On GHC 9.14 or newer, depend only on the three public surfaces named by the+workflow:++```cabal+build-depends:+  moonlight-homology >= 0.1.0.3 && < 0.2,+  moonlight-planar:dcel >= 1.0 && < 1.1,+  moonlight-planar:zigzag >= 1.0 && < 1.1,+  vector >= 0.13 && < 0.14+```++Construct a nonempty `ActivationSlice depth label` family, then call+`activationAlphaPersistence` for the stage-labelled barcode. Call+`activationAlphaZigzag` first when the admitted complexes, common cells, union+complexes, or checked inclusion maps are also required.+`activationComplexBasisAt` resolves each numeric chain basis back to its stable+labelled cells.++`ZigzagArrow` and `ZigzagInterval` are functorial carriers: use `fmap` or+`traverse` to relabel payloads and endpoints without rebuilding the checked+diagram or changing degree and multiplicity.++The compile-checked+[`squareLoopAcrossDepths`](./examples/Moonlight/Triangulation/Example/ActivationZigzag.hs)+example observes a square before its boundary appears, while it carries one+loop, and after its Delaunay faces fill that loop. Its degree-one result is:++```haskell+ZigzagInterval+  { zigzagIntervalDegree = HomologicalDegree 1+  , zigzagIntervalFirst = AdjacentDepthUnion 0 1+  , zigzagIntervalLast = ObservedDepth 1+  , zigzagIntervalMultiplicity = 1+  }+```++## Contract++- Labels, not mesh handles or input positions, identify vertices across+  depths. The input is `NonEmpty`, depth keys are unique, labels are unique within each slice, labels+  may appear or disappear between slices, and coordinates may move.+- Distinct labels at the same coordinate are rejected rather than silently+  merged. Every geometric, alpha-selection, chain, or correspondence failure+  is returned through `ActivationZigzagError`.+- Geometry and alpha comparisons are exact for the supplied finite binary64+  `Point` coordinates and `RadiusSquared` values. Induced homology maps and the+  zigzag interval decomposition use exact rational arithmetic.+- Each slice is triangulated once. At each degree, the reducer prepares and+  consumes every adjacent homology map once. It targets finite depth traces,+  not an unbounded stream.++`moonlight-planar:zigzag` owns only labelled alpha ingestion and the+adjacent-union witnesses. `Moonlight.Homology.Persistence` remains the sole+owner of checked chain maps and exact zigzag reduction.
+ docs/category-observatory/Main.hs view
@@ -0,0 +1,160 @@+module Main (main) where++import Control.Exception (IOException, try)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except+  ( ExceptT (..),+    except,+    runExceptT,+  )+import Data.Aeson qualified as Aeson+import Data.Bifunctor (first)+import Data.ByteString.Lazy.Char8 qualified as LazyByteString+import Moonlight.Triangulation.Exhibit.CategoryObservatory+  ( Exhibit,+    ExhibitError,+    buildExhibit,+    renderExhibitError,+  )+import Moonlight.Triangulation.Exhibit.CategoryObservatory.Picture+  ( PictureObstruction,+    categoryObservatoryPictureFileName,+    renderCategoryObservatoryPicture,+    renderPictureObstruction,+  )+import System.Directory (createDirectoryIfMissing)+import System.Environment (getArgs)+import System.Exit (die)+import System.FilePath ((</>), takeDirectory)++data CategoryObservatoryCommand+  = ExportJson+  | WritePicture !FilePath+  | VerifyArtifacts !FilePath++data CategoryObservatoryCommandError+  = CategoryObservatoryUsage ![String]+  | CategoryObservatoryConstructionFailed !ExhibitError+  | CategoryObservatoryPictureFailed !PictureObstruction+  | CategoryObservatoryDirectoryFailed !FilePath !IOException+  | CategoryObservatoryReadFailed !FilePath !IOException+  | CategoryObservatoryWriteFailed !FilePath !IOException+  | CategoryObservatoryArtifactMismatch !FilePath++main :: IO ()+main = do+  arguments <- getArgs+  result <- runExceptT (runCategoryObservatoryCommand arguments)+  either (die . renderCommandError) pure result++runCategoryObservatoryCommand ::+  [String] ->+  ExceptT CategoryObservatoryCommandError IO ()+runCategoryObservatoryCommand arguments = do+  command <- except (parseCommand arguments)+  exhibit <- requireExhibit+  case command of+    ExportJson -> lift (LazyByteString.putStrLn (Aeson.encode exhibit))+    WritePicture outputPath -> do+      picture <- requirePicture exhibit+      createOutputDirectory (takeDirectory outputPath)+      writeOutput outputPath picture+      lift (putStrLn ("wrote category-observatory picture " <> outputPath))+    VerifyArtifacts packageRoot -> do+      picture <- requirePicture exhibit+      let picturePath =+            packageRoot+              </> "docs"+              </> "category-observatory"+              </> categoryObservatoryPictureFileName+      actualPicture <- readOutput picturePath+      except+        ( if actualPicture == picture+            then Right ()+            else Left (CategoryObservatoryArtifactMismatch picturePath)+        )+      lift (putStrLn ("verified category-observatory picture " <> picturePath))++parseCommand ::+  [String] ->+  Either CategoryObservatoryCommandError CategoryObservatoryCommand+parseCommand arguments =+  case arguments of+    [] -> Right ExportJson+    ["picture", outputPath] -> Right (WritePicture outputPath)+    ["verify-artifacts", packageRoot] -> Right (VerifyArtifacts packageRoot)+    _ -> Left (CategoryObservatoryUsage arguments)++requireExhibit :: ExceptT CategoryObservatoryCommandError IO Exhibit+requireExhibit =+  except (first CategoryObservatoryConstructionFailed buildExhibit)++requirePicture ::+  Exhibit ->+  ExceptT CategoryObservatoryCommandError IO String+requirePicture exhibit =+  except+    ( first+        CategoryObservatoryPictureFailed+        (renderCategoryObservatoryPicture exhibit)+    )++createOutputDirectory ::+  FilePath ->+  ExceptT CategoryObservatoryCommandError IO ()+createOutputDirectory outputDirectory =+  liftIOException+    (CategoryObservatoryDirectoryFailed outputDirectory)+    (createDirectoryIfMissing True outputDirectory)++readOutput :: FilePath -> ExceptT CategoryObservatoryCommandError IO String+readOutput inputPath =+  liftIOException+    (CategoryObservatoryReadFailed inputPath)+    (readFile inputPath)++writeOutput ::+  FilePath ->+  String ->+  ExceptT CategoryObservatoryCommandError IO ()+writeOutput outputPath contents =+  liftIOException+    (CategoryObservatoryWriteFailed outputPath)+    (writeFile outputPath contents)++liftIOException ::+  (IOException -> CategoryObservatoryCommandError) ->+  IO value ->+  ExceptT CategoryObservatoryCommandError IO value+liftIOException wrapFailure =+  ExceptT . fmap (first wrapFailure) . try++renderCommandError :: CategoryObservatoryCommandError -> String+renderCommandError commandError =+  case commandError of+    CategoryObservatoryUsage arguments ->+      "invalid category-observatory command "+        <> show arguments+        <> "; expected no arguments (JSON) | picture OUTPUT.svg | verify-artifacts PACKAGE_ROOT"+    CategoryObservatoryConstructionFailed exhibitError ->+      renderExhibitError exhibitError+    CategoryObservatoryPictureFailed pictureError ->+      renderPictureObstruction pictureError+    CategoryObservatoryDirectoryFailed path caughtError ->+      "could not create category-observatory output directory "+        <> show path+        <> ": "+        <> show caughtError+    CategoryObservatoryReadFailed path caughtError ->+      "could not read category-observatory artifact "+        <> show path+        <> ": "+        <> show caughtError+    CategoryObservatoryWriteFailed path caughtError ->+      "could not write category-observatory artifact "+        <> show path+        <> ": "+        <> show caughtError+    CategoryObservatoryArtifactMismatch path ->+      "tracked category-observatory artifact differs from its canonical renderer: "+        <> show path
+ docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory.hs view
@@ -0,0 +1,96 @@+module Moonlight.Triangulation.Exhibit.CategoryObservatory+  ( Exhibit,+    ExhibitError,+    buildExhibit,+    renderExhibitError,+  )+where++import Data.Bifunctor (first)+import Data.Vector qualified as Vector+import Moonlight.Homology.Pure.Topology.CellCategory (complexCategory)+import Moonlight.Homology.Pure.Topology.CellComplex (CellComplex2D (..))+import Moonlight.Triangulation.BulkLoad (delaunayGeometry)+import Moonlight.Triangulation.CellComplex+  ( DCELComplex,+    fromExactCellSet,+  )+import Moonlight.Triangulation.CellSet+  ( ExactCellSet,+    closeFaceCellSet,+    exactCellSetEdgeCount,+    exactCellSetFaceCount,+    exactCellSetVertexCount,+  )+import Moonlight.Triangulation.Exhibit.CategoryObservatory.Category+  ( projectCategory,+    validateCategoryEnumeration,+  )+import Moonlight.Triangulation.Exhibit.CategoryObservatory.Geometry (projectMesh)+import Moonlight.Triangulation.Exhibit.CategoryObservatory.Model+  ( CellInventory (..),+    Exhibit (..),+    ExhibitError (..),+    renderExhibitError,+  )+import Moonlight.Triangulation.Exhibit.CategoryObservatory.Nerve+  ( projectNerve,+    validateNerveCount,+  )+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (innerFaces)+import Moonlight.Triangulation.Types (Point (..))++buildExhibit :: Either ExhibitError Exhibit+buildExhibit = do+  triangulation <- first ExhibitTriangulationBuildFailed (delaunayGeometry exhibitPoints)+  selectedCells <-+    first ExhibitCellSelectionFailed+      (closeFaceCellSet triangulation (innerFaces triangulation))+  let complexValue = fromExactCellSet selectedCells+      categoryValue = complexCategory complexValue+  validateInventory selectedCells complexValue+  validateCategoryEnumeration complexValue categoryValue+  categoryProjection <- projectCategory triangulation categoryValue+  nerveProjection <- projectNerve categoryValue+  validateNerveCount complexValue nerveProjection+  pure+    Exhibit+      { schemaVersion = 2,+        exhibitTitle = "Triangulation, incidence category, and flag nerve",+        mesh = projectMesh triangulation complexValue,+        category = categoryProjection,+        nerve = nerveProjection+      }++validateInventory :: ExactCellSet -> DCELComplex -> Either ExhibitError ()+validateInventory cellSet complexValue =+  let expectedInventory =+        CellInventory+          { cellVertexCount = exactCellSetVertexCount cellSet,+            cellEdgeCount = exactCellSetEdgeCount cellSet,+            cellFaceCount = exactCellSetFaceCount cellSet+          }+      observedInventory =+        CellInventory+          { cellVertexCount = length (vertices complexValue),+            cellEdgeCount = length (edges complexValue),+            cellFaceCount = length (faces complexValue)+          }+   in if observedInventory == expectedInventory+        then Right ()+        else Left (ExhibitInventoryMismatch expectedInventory observedInventory)++exhibitPoints :: Vector.Vector Point+exhibitPoints =+  Vector.fromList+    [ Point 80 72,+      Point 222 48,+      Point 362 92,+      Point 52 208,+      Point 176 166,+      Point 310 190,+      Point 414 232,+      Point 112 330,+      Point 258 314,+      Point 380 354+    ]
+ docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Category.hs view
@@ -0,0 +1,127 @@+module Moonlight.Triangulation.Exhibit.CategoryObservatory.Category+  ( incidenceFlagCount,+    projectCategory,+    validateCategoryEnumeration,+  )+where++import Data.Bifunctor (first)+import Data.Containers.ListUtils (nubOrd)+import Moonlight.Category+  ( Category (..),+    FiniteComposableCategory (..),+  )+import Moonlight.Homology.Pure.Topology.CellCategory+  ( ComplexCat,+    ComplexMor (..),+    ComplexOb,+  )+import Moonlight.Homology.Pure.Topology.CellComplex+  ( CellComplex2D (..),+    CellTypes (..),+    OrientedEdge (..),+  )+import Moonlight.Triangulation.CellComplex (DCELComplex)+import Moonlight.Triangulation.Exhibit.CategoryObservatory.Geometry (positionForObject)+import Moonlight.Triangulation.Exhibit.CategoryObservatory.Identifier+  ( morphismKind,+    objectIdentifier,+    objectKind,+    objectLabel,+  )+import Moonlight.Triangulation.Exhibit.CategoryObservatory.Model+  ( CategoryMorphism (..),+    CategoryObject (..),+    CategoryProjection (..),+    ExhibitError (..),+    MorphismEndpoint (..),+    MorphismInventory (..),+  )+import Moonlight.Triangulation.Types (DelaunayTriangulation)++projectCategory ::+  DelaunayTriangulation () ->+  ComplexCat DCELComplex ->+  Either ExhibitError CategoryProjection+projectCategory triangulation categoryValue =+  CategoryProjection+    <$> traverse+      (projectCategoryObject triangulation)+      (enumerateObjects categoryValue)+    <*> traverse+      (projectCategoryMorphism categoryValue)+      (zip [0 ..] (enumerateMorphisms categoryValue))++projectCategoryObject ::+  DelaunayTriangulation () ->+  ComplexOb DCELComplex ->+  Either ExhibitError CategoryObject+projectCategoryObject triangulation objectValue =+  CategoryObject+    (objectIdentifier objectValue)+    (objectKind objectValue)+    (objectLabel objectValue)+    <$> positionForObject triangulation objectValue++projectCategoryMorphism ::+  ComplexCat DCELComplex ->+  (Int, ComplexMor DCELComplex) ->+  Either ExhibitError CategoryMorphism+projectCategoryMorphism categoryValue (morphismIndex, morphismValue) =+  CategoryMorphism+    ("morphism-" <> show morphismIndex)+    (morphismKind morphismValue)+    <$> projectedEndpoint MorphismSource source+    <*> projectedEndpoint MorphismTarget target+  where+    projectedEndpoint endpoint endpointProjection =+      objectIdentifier+        <$> first+          (const (ExhibitMorphismEndpointUnavailable endpoint morphismIndex))+          (endpointProjection categoryValue morphismValue)++validateCategoryEnumeration ::+  DCELComplex ->+  ComplexCat DCELComplex ->+  Either ExhibitError ()+validateCategoryEnumeration complexValue categoryValue =+  let morphisms = enumerateMorphisms categoryValue+      expectedInventory =+        MorphismInventory+          { identityMorphismCount =+              length (vertices complexValue)+                + length (edges complexValue)+                + length (faces complexValue),+            faceEdgeMorphismCount =+              sum (fmap (length . faceBoundary complexValue) (faces complexValue)),+            edgeVertexMorphismCount =+              sum (fmap (edgeEndpointCount complexValue) (edges complexValue)),+            faceVertexMorphismCount =+              sum (fmap (incidenceFlagCount complexValue) (faces complexValue))+          }+      observedInventory =+        foldMap morphismInventory morphisms+   in if observedInventory == expectedInventory+        then Right ()+        else Left (ExhibitCategoryEnumerationMismatch expectedInventory observedInventory)++edgeEndpointCount :: DCELComplex -> Edge DCELComplex -> Int+edgeEndpointCount complexValue edgeValue =+  let (sourceVertex, targetVertex) = edgeBoundary complexValue edgeValue+   in length (nubOrd [sourceVertex, targetVertex])++incidenceFlagCount :: DCELComplex -> Face DCELComplex -> Int+incidenceFlagCount complexValue faceValue =+  sum+    ( fmap+        (edgeEndpointCount complexValue . orientedEdge)+        (faceBoundary complexValue faceValue)+    )++morphismInventory :: ComplexMor DCELComplex -> MorphismInventory+morphismInventory morphismValue =+  case morphismValue of+    IdentityMor _ -> MorphismInventory 1 0 0 0+    FaceToEdge {} -> MorphismInventory 0 1 0 0+    EdgeToVertex _ _ -> MorphismInventory 0 0 1 0+    FaceToVertex {} -> MorphismInventory 0 0 0 1
+ docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Geometry.hs view
@@ -0,0 +1,127 @@+module Moonlight.Triangulation.Exhibit.CategoryObservatory.Geometry+  ( positionForObject,+    projectMesh,+  )+where++import Data.Foldable (foldMap')+import Moonlight.Homology.Pure.Topology.CellCategory (ComplexOb (..))+import Moonlight.Homology.Pure.Topology.CellComplex (CellComplex2D (..))+import Moonlight.Triangulation.CellComplex (DCELComplex)+import Moonlight.Triangulation.Dcel+  ( faceVertices,+    undirectedEndpoints,+    vertexPoint,+  )+import Moonlight.Triangulation.Exhibit.CategoryObservatory.Identifier+  ( edgeIdentifier,+    edgeObjectIdentifier,+    faceIdentifier,+    faceObjectIdentifier,+    vertexIdentifier,+    vertexObjectIdentifier,+  )+import Moonlight.Triangulation.Exhibit.CategoryObservatory.Model+  ( ExhibitError (..),+    MeshEdge (..),+    MeshFace (..),+    MeshProjection (..),+    MeshVertex (..),+    Position (..),+  )+import Moonlight.Triangulation.Internal.HandleDefs+  ( FaceId,+    UndirectedEdgeId,+    VertexId,+  )+import Moonlight.Triangulation.Types+  ( DelaunayTriangulation,+    Point (..),+  )++projectMesh :: DelaunayTriangulation () -> DCELComplex -> MeshProjection+projectMesh triangulation complexValue =+  MeshProjection+    { meshVertices = fmap (projectMeshVertex triangulation) (vertices complexValue),+      meshEdges = fmap (projectMeshEdge triangulation) (edges complexValue),+      meshFaces = fmap (projectMeshFace triangulation) (faces complexValue)+    }++projectMeshVertex :: DelaunayTriangulation () -> VertexId -> MeshVertex+projectMeshVertex triangulation vertexValue =+  MeshVertex+    { meshVertexIdentifier = vertexIdentifier vertexValue,+      meshVertexObjectIdentifier = vertexObjectIdentifier vertexValue,+      meshVertexPosition = pointPosition (vertexPoint triangulation vertexValue)+    }++projectMeshEdge :: DelaunayTriangulation () -> UndirectedEdgeId -> MeshEdge+projectMeshEdge triangulation edgeValue =+  let (sourceVertex, targetVertex) = undirectedEndpoints triangulation edgeValue+   in MeshEdge+        { meshEdgeIdentifier = edgeIdentifier edgeValue,+          meshEdgeObjectIdentifier = edgeObjectIdentifier edgeValue,+          meshEdgeVertexIdentifiers = fmap vertexIdentifier [sourceVertex, targetVertex]+        }++projectMeshFace :: DelaunayTriangulation () -> FaceId -> MeshFace+projectMeshFace triangulation faceValue =+  MeshFace+    { meshFaceIdentifier = faceIdentifier faceValue,+      meshFaceObjectIdentifier = faceObjectIdentifier faceValue,+      meshFaceVertexIdentifiers = fmap vertexIdentifier (faceVertices triangulation faceValue)+    }++positionForObject ::+  DelaunayTriangulation () ->+  ComplexOb DCELComplex ->+  Either ExhibitError Position+positionForObject triangulation objectValue =+  case objectValue of+    VertexOb vertexValue ->+      Right (pointPosition (vertexPoint triangulation vertexValue))+    EdgeOb edgeValue ->+      let (sourceVertex, targetVertex) = undirectedEndpoints triangulation edgeValue+       in Right+            ( midpoint+                (pointPosition (vertexPoint triangulation sourceVertex))+                (pointPosition (vertexPoint triangulation targetVertex))+            )+    FaceOb faceValue ->+      centroid faceValue+        (fmap (pointPosition . vertexPoint triangulation) (faceVertices triangulation faceValue))++data PositionSum = PositionSum Double Double++instance Semigroup PositionSum where+  PositionSum leftX leftY <> PositionSum rightX rightY =+    PositionSum (leftX + rightX) (leftY + rightY)++instance Monoid PositionSum where+  mempty = PositionSum 0 0++centroid :: FaceId -> [Position] -> Either ExhibitError Position+centroid faceValue positions =+  case positions of+    [] -> Left (ExhibitFaceWithoutVertices faceValue)+    _ ->+      let PositionSum summedX summedY =+            foldMap'+              (\positionValue -> PositionSum (positionX positionValue) (positionY positionValue))+              positions+          positionCount = fromIntegral (length positions)+       in Right (Position (summedX / positionCount) (summedY / positionCount))++midpoint :: Position -> Position -> Position+midpoint firstPosition secondPosition =+  Position+    { positionX = (positionX firstPosition + positionX secondPosition) / 2,+      positionY = (positionY firstPosition + positionY secondPosition) / 2+    }++pointPosition :: Point -> Position+pointPosition pointValue =+  Position+    { positionX = pointX pointValue,+      positionY = pointY pointValue+    }
+ docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Identifier.hs view
@@ -0,0 +1,78 @@+module Moonlight.Triangulation.Exhibit.CategoryObservatory.Identifier+  ( objectIdentifier,+    objectKind,+    objectLabel,+    morphismKind,+    vertexIdentifier,+    edgeIdentifier,+    faceIdentifier,+    vertexObjectIdentifier,+    edgeObjectIdentifier,+    faceObjectIdentifier,+  )+where++import Moonlight.Homology.Pure.Topology.CellCategory+  ( ComplexMor (..),+    ComplexOb (..),+  )+import Moonlight.Triangulation.CellComplex (DCELComplex)+import Moonlight.Triangulation.Exhibit.CategoryObservatory.Model+  ( CategoryMorphismKind (..),+    CategoryObjectKind (..),+  )+import Moonlight.Triangulation.Internal.HandleDefs+  ( FaceId,+    UndirectedEdgeId,+    VertexId,+    unFaceId,+    unUndirectedEdgeId,+    unVertexId,+  )++objectIdentifier :: ComplexOb DCELComplex -> String+objectIdentifier objectValue =+  case objectValue of+    VertexOb vertexValue -> vertexObjectIdentifier vertexValue+    EdgeOb edgeValue -> edgeObjectIdentifier edgeValue+    FaceOb faceValue -> faceObjectIdentifier faceValue++objectKind :: ComplexOb DCELComplex -> CategoryObjectKind+objectKind objectValue =+  case objectValue of+    VertexOb _ -> VertexObject+    EdgeOb _ -> EdgeObject+    FaceOb _ -> FaceObject++objectLabel :: ComplexOb DCELComplex -> String+objectLabel objectValue =+  case objectValue of+    VertexOb vertexValue -> "v" <> show (unVertexId vertexValue)+    EdgeOb edgeValue -> "e" <> show (unUndirectedEdgeId edgeValue)+    FaceOb faceValue -> "f" <> show (unFaceId faceValue)++morphismKind :: ComplexMor DCELComplex -> CategoryMorphismKind+morphismKind morphismValue =+  case morphismValue of+    IdentityMor _ -> IdentityMorphism+    FaceToEdge {} -> FaceEdgeMorphism+    EdgeToVertex _ _ -> EdgeVertexMorphism+    FaceToVertex {} -> FaceVertexComposite++vertexIdentifier :: VertexId -> String+vertexIdentifier vertexValue = "vertex-" <> show (unVertexId vertexValue)++edgeIdentifier :: UndirectedEdgeId -> String+edgeIdentifier edgeValue = "edge-" <> show (unUndirectedEdgeId edgeValue)++faceIdentifier :: FaceId -> String+faceIdentifier faceValue = "face-" <> show (unFaceId faceValue)++vertexObjectIdentifier :: VertexId -> String+vertexObjectIdentifier vertexValue = "object-" <> vertexIdentifier vertexValue++edgeObjectIdentifier :: UndirectedEdgeId -> String+edgeObjectIdentifier edgeValue = "object-" <> edgeIdentifier edgeValue++faceObjectIdentifier :: FaceId -> String+faceObjectIdentifier faceValue = "object-" <> faceIdentifier faceValue
+ docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Model.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE DeriveAnyClass #-}++module Moonlight.Triangulation.Exhibit.CategoryObservatory.Model+  ( Exhibit (..),+    MeshProjection (..),+    MeshVertex (..),+    MeshEdge (..),+    MeshFace (..),+    Position (..),+    CategoryProjection (..),+    CategoryObject (..),+    CategoryObjectKind (..),+    CategoryMorphism (..),+    CategoryMorphismKind (..),+    NerveProjection (..),+    NerveSimplexCount (..),+    NerveTwoSimplex (..),+    CellInventory (..),+    MorphismInventory (..),+    ExhibitError (..),+    MorphismEndpoint (..),+    renderExhibitError,+  )+where++import Data.Aeson (ToJSON)+import GHC.Generics (Generic)+import Moonlight.Triangulation.CellSet (CellSelectionError)+import Moonlight.Triangulation.Internal.HandleDefs (FaceId)+import Moonlight.Triangulation.Types (BuildError)+import Numeric.Natural (Natural)++data Exhibit = Exhibit+  { schemaVersion :: Int,+    exhibitTitle :: String,+    mesh :: MeshProjection,+    category :: CategoryProjection,+    nerve :: NerveProjection+  }+  deriving stock (Generic)+  deriving anyclass (ToJSON)++data MeshProjection = MeshProjection+  { meshVertices :: [MeshVertex],+    meshEdges :: [MeshEdge],+    meshFaces :: [MeshFace]+  }+  deriving stock (Generic)+  deriving anyclass (ToJSON)++data MeshVertex = MeshVertex+  { meshVertexIdentifier :: String,+    meshVertexObjectIdentifier :: String,+    meshVertexPosition :: Position+  }+  deriving stock (Generic)+  deriving anyclass (ToJSON)++data MeshEdge = MeshEdge+  { meshEdgeIdentifier :: String,+    meshEdgeObjectIdentifier :: String,+    meshEdgeVertexIdentifiers :: [String]+  }+  deriving stock (Generic)+  deriving anyclass (ToJSON)++data MeshFace = MeshFace+  { meshFaceIdentifier :: String,+    meshFaceObjectIdentifier :: String,+    meshFaceVertexIdentifiers :: [String]+  }+  deriving stock (Generic)+  deriving anyclass (ToJSON)++data Position = Position+  { positionX :: Double,+    positionY :: Double+  }+  deriving stock (Generic)+  deriving anyclass (ToJSON)++data CategoryProjection = CategoryProjection+  { categoryObjects :: [CategoryObject],+    categoryMorphisms :: [CategoryMorphism]+  }+  deriving stock (Generic)+  deriving anyclass (ToJSON)++data CategoryObject = CategoryObject+  { categoryObjectIdentifier :: String,+    categoryObjectKind :: CategoryObjectKind,+    categoryObjectLabel :: String,+    categoryObjectPosition :: Position+  }+  deriving stock (Generic)+  deriving anyclass (ToJSON)++data CategoryObjectKind+  = VertexObject+  | EdgeObject+  | FaceObject+  deriving stock (Eq, Show, Generic)+  deriving anyclass (ToJSON)++data CategoryMorphism = CategoryMorphism+  { categoryMorphismIdentifier :: String,+    categoryMorphismKind :: CategoryMorphismKind,+    categoryMorphismSourceObject :: String,+    categoryMorphismTargetObject :: String+  }+  deriving stock (Generic)+  deriving anyclass (ToJSON)++data CategoryMorphismKind+  = IdentityMorphism+  | FaceEdgeMorphism+  | EdgeVertexMorphism+  | FaceVertexComposite+  deriving stock (Generic)+  deriving anyclass (ToJSON)++data NerveProjection = NerveProjection+  { nerveTwoSimplices :: [NerveTwoSimplex],+    nerveSimplexCounts :: [NerveSimplexCount]+  }+  deriving stock (Generic)+  deriving anyclass (ToJSON)++data NerveSimplexCount = NerveSimplexCount+  { nerveDimension :: Natural,+    normalizedSimplexCount :: Int,+    unnormalizedSimplexCount :: Int+  }+  deriving stock (Generic)+  deriving anyclass (ToJSON)++data NerveTwoSimplex = NerveTwoSimplex+  { nerveSimplexIdentifier :: String,+    nerveSimplexObjectIdentifiers :: [String]+  }+  deriving stock (Generic)+  deriving anyclass (ToJSON)++data CellInventory = CellInventory+  { cellVertexCount :: Int,+    cellEdgeCount :: Int,+    cellFaceCount :: Int+  }+  deriving stock (Eq, Show)++data MorphismInventory = MorphismInventory+  { identityMorphismCount :: Int,+    faceEdgeMorphismCount :: Int,+    edgeVertexMorphismCount :: Int,+    faceVertexMorphismCount :: Int+  }+  deriving stock (Eq, Show)++instance Semigroup MorphismInventory where+  MorphismInventory leftIdentities leftFaceEdges leftEdgeVertices leftFaceVertices+    <> MorphismInventory rightIdentities rightFaceEdges rightEdgeVertices rightFaceVertices =+      MorphismInventory+        (leftIdentities + rightIdentities)+        (leftFaceEdges + rightFaceEdges)+        (leftEdgeVertices + rightEdgeVertices)+        (leftFaceVertices + rightFaceVertices)++instance Monoid MorphismInventory where+  mempty = MorphismInventory 0 0 0 0++data ExhibitError+  = ExhibitTriangulationBuildFailed BuildError+  | ExhibitCellSelectionFailed CellSelectionError+  | ExhibitMorphismEndpointUnavailable MorphismEndpoint Int+  | ExhibitFaceWithoutVertices FaceId+  | ExhibitMalformedTwoSimplex Int+  | ExhibitInventoryMismatch CellInventory CellInventory+  | ExhibitCategoryEnumerationMismatch MorphismInventory MorphismInventory+  | ExhibitNerveCountMismatch Int Int+  deriving stock (Show)++data MorphismEndpoint+  = MorphismSource+  | MorphismTarget+  deriving stock (Show)++renderExhibitError :: ExhibitError -> String+renderExhibitError = show
+ docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Nerve.hs view
@@ -0,0 +1,84 @@+module Moonlight.Triangulation.Exhibit.CategoryObservatory.Nerve+  ( projectNerve,+    validateNerveCount,+  )+where++import Data.List.NonEmpty (NonEmpty (..))+import Moonlight.Category (chainVertices)+import Moonlight.Category.Simplicial+  ( GeneratedSSet,+    NerveSimplex,+    TruncatedNormalizedSSet,+    generatedSimplicesAtDimension,+    nerveSimplexChain,+    normalizedNerve,+    simplicesAtDimension,+    unnormalizedNerve,+  )+import Moonlight.Homology.Pure.Topology.CellCategory (ComplexCat)+import Moonlight.Homology.Pure.Topology.CellComplex (CellComplex2D (..))+import Moonlight.Triangulation.CellComplex (DCELComplex)+import Moonlight.Triangulation.Exhibit.CategoryObservatory.Category (incidenceFlagCount)+import Moonlight.Triangulation.Exhibit.CategoryObservatory.Identifier (objectIdentifier)+import Moonlight.Triangulation.Exhibit.CategoryObservatory.Model+  ( ExhibitError (..),+    NerveProjection (..),+    NerveSimplexCount (..),+    NerveTwoSimplex (..),+  )+import Numeric.Natural (Natural)++projectNerve :: ComplexCat DCELComplex -> Either ExhibitError NerveProjection+projectNerve categoryValue =+  let normalizedNerveValue = normalizedNerve categoryValue nerveObservationBound+      unnormalizedNerveValue = unnormalizedNerve categoryValue nerveObservationBound+   in NerveProjection+        <$> traverse+          projectTwoSimplex+          (zip [0 ..] (simplicesAtDimension normalizedNerveValue nerveObservationBound))+        <*> pure+          ( fmap+              (projectNerveSimplexCount normalizedNerveValue unnormalizedNerveValue)+              nerveObservationDimensions+          )++validateNerveCount :: DCELComplex -> NerveProjection -> Either ExhibitError ()+validateNerveCount complexValue nerveProjection =+  let expectedCount = sum (fmap (incidenceFlagCount complexValue) (faces complexValue))+      observedCount = length (nerveTwoSimplices nerveProjection)+   in if observedCount == expectedCount+        then Right ()+        else Left (ExhibitNerveCountMismatch expectedCount observedCount)++projectNerveSimplexCount ::+  TruncatedNormalizedSSet (NerveSimplex (ComplexCat DCELComplex)) ->+  GeneratedSSet (NerveSimplex (ComplexCat DCELComplex)) ->+  Natural ->+  NerveSimplexCount+projectNerveSimplexCount normalizedNerveValue unnormalizedNerveValue dimensionValue =+  NerveSimplexCount+    { nerveDimension = dimensionValue,+      normalizedSimplexCount = length (simplicesAtDimension normalizedNerveValue dimensionValue),+      unnormalizedSimplexCount = length (generatedSimplicesAtDimension unnormalizedNerveValue dimensionValue)+    }++projectTwoSimplex ::+  (Int, NerveSimplex (ComplexCat DCELComplex)) ->+  Either ExhibitError NerveTwoSimplex+projectTwoSimplex (simplexIndex, simplexValue) =+  case chainVertices (nerveSimplexChain simplexValue) of+    faceObject :| [edgeObject, vertexObject] ->+      Right+        NerveTwoSimplex+          { nerveSimplexIdentifier = "simplex-" <> show simplexIndex,+            nerveSimplexObjectIdentifiers =+              fmap objectIdentifier [faceObject, edgeObject, vertexObject]+          }+    _ -> Left (ExhibitMalformedTwoSimplex simplexIndex)++nerveObservationBound :: Natural+nerveObservationBound = 2++nerveObservationDimensions :: [Natural]+nerveObservationDimensions = [0, 1, 2]
+ docs/category-observatory/Moonlight/Triangulation/Exhibit/CategoryObservatory/Picture.hs view
@@ -0,0 +1,663 @@+{-# LANGUAGE LambdaCase #-}++-- | Pure, compact SVG projection of the checked category-observatory exhibit.+module Moonlight.Triangulation.Exhibit.CategoryObservatory.Picture+  ( PictureObstruction (..),+    categoryObservatoryPictureFileName,+    renderCategoryObservatoryPicture,+    renderPictureObstruction,+  )+where++import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Moonlight.Triangulation.Exhibit.CategoryObservatory.Model+  ( CategoryObject (..),+    CategoryObjectKind (..),+    CategoryProjection (..),+    Exhibit (..),+    MeshEdge (..),+    MeshFace (..),+    MeshProjection (..),+    MeshVertex (..),+    NerveProjection (..),+    NerveSimplexCount (..),+    NerveTwoSimplex (..),+    Position (..),+  )+import Numeric (showFFloat)++data PictureObstruction+  = PictureHasNoMeshVertices+  | PictureHasNoNerveTwoSimplex+  | PictureMissingMeshVertex !String+  | PictureMissingCategoryObject !String+  | PictureMalformedMeshEdge !String ![String]+  | PictureMalformedMeshFace !String ![String]+  | PictureMalformedNerveTwoSimplex !String ![String]+  | PictureMalformedFlagKinds ![CategoryObjectKind]+  deriving stock (Eq, Show)++data PictureBounds = PictureBounds+  { minimumX :: !Double,+    minimumY :: !Double,+    maximumX :: !Double,+    maximumY :: !Double+  }++data PictureFrame = PictureFrame+  { frameLeft :: !Double,+    frameTop :: !Double,+    frameWidth :: !Double,+    frameHeight :: !Double+  }++data ResolvedMeshEdge = ResolvedMeshEdge+  { resolvedEdge :: !MeshEdge,+    resolvedEdgeSource :: !Position,+    resolvedEdgeTarget :: !Position+  }++data ResolvedMeshFace = ResolvedMeshFace+  { resolvedFace :: !MeshFace,+    resolvedFaceVertices :: ![Position]+  }++data ResolvedNerveSimplex = ResolvedNerveSimplex+  { resolvedSimplex :: !NerveTwoSimplex,+    resolvedSimplexVertices :: ![Position]+  }++data FlagSelection = FlagSelection+  { selectedSimplexIdentifier :: !String,+    selectedFace :: !CategoryObject,+    selectedEdge :: !CategoryObject,+    selectedVertex :: !CategoryObject,+    selectedObjectIdentifiers :: !(Set.Set String)+  }++data PictureContext = PictureContext+  { contextExhibit :: !Exhibit,+    contextBounds :: !PictureBounds,+    contextEdges :: ![ResolvedMeshEdge],+    contextFaces :: ![ResolvedMeshFace],+    contextNerveSimplices :: ![ResolvedNerveSimplex],+    contextFlag :: !FlagSelection+  }++categoryObservatoryPictureFileName :: FilePath+categoryObservatoryPictureFileName =+  "moonlight-triangulation-category-observatory.svg"++renderCategoryObservatoryPicture :: Exhibit -> Either PictureObstruction String+renderCategoryObservatoryPicture exhibit =+  renderPicture <$> preparePicture exhibit++renderPictureObstruction :: PictureObstruction -> String+renderPictureObstruction = \case+  PictureHasNoMeshVertices ->+    "category-observatory picture requires at least one mesh vertex"+  PictureHasNoNerveTwoSimplex ->+    "category-observatory picture requires at least one admitted two-simplex"+  PictureMissingMeshVertex identifier ->+    "category-observatory picture cannot resolve mesh vertex " <> show identifier+  PictureMissingCategoryObject identifier ->+    "category-observatory picture cannot resolve category object " <> show identifier+  PictureMalformedMeshEdge identifier vertices ->+    "category-observatory mesh edge "+      <> show identifier+      <> " does not name exactly two vertices: "+      <> show vertices+  PictureMalformedMeshFace identifier vertices ->+    "category-observatory mesh face "+      <> show identifier+      <> " does not name exactly three vertices: "+      <> show vertices+  PictureMalformedNerveTwoSimplex identifier objects ->+    "category-observatory nerve simplex "+      <> show identifier+      <> " does not name one face, edge, and vertex: "+      <> show objects+  PictureMalformedFlagKinds kinds ->+    "category-observatory selected flag has incompatible object kinds: " <> show kinds++preparePicture :: Exhibit -> Either PictureObstruction PictureContext+preparePicture exhibit = do+  let meshProjection = mesh exhibit+      categoryProjection = category exhibit+      nerveProjection = nerve exhibit+      meshVerticesValue = meshVertices meshProjection+      vertexPositions =+        Map.fromList+          ( fmap+              (\vertex -> (meshVertexIdentifier vertex, meshVertexPosition vertex))+              meshVerticesValue+          )+      categoryObjectsByIdentifier =+        Map.fromList+          ( fmap+              (\objectValue -> (categoryObjectIdentifier objectValue, objectValue))+              (categoryObjects categoryProjection)+          )+  pictureBounds <- boundsFromPositions (meshVertexPosition <$> meshVerticesValue)+  resolvedEdges <- traverse (resolveMeshEdge vertexPositions) (meshEdges meshProjection)+  resolvedFaces <- traverse (resolveMeshFace vertexPositions) (meshFaces meshProjection)+  resolvedSimplices <-+    traverse+      (resolveNerveSimplex categoryObjectsByIdentifier)+      (nerveTwoSimplices nerveProjection)+  flagSelection <- selectFlag categoryObjectsByIdentifier (nerveTwoSimplices nerveProjection)+  pure+    PictureContext+      { contextExhibit = exhibit,+        contextBounds = pictureBounds,+        contextEdges = resolvedEdges,+        contextFaces = resolvedFaces,+        contextNerveSimplices = resolvedSimplices,+        contextFlag = flagSelection+      }++boundsFromPositions :: [Position] -> Either PictureObstruction PictureBounds+boundsFromPositions positions =+  case positions of+    [] -> Left PictureHasNoMeshVertices+    firstPosition : remainingPositions ->+      Right+        ( foldl'+            extendBounds+            ( PictureBounds+                (positionX firstPosition)+                (positionY firstPosition)+                (positionX firstPosition)+                (positionY firstPosition)+            )+            remainingPositions+        )++extendBounds :: PictureBounds -> Position -> PictureBounds+extendBounds bounds positionValue =+  PictureBounds+    { minimumX = min (minimumX bounds) (positionX positionValue),+      minimumY = min (minimumY bounds) (positionY positionValue),+      maximumX = max (maximumX bounds) (positionX positionValue),+      maximumY = max (maximumY bounds) (positionY positionValue)+    }++resolveMeshEdge ::+  Map.Map String Position ->+  MeshEdge ->+  Either PictureObstruction ResolvedMeshEdge+resolveMeshEdge vertexPositions edgeValue =+  case meshEdgeVertexIdentifiers edgeValue of+    [sourceIdentifier, targetIdentifier] ->+      ResolvedMeshEdge edgeValue+        <$> lookupMeshVertex vertexPositions sourceIdentifier+        <*> lookupMeshVertex vertexPositions targetIdentifier+    identifiers ->+      Left (PictureMalformedMeshEdge (meshEdgeIdentifier edgeValue) identifiers)++resolveMeshFace ::+  Map.Map String Position ->+  MeshFace ->+  Either PictureObstruction ResolvedMeshFace+resolveMeshFace vertexPositions faceValue =+  case meshFaceVertexIdentifiers faceValue of+    [firstIdentifier, secondIdentifier, thirdIdentifier] ->+      ResolvedMeshFace faceValue+        <$> traverse+          (lookupMeshVertex vertexPositions)+          [firstIdentifier, secondIdentifier, thirdIdentifier]+    identifiers ->+      Left (PictureMalformedMeshFace (meshFaceIdentifier faceValue) identifiers)++lookupMeshVertex ::+  Map.Map String Position ->+  String ->+  Either PictureObstruction Position+lookupMeshVertex vertexPositions identifier =+  maybe+    (Left (PictureMissingMeshVertex identifier))+    Right+    (Map.lookup identifier vertexPositions)++resolveNerveSimplex ::+  Map.Map String CategoryObject ->+  NerveTwoSimplex ->+  Either PictureObstruction ResolvedNerveSimplex+resolveNerveSimplex categoryObjectsByIdentifier simplexValue =+  case nerveSimplexObjectIdentifiers simplexValue of+    [faceIdentifier, edgeIdentifier, vertexIdentifier] ->+      ResolvedNerveSimplex simplexValue+        . fmap categoryObjectPosition+        <$> traverse+          (lookupCategoryObject categoryObjectsByIdentifier)+          [faceIdentifier, edgeIdentifier, vertexIdentifier]+    identifiers ->+      Left+        ( PictureMalformedNerveTwoSimplex+            (nerveSimplexIdentifier simplexValue)+            identifiers+        )++selectFlag ::+  Map.Map String CategoryObject ->+  [NerveTwoSimplex] ->+  Either PictureObstruction FlagSelection+selectFlag categoryObjectsByIdentifier simplices =+  case simplices of+    [] -> Left PictureHasNoNerveTwoSimplex+    simplexValue : _ ->+      case nerveSimplexObjectIdentifiers simplexValue of+        identifiers@[faceIdentifier, edgeIdentifier, vertexIdentifier] -> do+          faceObject <- lookupCategoryObject categoryObjectsByIdentifier faceIdentifier+          edgeObject <- lookupCategoryObject categoryObjectsByIdentifier edgeIdentifier+          vertexObject <- lookupCategoryObject categoryObjectsByIdentifier vertexIdentifier+          let kinds = categoryObjectKind <$> [faceObject, edgeObject, vertexObject]+          case kinds of+            [FaceObject, EdgeObject, VertexObject] ->+              Right+                FlagSelection+                  { selectedSimplexIdentifier = nerveSimplexIdentifier simplexValue,+                    selectedFace = faceObject,+                    selectedEdge = edgeObject,+                    selectedVertex = vertexObject,+                    selectedObjectIdentifiers = Set.fromList identifiers+                  }+            _ -> Left (PictureMalformedFlagKinds kinds)+        identifiers ->+          Left+            ( PictureMalformedNerveTwoSimplex+                (nerveSimplexIdentifier simplexValue)+                identifiers+            )++lookupCategoryObject ::+  Map.Map String CategoryObject ->+  String ->+  Either PictureObstruction CategoryObject+lookupCategoryObject categoryObjectsByIdentifier identifier =+  maybe+    (Left (PictureMissingCategoryObject identifier))+    Right+    (Map.lookup identifier categoryObjectsByIdentifier)++renderPicture :: PictureContext -> String+renderPicture context =+  unlines+    ( renderDocumentOpening+        <> renderHeader context+        <> renderPanels context+        <> renderNerveProfile context+        <> ["</svg>"]+    )++renderDocumentOpening :: [String]+renderDocumentOpening =+  [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>",+    "<svg xmlns=\"http://www.w3.org/2000/svg\" viewBox=\"0 0 1440 920\" role=\"img\" aria-labelledby=\"title description\">",+    "<title id=\"title\">Moonlight category observatory</title>",+    "<desc id=\"description\">One checked Delaunay section shown as geometry, a local face-edge-vertex incidence flag, and the full path-sensitive flag nerve.</desc>",+    "<defs>",+    "  <linearGradient id=\"background\" x1=\"0\" y1=\"0\" x2=\"1\" y2=\"1\"><stop stop-color=\"#10262a\"/><stop offset=\"0.48\" stop-color=\"#071217\"/><stop offset=\"1\" stop-color=\"#120f20\"/></linearGradient>",+    "  <radialGradient id=\"cyan-glow\"><stop stop-color=\"#72d6c2\" stop-opacity=\"0.22\"/><stop offset=\"1\" stop-color=\"#72d6c2\" stop-opacity=\"0\"/></radialGradient>",+    "  <radialGradient id=\"violet-glow\"><stop stop-color=\"#bc8cff\" stop-opacity=\"0.22\"/><stop offset=\"1\" stop-color=\"#bc8cff\" stop-opacity=\"0\"/></radialGradient>",+    "  <pattern id=\"grid\" width=\"28\" height=\"28\" patternUnits=\"userSpaceOnUse\"><path d=\"M28 0H0V28\" fill=\"none\" stroke=\"#9bc7bd\" stroke-opacity=\"0.07\" stroke-width=\"1\"/></pattern>",+    "  <marker id=\"arrow\" viewBox=\"0 0 10 10\" refX=\"8\" refY=\"5\" markerWidth=\"7\" markerHeight=\"7\" orient=\"auto-start-reverse\"><path d=\"M0 0L10 5L0 10Z\" fill=\"#72d6c2\"/></marker>",+    "  <filter id=\"soft-shadow\" x=\"-20%\" y=\"-20%\" width=\"140%\" height=\"140%\"><feDropShadow dx=\"0\" dy=\"8\" stdDeviation=\"12\" flood-color=\"#000\" flood-opacity=\"0.28\"/></filter>",+    "  <style><![CDATA[",+    "    .sans{font-family:Inter,ui-sans-serif,system-ui,-apple-system,BlinkMacSystemFont,sans-serif}",+    "    .serif{font-family:Georgia,'Times New Roman',serif}",+    "    .mono{font-family:ui-monospace,SFMono-Regular,Menlo,monospace}",+    "    .panel{fill:#0a181d;fill-opacity:.93;stroke:#8bbeb2;stroke-opacity:.22;stroke-width:1.2}",+    "    .kicker{fill:#72d6c2;font-size:12px;font-weight:700;letter-spacing:2.8px}",+    "    .title{fill:#f1eee7;font-size:48px;font-weight:400;letter-spacing:-1.4px}",+    "    .subtitle{fill:#9ab0aa;font-size:16px}",+    "    .panel-number{fill:#72d6c2;font-size:11px;font-weight:700;letter-spacing:1.6px}",+    "    .panel-title{fill:#f1eee7;font-size:25px}",+    "    .callout-title{fill:#f1eee7;font-size:21px}",+    "    .panel-note{fill:#8ca49f;font-size:12px}",+    "    .metric-value{fill:#f1eee7;font-size:18px;font-weight:700}",+    "    .metric-label{fill:#8ca49f;font-size:9px;font-weight:700;letter-spacing:1.2px}",+    "    .mesh-face{fill:#72d6c2;fill-opacity:.035;stroke:none}",+    "    .mesh-face.selected{fill:#ffad66;fill-opacity:.28}",+    "    .mesh-edge{stroke:#72d6c2;stroke-opacity:.58;stroke-width:1.7}",+    "    .mesh-edge.selected{stroke:#ffad66;stroke-opacity:1;stroke-width:5}",+    "    .mesh-vertex{fill:#071217;stroke:#f2e37e;stroke-width:2.2}",+    "    .mesh-vertex.selected{fill:#f2e37e;stroke:#fff7b0;stroke-width:4}",+    "    .nerve-simplex{fill:#bc8cff;fill-opacity:.065;stroke:#bc8cff;stroke-opacity:.42;stroke-width:1.1}",+    "    .nerve-simplex.selected{fill:#ffad66;fill-opacity:.48;stroke:#ffd1a8;stroke-opacity:1;stroke-width:3}",+    "    .object-face{fill:#ffad66}.object-edge{fill:#72d6c2}.object-vertex{fill:#f2e37e}",+    "    .node-label{fill:#f1eee7;font-size:23px;font-weight:700}.node-kind{fill:#8ca49f;font-size:10px;font-weight:700;letter-spacing:1.4px}",+    "    .profile-label{fill:#8ca49f;font-size:11px;font-weight:700;letter-spacing:1px}.profile-value{fill:#f1eee7;font-size:12px;font-weight:700}",+    "  ]]></style>",+    "</defs>",+    "<rect width=\"1440\" height=\"920\" fill=\"url(#background)\"/>",+    "<circle cx=\"180\" cy=\"110\" r=\"290\" fill=\"url(#cyan-glow)\"/>",+    "<circle cx=\"1290\" cy=\"520\" r=\"360\" fill=\"url(#violet-glow)\"/>"+  ]++renderHeader :: PictureContext -> [String]+renderHeader context =+  [ svgText "mono kicker" 56 38 "start" "MOONLIGHT / FINITE DESCENT",+    svgText "serif title" 56 94 "start" "One section, three faithful projections",+    svgText+      "sans subtitle"+      57+      127+      "start"+      "Delaunay geometry → incidence category → path-sensitive flag nerve"+  ]+    <> concat+      ( zipWith+          renderMetric+          [56, 212, 368, 524, 680, 856]+          (pictureMetrics context)+      )+    <> [ "<path d=\"M1040 163H1378\" stroke=\"#72d6c2\" stroke-opacity=\".24\"/>",+         svgText "mono panel-note" 1378 168 "end" "ONE HIGHLIGHTED FLAG GLUES ALL THREE PANELS"+       ]++data PictureMetric = PictureMetric+  { metricValue :: !Int,+    metricLabel :: !String+  }++pictureMetrics :: PictureContext -> [PictureMetric]+pictureMetrics context =+  let exhibit = contextExhibit context+      meshProjection = mesh exhibit+      categoryProjection = category exhibit+      nerveProjection = nerve exhibit+   in [ PictureMetric (length (meshVertices meshProjection)) "VERTICES",+        PictureMetric (length (meshEdges meshProjection)) "EDGES",+        PictureMetric (length (meshFaces meshProjection)) "FACES",+        PictureMetric (length (categoryObjects categoryProjection)) "OBJECTS",+        PictureMetric (length (categoryMorphisms categoryProjection)) "MORPHISMS",+        PictureMetric (length (nerveTwoSimplices nerveProjection)) "FLAGS"+      ]++renderMetric :: Double -> PictureMetric -> [String]+renderMetric x metric =+  [ "<g transform=\"translate(" <> coordinate x <> " 151)\">",+    "  <rect width=\"136\" height=\"48\" rx=\"13\" fill=\"#0b1b20\" stroke=\"#8bbeb2\" stroke-opacity=\".17\"/>",+    "  " <> svgText "sans metric-value" 16 22 "start" (show (metricValue metric)),+    "  " <> svgText "mono metric-label" 16 38 "start" (metricLabel metric),+    "</g>"+  ]++renderPanels :: PictureContext -> [String]+renderPanels context =+  renderPanelBackgrounds+    <> renderGeometryPanel context+    <> renderCategoryPanel (contextFlag context)+    <> renderNervePanel context++renderPanelBackgrounds :: [String]+renderPanelBackgrounds =+  concatMap+    (\x -> ["<rect class=\"panel\" x=\"" <> coordinate x <> "\" y=\"222\" width=\"410\" height=\"470\" rx=\"22\" filter=\"url(#soft-shadow)\"/>"])+    [50, 515, 980]++renderGeometryPanel :: PictureContext -> [String]+renderGeometryPanel context =+  renderPanelHeader 50 "01" "Geometric section" "the admitted Delaunay cells"+    <> ["<rect x=\"70\" y=\"326\" width=\"370\" height=\"330\" rx=\"15\" fill=\"url(#grid)\"/>"]+    <> fmap (renderMeshFace context geometryFrame) (contextFaces context)+    <> fmap (renderMeshEdge context geometryFrame) (contextEdges context)+    <> fmap (renderMeshVertex context geometryFrame) (meshVertices (mesh (contextExhibit context)))+    <> renderGeometrySelectionLabels context++geometryFrame :: PictureFrame+geometryFrame = PictureFrame 83 341 344 290++renderMeshFace :: PictureContext -> PictureFrame -> ResolvedMeshFace -> String+renderMeshFace context frame faceValue =+  let selected =+        Set.member+          (meshFaceObjectIdentifier (resolvedFace faceValue))+          (selectedObjectIdentifiers (contextFlag context))+   in "<polygon class=\"mesh-face"+        <> selectedClass selected+        <> "\" points=\""+        <> renderPointList (contextBounds context) frame (resolvedFaceVertices faceValue)+        <> "\"/>"++renderMeshEdge :: PictureContext -> PictureFrame -> ResolvedMeshEdge -> String+renderMeshEdge context frame edgeValue =+  let selected =+        Set.member+          (meshEdgeObjectIdentifier (resolvedEdge edgeValue))+          (selectedObjectIdentifiers (contextFlag context))+      (sourceX, sourceY) = projectPosition (contextBounds context) frame (resolvedEdgeSource edgeValue)+      (targetX, targetY) = projectPosition (contextBounds context) frame (resolvedEdgeTarget edgeValue)+   in "<line class=\"mesh-edge"+        <> selectedClass selected+        <> "\" x1=\""+        <> coordinate sourceX+        <> "\" y1=\""+        <> coordinate sourceY+        <> "\" x2=\""+        <> coordinate targetX+        <> "\" y2=\""+        <> coordinate targetY+        <> "\"/>"++renderMeshVertex :: PictureContext -> PictureFrame -> MeshVertex -> String+renderMeshVertex context frame vertexValue =+  let selected =+        Set.member+          (meshVertexObjectIdentifier vertexValue)+          (selectedObjectIdentifiers (contextFlag context))+      (x, y) = projectPosition (contextBounds context) frame (meshVertexPosition vertexValue)+   in "<circle class=\"mesh-vertex"+        <> selectedClass selected+        <> "\" cx=\""+        <> coordinate x+        <> "\" cy=\""+        <> coordinate y+        <> "\" r=\""+        <> if selected then "7\"/>" else "4.5\"/>"++renderGeometrySelectionLabels :: PictureContext -> [String]+renderGeometrySelectionLabels context =+  let flag = contextFlag context+      labelledObjects = [selectedFace flag, selectedEdge flag, selectedVertex flag]+   in fmap+        (\objectValue ->+           let (x, y) = projectPosition (contextBounds context) geometryFrame (categoryObjectPosition objectValue)+            in svgText+                 "mono profile-value"+                 (x + 10)+                 (y - 10)+                 "start"+                 (categoryObjectLabel objectValue)+        )+        labelledObjects++renderCategoryPanel :: FlagSelection -> [String]+renderCategoryPanel flag =+  renderPanelHeader 515 "02" "Incidence category" "one local section; no arrow thicket"+    <> [ svgText "mono panel-note" 720 334 "middle" "SELECTED NONDEGENERATE CHAIN",+         "<path d=\"M621 463H686\" stroke=\"#72d6c2\" stroke-width=\"2.5\" marker-end=\"url(#arrow)\"/>",+         "<path d=\"M754 463H817\" stroke=\"#72d6c2\" stroke-width=\"2.5\" marker-end=\"url(#arrow)\"/>",+         "<path d=\"M609 421C665 365 794 365 850 421\" fill=\"none\" stroke=\"#bc8cff\" stroke-opacity=\".68\" stroke-width=\"1.6\" stroke-dasharray=\"6 7\" marker-end=\"url(#arrow)\"/>",+         "<rect x=\"556\" y=\"430\" width=\"66\" height=\"66\" rx=\"14\" fill=\"#ffad66\" fill-opacity=\".18\" stroke=\"#ffad66\" stroke-width=\"2\"/>",+         "<rect x=\"696\" y=\"439\" width=\"48\" height=\"48\" transform=\"rotate(45 720 463)\" fill=\"#72d6c2\" fill-opacity=\".16\" stroke=\"#72d6c2\" stroke-width=\"2\"/>",+         "<circle cx=\"850\" cy=\"463\" r=\"31\" fill=\"#f2e37e\" fill-opacity=\".14\" stroke=\"#f2e37e\" stroke-width=\"2\"/>",+         svgText "mono node-kind" 589 407 "middle" "FACE OBJECT",+         svgText "sans node-label" 589 471 "middle" (categoryObjectLabel (selectedFace flag)),+         svgText "mono node-kind" 720 407 "middle" "EDGE OBJECT",+         svgText "sans node-label" 720 471 "middle" (categoryObjectLabel (selectedEdge flag)),+         svgText "mono node-kind" 850 407 "middle" "VERTEX OBJECT",+         svgText "sans node-label" 850 471 "middle" (categoryObjectLabel (selectedVertex flag)),+         svgText "mono panel-note" 720 535 "middle" "face → edge → vertex",+         "<rect x=\"552\" y=\"570\" width=\"336\" height=\"78\" rx=\"14\" fill=\"#071217\" stroke=\"#bc8cff\" stroke-opacity=\".28\"/>",+         svgText "serif callout-title" 720 602 "middle" "The intermediate edge survives.",+         svgText "sans panel-note" 720 628 "middle" "Same endpoints, different paths, distinct flags."+       ]++renderNervePanel :: PictureContext -> [String]+renderNervePanel context =+  renderPanelHeader 980 "03" "Flag nerve" "all 66 admitted two-simplices"+    <> ["<rect x=\"1000\" y=\"326\" width=\"370\" height=\"330\" rx=\"15\" fill=\"url(#grid)\"/>"]+    <> fmap (renderNerveSimplex context nerveFrame) (contextNerveSimplices context)+    <> fmap (renderNerveObject context nerveFrame) (categoryObjects (category (contextExhibit context)))+    <> renderNerveSelectionLabel context++nerveFrame :: PictureFrame+nerveFrame = PictureFrame 1013 341 344 290++renderNerveSimplex :: PictureContext -> PictureFrame -> ResolvedNerveSimplex -> String+renderNerveSimplex context frame simplexValue =+  let selected =+        nerveSimplexIdentifier (resolvedSimplex simplexValue)+          == selectedSimplexIdentifier (contextFlag context)+   in "<polygon class=\"nerve-simplex"+        <> selectedClass selected+        <> "\" points=\""+        <> renderPointList (contextBounds context) frame (resolvedSimplexVertices simplexValue)+        <> "\"/>"++renderNerveObject :: PictureContext -> PictureFrame -> CategoryObject -> String+renderNerveObject context frame objectValue =+  let selected =+        Set.member+          (categoryObjectIdentifier objectValue)+          (selectedObjectIdentifiers (contextFlag context))+      (x, y) = projectPosition (contextBounds context) frame (categoryObjectPosition objectValue)+      radius = if selected then 6 else 3.4+   in "<circle class=\""+        <> objectKindClass (categoryObjectKind objectValue)+        <> "\" cx=\""+        <> coordinate x+        <> "\" cy=\""+        <> coordinate y+        <> "\" r=\""+        <> coordinate radius+        <> "\" opacity=\""+        <> if selected then "1\" stroke=\"#fff\" stroke-width=\"2\"/>" else ".78\"/>"++renderNerveSelectionLabel :: PictureContext -> [String]+renderNerveSelectionLabel context =+  let flag = contextFlag context+      faceObject = selectedFace flag+      (x, y) = projectPosition (contextBounds context) nerveFrame (categoryObjectPosition faceObject)+   in [ svgText "mono profile-value" (x + 12) (y - 12) "start" "selected flag",+        svgText "mono panel-note" 1352 642 "end" (selectedSimplexIdentifier flag)+      ]++renderPanelHeader :: Double -> String -> String -> String -> [String]+renderPanelHeader x number titleText note =+  [ svgText "mono panel-number" (x + 22) 254 "start" number,+    svgText "serif panel-title" (x + 22) 282 "start" titleText,+    svgText "sans panel-note" (x + 22) 304 "start" note,+    "<path d=\"M"+      <> coordinate (x + 20)+      <> " 314H"+      <> coordinate (x + 390)+      <> "\" stroke=\"#8bbeb2\" stroke-opacity=\".14\"/>"+  ]++renderNerveProfile :: PictureContext -> [String]+renderNerveProfile context =+  let counts = nerveSimplexCounts (nerve (contextExhibit context))+      maximumCount =+        foldl'+          (\current count -> max current (unnormalizedSimplexCount count))+          1+          counts+   in [ "<rect x=\"50\" y=\"720\" width=\"1340\" height=\"156\" rx=\"22\" fill=\"#09171c\" stroke=\"#8bbeb2\" stroke-opacity=\".20\"/>",+        svgText "mono kicker" 76 752 "start" "NORMALIZATION PROFILE",+        svgText "serif panel-title" 76 789 "start" "Identity insertions are cost, not geometry.",+        svgText "sans panel-note" 76 817 "start" "Identity insertions swell dimension two to 385.",+        "<rect x=\"76\" y=\"838\" width=\"12\" height=\"4\" rx=\"2\" fill=\"#72d6c2\"/>",+        svgText "mono profile-label" 96 845 "start" "NORMALIZED",+        "<rect x=\"196\" y=\"838\" width=\"12\" height=\"4\" rx=\"2\" fill=\"#bc8cff\"/>",+        svgText "mono profile-label" 216 845 "start" "UNNORMALIZED"+      ]+        <> concat+          ( zipWith+              (renderProfileRow maximumCount)+              [770, 814, 858]+              counts+          )++renderProfileRow :: Int -> Double -> NerveSimplexCount -> [String]+renderProfileRow maximumCount y count =+  let normalizedWidth = profileWidth maximumCount (normalizedSimplexCount count)+      unnormalizedWidth = profileWidth maximumCount (unnormalizedSimplexCount count)+   in [ svgText "mono profile-label" 590 (y + 5) "end" ("DIM " <> show (nerveDimension count)),+        "<rect x=\"615\" y=\"" <> coordinate (y - 8) <> "\" width=\"230\" height=\"11\" rx=\"5.5\" fill=\"#13272d\"/>",+        "<rect x=\"615\" y=\"" <> coordinate (y - 8) <> "\" width=\"" <> coordinate normalizedWidth <> "\" height=\"11\" rx=\"5.5\" fill=\"#72d6c2\"/>",+        svgText "mono profile-value" 858 (y + 3) "start" (show (normalizedSimplexCount count)),+        "<rect x=\"965\" y=\"" <> coordinate (y - 8) <> "\" width=\"310\" height=\"11\" rx=\"5.5\" fill=\"#1d1830\"/>",+        "<rect x=\"965\" y=\"" <> coordinate (y - 8) <> "\" width=\"" <> coordinate (unnormalizedWidth * 310 / 230) <> "\" height=\"11\" rx=\"5.5\" fill=\"#bc8cff\"/>",+        svgText "mono profile-value" 1288 (y + 3) "start" (show (unnormalizedSimplexCount count))+      ]++profileWidth :: Int -> Int -> Double+profileWidth maximumCount count =+  230 * fromIntegral count / fromIntegral maximumCount++projectPosition :: PictureBounds -> PictureFrame -> Position -> (Double, Double)+projectPosition bounds frame positionValue =+  ( frameLeft frame+      + frameWidth frame+        * normalizedCoordinate (positionX positionValue) (minimumX bounds) (maximumX bounds),+    frameTop frame+      + frameHeight frame+        * normalizedCoordinate (positionY positionValue) (minimumY bounds) (maximumY bounds)+  )++normalizedCoordinate :: Double -> Double -> Double -> Double+normalizedCoordinate value minimumValue maximumValue =+  if maximumValue == minimumValue+    then 0.5+    else (value - minimumValue) / (maximumValue - minimumValue)++renderPointList :: PictureBounds -> PictureFrame -> [Position] -> String+renderPointList bounds frame =+  unwords+    . fmap+      (\positionValue ->+         let (x, y) = projectPosition bounds frame positionValue+          in coordinate x <> "," <> coordinate y+      )++selectedClass :: Bool -> String+selectedClass selected = if selected then " selected" else ""++objectKindClass :: CategoryObjectKind -> String+objectKindClass = \case+  FaceObject -> "object-face"+  EdgeObject -> "object-edge"+  VertexObject -> "object-vertex"++svgText :: String -> Double -> Double -> String -> String -> String+svgText classes x y anchor contents =+  "<text class=\""+    <> classes+    <> "\" x=\""+    <> coordinate x+    <> "\" y=\""+    <> coordinate y+    <> "\" text-anchor=\""+    <> anchor+    <> "\">"+    <> escapeXml contents+    <> "</text>"++coordinate :: Double -> String+coordinate value = showFFloat (Just 1) value ""++escapeXml :: String -> String+escapeXml = concatMap escapeCharacter++escapeCharacter :: Char -> String+escapeCharacter = \case+  '&' -> "&amp;"+  '<' -> "&lt;"+  '>' -> "&gt;"+  '\"' -> "&quot;"+  '\'' -> "&apos;"+  character -> [character]
+ docs/category-observatory/README.md view
@@ -0,0 +1,142 @@+# Moonlight category observatory++![The Moonlight category observatory showing one Delaunay cell selection as geometry, its incidence category, and its flag nerve](./moonlight-triangulation-category-observatory.svg)++[Browse all exhibits.](../README.md)+· [Read the package operation index.](../../README.md#operations)++The category observatory follows one checked finite section through three+synchronized views: the selected Delaunay cells, their incidence category, and+the normalized nerve of that category. The visual above is the package-owned+compact SVG projection of the same admitted `Exhibit`: one face-edge-vertex+flag is restricted through all three panels while the full mesh and 66+two-simplices remain visible. It is neither a viewport screenshot nor a second+mathematical model.++## Cell-complex and category interpretation++The `cell-complex` component interprets an `ExactCellSet` as Homology's generic+`CellComplex2D`. The opaque carrier retains the authoritative selected handles+and resident DCEL. `fromExactCellSet` is total because `ExactCellSet`+construction has already discharged downward closure and handle validity.++The interpretation is available on GHC 9.14 and newer. Existing Triangulation+components retain the package's GHC 9.8–9.14 support range: below 9.14 Cabal+marks only `cell-complex`, its focused test, and the category-observatory+exporter unbuildable. Hackage aggregates dependencies from every component on+the package page, but an ordinary main-library consumer does not inherit the+Homology or Category closure.++```cabal+-- the consumer package+build-depends:+  base >= 4.22 && < 5,+  moonlight-triangulation >= 1.4 && < 1.5,+  moonlight-planar:cell-complex >= 1.0 && < 1.1,+  moonlight-homology:cell-category >= 0.1 && < 0.2+```++```haskell+import Moonlight.Homology.Pure.Topology.CellCategory (complexCategory)+import Moonlight.Triangulation.CellComplex (fromExactCellSet)++incidenceCategory = complexCategory . fromExactCellSet+```++## What owns what++The executable composes existing owners in one direction:++```text+ExactCellSet+  -> Moonlight.Triangulation.CellComplex.DCELComplex+  -> Moonlight.Homology.Pure.Topology.CellCategory.ComplexCat+  -> Moonlight.Category.Simplicial.normalizedNerve+  -> checked schema-version-2 JSON+  -> Melusine's /category browser projection+```++`moonlight-triangulation-category-observatory-export` owns only the checked+projection boundary. Geometry remains in Triangulation, the generic+two-dimensional cell interface and incidence category remain in Homology, and+the browser remains a derived view. There is no observatory-specific mesh,+category implementation, or nerve implementation lurking behind the scenery.++## Deterministic witness++The retained ten-point section yields:++| observation | count |+| --- | ---: |+| vertices | 10 |+| undirected edges | 20 |+| bounded faces | 11 |+| category objects | 41 |+| category morphisms | 180 |+| face-edge-vertex incidence flags | 66 |++The normalized and identity-saturated unnormalized nerves contain respectively+`41 / 41`, `139 / 180`, and `66 / 385` simplices in dimensions 0, 1, and 2.+Each rendered 2-simplex retains its intermediate edge; this is the+path-sensitive incidence flag nerve, not a thinned face poset.++Before encoding, the pure builder checks the selected-cell inventory, the four+morphism classes, every morphism endpoint, every 2-simplex shape, and equality+between the face-incidence and rendered-flag counts. Failures inhabit+`ExhibitError`; stdout receives JSON only after those local sections glue.++## Run the exporter++The Homology-backed component requires GHC 9.14 or newer. From the repository+root:++```console+scripts/safe-cabal.sh run \+  moonlight-planar:exe:moonlight-triangulation-category-observatory-export \+  --project-file=cabal.project.planar-dev+```++That command emits the deterministic schema-version-2 document to stdout. To+regenerate or verify the retained documentation picture:++```console+scripts/safe-cabal.sh run \+  moonlight-planar:exe:moonlight-triangulation-category-observatory-export \+  --project-file=cabal.project.planar-dev -- \+  picture compiler/foundation/moonlight-planar/docs/category-observatory/moonlight-triangulation-category-observatory.svg+scripts/safe-cabal.sh run \+  moonlight-planar:exe:moonlight-triangulation-category-observatory-export \+  --project-file=cabal.project.planar-dev -- \+  verify-artifacts compiler/foundation/moonlight-planar+```++To run the interactive browser consumer:++```console+cd compiler/engine/melusine-visualization+pnpm dev:category+```++Open `http://127.0.0.1:5173/category`. Hovering a cell, category arrow, or flag+restricts the other two panels to the same semantic objects; the dimension+control reveals the normalized 0-, 1-, and 2-simplex sections.++## Source decomposition++`Main.hs` is only the `IO` edge: render a typed obstruction or encode the+admitted exhibit. The pure implementation is split by mathematical+responsibility:++| module | responsibility |+| --- | --- |+| `Moonlight.Triangulation.Exhibit.CategoryObservatory` | deterministic witness and final descent |+| `.Model` | JSON projection types and typed obstructions |+| `.Geometry` | mesh projection and geometric object placement |+| `.Category` | finite object/morphism projection and inventory law |+| `.Nerve` | normalized/unnormalized nerve projection and flag law |+| `.Identifier` | the single identifier/label interpretation shared by all projections |+| `.Picture` | compact pure SVG projection of the admitted exhibit |++The split is semantic rather than ceremonial: no wrapper modules, no duplicate+projection types, no hand-maintained duplicate mesh coordinates, and no mutable+orchestration wearing an expensive hat.
+ docs/category-observatory/moonlight-triangulation-category-observatory.svg view
@@ -0,0 +1,293 @@+<?xml version="1.0" encoding="utf-8"?>+<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 1440 920" role="img" aria-labelledby="title description">+<title id="title">Moonlight category observatory</title>+<desc id="description">One checked Delaunay section shown as geometry, a local face-edge-vertex incidence flag, and the full path-sensitive flag nerve.</desc>+<defs>+  <linearGradient id="background" x1="0" y1="0" x2="1" y2="1"><stop stop-color="#10262a"/><stop offset="0.48" stop-color="#071217"/><stop offset="1" stop-color="#120f20"/></linearGradient>+  <radialGradient id="cyan-glow"><stop stop-color="#72d6c2" stop-opacity="0.22"/><stop offset="1" stop-color="#72d6c2" stop-opacity="0"/></radialGradient>+  <radialGradient id="violet-glow"><stop stop-color="#bc8cff" stop-opacity="0.22"/><stop offset="1" stop-color="#bc8cff" stop-opacity="0"/></radialGradient>+  <pattern id="grid" width="28" height="28" patternUnits="userSpaceOnUse"><path d="M28 0H0V28" fill="none" stroke="#9bc7bd" stroke-opacity="0.07" stroke-width="1"/></pattern>+  <marker id="arrow" viewBox="0 0 10 10" refX="8" refY="5" markerWidth="7" markerHeight="7" orient="auto-start-reverse"><path d="M0 0L10 5L0 10Z" fill="#72d6c2"/></marker>+  <filter id="soft-shadow" x="-20%" y="-20%" width="140%" height="140%"><feDropShadow dx="0" dy="8" stdDeviation="12" flood-color="#000" flood-opacity="0.28"/></filter>+  <style><![CDATA[+    .sans{font-family:Inter,ui-sans-serif,system-ui,-apple-system,BlinkMacSystemFont,sans-serif}+    .serif{font-family:Georgia,'Times New Roman',serif}+    .mono{font-family:ui-monospace,SFMono-Regular,Menlo,monospace}+    .panel{fill:#0a181d;fill-opacity:.93;stroke:#8bbeb2;stroke-opacity:.22;stroke-width:1.2}+    .kicker{fill:#72d6c2;font-size:12px;font-weight:700;letter-spacing:2.8px}+    .title{fill:#f1eee7;font-size:48px;font-weight:400;letter-spacing:-1.4px}+    .subtitle{fill:#9ab0aa;font-size:16px}+    .panel-number{fill:#72d6c2;font-size:11px;font-weight:700;letter-spacing:1.6px}+    .panel-title{fill:#f1eee7;font-size:25px}+    .callout-title{fill:#f1eee7;font-size:21px}+    .panel-note{fill:#8ca49f;font-size:12px}+    .metric-value{fill:#f1eee7;font-size:18px;font-weight:700}+    .metric-label{fill:#8ca49f;font-size:9px;font-weight:700;letter-spacing:1.2px}+    .mesh-face{fill:#72d6c2;fill-opacity:.035;stroke:none}+    .mesh-face.selected{fill:#ffad66;fill-opacity:.28}+    .mesh-edge{stroke:#72d6c2;stroke-opacity:.58;stroke-width:1.7}+    .mesh-edge.selected{stroke:#ffad66;stroke-opacity:1;stroke-width:5}+    .mesh-vertex{fill:#071217;stroke:#f2e37e;stroke-width:2.2}+    .mesh-vertex.selected{fill:#f2e37e;stroke:#fff7b0;stroke-width:4}+    .nerve-simplex{fill:#bc8cff;fill-opacity:.065;stroke:#bc8cff;stroke-opacity:.42;stroke-width:1.1}+    .nerve-simplex.selected{fill:#ffad66;fill-opacity:.48;stroke:#ffd1a8;stroke-opacity:1;stroke-width:3}+    .object-face{fill:#ffad66}.object-edge{fill:#72d6c2}.object-vertex{fill:#f2e37e}+    .node-label{fill:#f1eee7;font-size:23px;font-weight:700}.node-kind{fill:#8ca49f;font-size:10px;font-weight:700;letter-spacing:1.4px}+    .profile-label{fill:#8ca49f;font-size:11px;font-weight:700;letter-spacing:1px}.profile-value{fill:#f1eee7;font-size:12px;font-weight:700}+  ]]></style>+</defs>+<rect width="1440" height="920" fill="url(#background)"/>+<circle cx="180" cy="110" r="290" fill="url(#cyan-glow)"/>+<circle cx="1290" cy="520" r="360" fill="url(#violet-glow)"/>+<text class="mono kicker" x="56.0" y="38.0" text-anchor="start">MOONLIGHT / FINITE DESCENT</text>+<text class="serif title" x="56.0" y="94.0" text-anchor="start">One section, three faithful projections</text>+<text class="sans subtitle" x="57.0" y="127.0" text-anchor="start">Delaunay geometry → incidence category → path-sensitive flag nerve</text>+<g transform="translate(56.0 151)">+  <rect width="136" height="48" rx="13" fill="#0b1b20" stroke="#8bbeb2" stroke-opacity=".17"/>+  <text class="sans metric-value" x="16.0" y="22.0" text-anchor="start">10</text>+  <text class="mono metric-label" x="16.0" y="38.0" text-anchor="start">VERTICES</text>+</g>+<g transform="translate(212.0 151)">+  <rect width="136" height="48" rx="13" fill="#0b1b20" stroke="#8bbeb2" stroke-opacity=".17"/>+  <text class="sans metric-value" x="16.0" y="22.0" text-anchor="start">20</text>+  <text class="mono metric-label" x="16.0" y="38.0" text-anchor="start">EDGES</text>+</g>+<g transform="translate(368.0 151)">+  <rect width="136" height="48" rx="13" fill="#0b1b20" stroke="#8bbeb2" stroke-opacity=".17"/>+  <text class="sans metric-value" x="16.0" y="22.0" text-anchor="start">11</text>+  <text class="mono metric-label" x="16.0" y="38.0" text-anchor="start">FACES</text>+</g>+<g transform="translate(524.0 151)">+  <rect width="136" height="48" rx="13" fill="#0b1b20" stroke="#8bbeb2" stroke-opacity=".17"/>+  <text class="sans metric-value" x="16.0" y="22.0" text-anchor="start">41</text>+  <text class="mono metric-label" x="16.0" y="38.0" text-anchor="start">OBJECTS</text>+</g>+<g transform="translate(680.0 151)">+  <rect width="136" height="48" rx="13" fill="#0b1b20" stroke="#8bbeb2" stroke-opacity=".17"/>+  <text class="sans metric-value" x="16.0" y="22.0" text-anchor="start">180</text>+  <text class="mono metric-label" x="16.0" y="38.0" text-anchor="start">MORPHISMS</text>+</g>+<g transform="translate(856.0 151)">+  <rect width="136" height="48" rx="13" fill="#0b1b20" stroke="#8bbeb2" stroke-opacity=".17"/>+  <text class="sans metric-value" x="16.0" y="22.0" text-anchor="start">66</text>+  <text class="mono metric-label" x="16.0" y="38.0" text-anchor="start">FLAGS</text>+</g>+<path d="M1040 163H1378" stroke="#72d6c2" stroke-opacity=".24"/>+<text class="mono panel-note" x="1378.0" y="168.0" text-anchor="end">ONE HIGHLIGHTED FLAG GLUES ALL THREE PANELS</text>+<rect class="panel" x="50.0" y="222" width="410" height="470" rx="22" filter="url(#soft-shadow)"/>+<rect class="panel" x="515.0" y="222" width="410" height="470" rx="22" filter="url(#soft-shadow)"/>+<rect class="panel" x="980.0" y="222" width="410" height="470" rx="22" filter="url(#soft-shadow)"/>+<text class="mono panel-number" x="72.0" y="254.0" text-anchor="start">01</text>+<text class="serif panel-title" x="72.0" y="282.0" text-anchor="start">Geometric section</text>+<text class="sans panel-note" x="72.0" y="304.0" text-anchor="start">the admitted Delaunay cells</text>+<path d="M70.0 314H440.0" stroke="#8bbeb2" stroke-opacity=".14"/>+<rect x="70" y="326" width="370" height="330" rx="15" fill="url(#grid)"/>+<polygon class="mesh-face selected" points="200.8,452.8 328.2,475.6 278.8,593.1"/>+<polygon class="mesh-face" points="328.2,475.6 200.8,452.8 244.5,341.0"/>+<polygon class="mesh-face" points="328.2,475.6 244.5,341.0 377.6,382.7"/>+<polygon class="mesh-face" points="200.8,452.8 278.8,593.1 140.0,608.3"/>+<polygon class="mesh-face" points="278.8,593.1 328.2,475.6 427.0,515.4"/>+<polygon class="mesh-face" points="427.0,515.4 328.2,475.6 377.6,382.7"/>+<polygon class="mesh-face" points="200.8,452.8 140.0,608.3 83.0,492.6"/>+<polygon class="mesh-face" points="244.5,341.0 200.8,452.8 109.6,363.7"/>+<polygon class="mesh-face" points="109.6,363.7 200.8,452.8 83.0,492.6"/>+<polygon class="mesh-face" points="278.8,593.1 427.0,515.4 394.7,631.0"/>+<polygon class="mesh-face" points="140.0,608.3 278.8,593.1 394.7,631.0"/>+<line class="mesh-edge selected" x1="200.8" y1="452.8" x2="328.2" y2="475.6"/>+<line class="mesh-edge" x1="200.8" y1="452.8" x2="278.8" y2="593.1"/>+<line class="mesh-edge" x1="328.2" y1="475.6" x2="278.8" y2="593.1"/>+<line class="mesh-edge" x1="328.2" y1="475.6" x2="244.5" y2="341.0"/>+<line class="mesh-edge" x1="200.8" y1="452.8" x2="244.5" y2="341.0"/>+<line class="mesh-edge" x1="328.2" y1="475.6" x2="377.6" y2="382.7"/>+<line class="mesh-edge" x1="244.5" y1="341.0" x2="377.6" y2="382.7"/>+<line class="mesh-edge" x1="200.8" y1="452.8" x2="140.0" y2="608.3"/>+<line class="mesh-edge" x1="278.8" y1="593.1" x2="140.0" y2="608.3"/>+<line class="mesh-edge" x1="278.8" y1="593.1" x2="427.0" y2="515.4"/>+<line class="mesh-edge" x1="328.2" y1="475.6" x2="427.0" y2="515.4"/>+<line class="mesh-edge" x1="427.0" y1="515.4" x2="377.6" y2="382.7"/>+<line class="mesh-edge" x1="200.8" y1="452.8" x2="83.0" y2="492.6"/>+<line class="mesh-edge" x1="140.0" y1="608.3" x2="83.0" y2="492.6"/>+<line class="mesh-edge" x1="244.5" y1="341.0" x2="109.6" y2="363.7"/>+<line class="mesh-edge" x1="200.8" y1="452.8" x2="109.6" y2="363.7"/>+<line class="mesh-edge" x1="109.6" y1="363.7" x2="83.0" y2="492.6"/>+<line class="mesh-edge" x1="278.8" y1="593.1" x2="394.7" y2="631.0"/>+<line class="mesh-edge" x1="427.0" y1="515.4" x2="394.7" y2="631.0"/>+<line class="mesh-edge" x1="140.0" y1="608.3" x2="394.7" y2="631.0"/>+<circle class="mesh-vertex selected" cx="200.8" cy="452.8" r="7"/>+<circle class="mesh-vertex" cx="328.2" cy="475.6" r="4.5"/>+<circle class="mesh-vertex" cx="278.8" cy="593.1" r="4.5"/>+<circle class="mesh-vertex" cx="244.5" cy="341.0" r="4.5"/>+<circle class="mesh-vertex" cx="377.6" cy="382.7" r="4.5"/>+<circle class="mesh-vertex" cx="140.0" cy="608.3" r="4.5"/>+<circle class="mesh-vertex" cx="427.0" cy="515.4" r="4.5"/>+<circle class="mesh-vertex" cx="83.0" cy="492.6" r="4.5"/>+<circle class="mesh-vertex" cx="109.6" cy="363.7" r="4.5"/>+<circle class="mesh-vertex" cx="394.7" cy="631.0" r="4.5"/>+<text class="mono profile-value" x="279.3" y="497.2" text-anchor="start">f1</text>+<text class="mono profile-value" x="274.5" y="454.2" text-anchor="start">e0</text>+<text class="mono profile-value" x="210.8" y="442.8" text-anchor="start">v0</text>+<text class="mono panel-number" x="537.0" y="254.0" text-anchor="start">02</text>+<text class="serif panel-title" x="537.0" y="282.0" text-anchor="start">Incidence category</text>+<text class="sans panel-note" x="537.0" y="304.0" text-anchor="start">one local section; no arrow thicket</text>+<path d="M535.0 314H905.0" stroke="#8bbeb2" stroke-opacity=".14"/>+<text class="mono panel-note" x="720.0" y="334.0" text-anchor="middle">SELECTED NONDEGENERATE CHAIN</text>+<path d="M621 463H686" stroke="#72d6c2" stroke-width="2.5" marker-end="url(#arrow)"/>+<path d="M754 463H817" stroke="#72d6c2" stroke-width="2.5" marker-end="url(#arrow)"/>+<path d="M609 421C665 365 794 365 850 421" fill="none" stroke="#bc8cff" stroke-opacity=".68" stroke-width="1.6" stroke-dasharray="6 7" marker-end="url(#arrow)"/>+<rect x="556" y="430" width="66" height="66" rx="14" fill="#ffad66" fill-opacity=".18" stroke="#ffad66" stroke-width="2"/>+<rect x="696" y="439" width="48" height="48" transform="rotate(45 720 463)" fill="#72d6c2" fill-opacity=".16" stroke="#72d6c2" stroke-width="2"/>+<circle cx="850" cy="463" r="31" fill="#f2e37e" fill-opacity=".14" stroke="#f2e37e" stroke-width="2"/>+<text class="mono node-kind" x="589.0" y="407.0" text-anchor="middle">FACE OBJECT</text>+<text class="sans node-label" x="589.0" y="471.0" text-anchor="middle">f1</text>+<text class="mono node-kind" x="720.0" y="407.0" text-anchor="middle">EDGE OBJECT</text>+<text class="sans node-label" x="720.0" y="471.0" text-anchor="middle">e0</text>+<text class="mono node-kind" x="850.0" y="407.0" text-anchor="middle">VERTEX OBJECT</text>+<text class="sans node-label" x="850.0" y="471.0" text-anchor="middle">v0</text>+<text class="mono panel-note" x="720.0" y="535.0" text-anchor="middle">face → edge → vertex</text>+<rect x="552" y="570" width="336" height="78" rx="14" fill="#071217" stroke="#bc8cff" stroke-opacity=".28"/>+<text class="serif callout-title" x="720.0" y="602.0" text-anchor="middle">The intermediate edge survives.</text>+<text class="sans panel-note" x="720.0" y="628.0" text-anchor="middle">Same endpoints, different paths, distinct flags.</text>+<text class="mono panel-number" x="1002.0" y="254.0" text-anchor="start">03</text>+<text class="serif panel-title" x="1002.0" y="282.0" text-anchor="start">Flag nerve</text>+<text class="sans panel-note" x="1002.0" y="304.0" text-anchor="start">all 66 admitted two-simplices</text>+<path d="M1000.0 314H1370.0" stroke="#8bbeb2" stroke-opacity=".14"/>+<rect x="1000" y="326" width="370" height="330" rx="15" fill="url(#grid)"/>+<polygon class="nerve-simplex selected" points="1199.3,507.2 1194.5,464.2 1130.8,452.8"/>+<polygon class="nerve-simplex" points="1199.3,507.2 1194.5,464.2 1258.2,475.6"/>+<polygon class="nerve-simplex" points="1199.3,507.2 1233.5,534.3 1258.2,475.6"/>+<polygon class="nerve-simplex" points="1199.3,507.2 1233.5,534.3 1208.8,593.1"/>+<polygon class="nerve-simplex" points="1199.3,507.2 1169.8,523.0 1130.8,452.8"/>+<polygon class="nerve-simplex" points="1199.3,507.2 1169.8,523.0 1208.8,593.1"/>+<polygon class="nerve-simplex" points="1187.9,423.1 1194.5,464.2 1130.8,452.8"/>+<polygon class="nerve-simplex" points="1187.9,423.1 1194.5,464.2 1258.2,475.6"/>+<polygon class="nerve-simplex" points="1187.9,423.1 1152.7,396.9 1130.8,452.8"/>+<polygon class="nerve-simplex" points="1187.9,423.1 1152.7,396.9 1174.5,341.0"/>+<polygon class="nerve-simplex" points="1187.9,423.1 1216.4,408.3 1258.2,475.6"/>+<polygon class="nerve-simplex" points="1187.9,423.1 1216.4,408.3 1174.5,341.0"/>+<polygon class="nerve-simplex" points="1246.8,399.8 1216.4,408.3 1258.2,475.6"/>+<polygon class="nerve-simplex" points="1246.8,399.8 1216.4,408.3 1174.5,341.0"/>+<polygon class="nerve-simplex" points="1246.8,399.8 1241.1,361.8 1174.5,341.0"/>+<polygon class="nerve-simplex" points="1246.8,399.8 1241.1,361.8 1307.6,382.7"/>+<polygon class="nerve-simplex" points="1246.8,399.8 1282.9,429.1 1258.2,475.6"/>+<polygon class="nerve-simplex" points="1246.8,399.8 1282.9,429.1 1307.6,382.7"/>+<polygon class="nerve-simplex" points="1136.5,551.4 1169.8,523.0 1130.8,452.8"/>+<polygon class="nerve-simplex" points="1136.5,551.4 1169.8,523.0 1208.8,593.1"/>+<polygon class="nerve-simplex" points="1136.5,551.4 1139.4,600.7 1208.8,593.1"/>+<polygon class="nerve-simplex" points="1136.5,551.4 1139.4,600.7 1070.0,608.3"/>+<polygon class="nerve-simplex" points="1136.5,551.4 1100.4,530.5 1130.8,452.8"/>+<polygon class="nerve-simplex" points="1136.5,551.4 1100.4,530.5 1070.0,608.3"/>+<polygon class="nerve-simplex" points="1274.6,528.0 1233.5,534.3 1258.2,475.6"/>+<polygon class="nerve-simplex" points="1274.6,528.0 1233.5,534.3 1208.8,593.1"/>+<polygon class="nerve-simplex" points="1274.6,528.0 1307.6,495.5 1258.2,475.6"/>+<polygon class="nerve-simplex" points="1274.6,528.0 1307.6,495.5 1357.0,515.4"/>+<polygon class="nerve-simplex" points="1274.6,528.0 1282.9,554.2 1208.8,593.1"/>+<polygon class="nerve-simplex" points="1274.6,528.0 1282.9,554.2 1357.0,515.4"/>+<polygon class="nerve-simplex" points="1307.6,457.9 1307.6,495.5 1258.2,475.6"/>+<polygon class="nerve-simplex" points="1307.6,457.9 1307.6,495.5 1357.0,515.4"/>+<polygon class="nerve-simplex" points="1307.6,457.9 1282.9,429.1 1258.2,475.6"/>+<polygon class="nerve-simplex" points="1307.6,457.9 1282.9,429.1 1307.6,382.7"/>+<polygon class="nerve-simplex" points="1307.6,457.9 1332.3,449.0 1357.0,515.4"/>+<polygon class="nerve-simplex" points="1307.6,457.9 1332.3,449.0 1307.6,382.7"/>+<polygon class="nerve-simplex" points="1071.3,517.9 1100.4,530.5 1130.8,452.8"/>+<polygon class="nerve-simplex" points="1071.3,517.9 1100.4,530.5 1070.0,608.3"/>+<polygon class="nerve-simplex" points="1071.3,517.9 1041.5,550.4 1070.0,608.3"/>+<polygon class="nerve-simplex" points="1071.3,517.9 1041.5,550.4 1013.0,492.6"/>+<polygon class="nerve-simplex" points="1071.3,517.9 1071.9,472.7 1130.8,452.8"/>+<polygon class="nerve-simplex" points="1071.3,517.9 1071.9,472.7 1013.0,492.6"/>+<polygon class="nerve-simplex" points="1115.0,385.9 1152.7,396.9 1130.8,452.8"/>+<polygon class="nerve-simplex" points="1115.0,385.9 1152.7,396.9 1174.5,341.0"/>+<polygon class="nerve-simplex" points="1115.0,385.9 1085.2,408.3 1130.8,452.8"/>+<polygon class="nerve-simplex" points="1115.0,385.9 1085.2,408.3 1039.6,363.7"/>+<polygon class="nerve-simplex" points="1115.0,385.9 1107.1,352.4 1174.5,341.0"/>+<polygon class="nerve-simplex" points="1115.0,385.9 1107.1,352.4 1039.6,363.7"/>+<polygon class="nerve-simplex" points="1061.1,436.4 1085.2,408.3 1130.8,452.8"/>+<polygon class="nerve-simplex" points="1061.1,436.4 1085.2,408.3 1039.6,363.7"/>+<polygon class="nerve-simplex" points="1061.1,436.4 1071.9,472.7 1130.8,452.8"/>+<polygon class="nerve-simplex" points="1061.1,436.4 1071.9,472.7 1013.0,492.6"/>+<polygon class="nerve-simplex" points="1061.1,436.4 1026.3,428.2 1039.6,363.7"/>+<polygon class="nerve-simplex" points="1061.1,436.4 1026.3,428.2 1013.0,492.6"/>+<polygon class="nerve-simplex" points="1296.8,579.8 1282.9,554.2 1208.8,593.1"/>+<polygon class="nerve-simplex" points="1296.8,579.8 1282.9,554.2 1357.0,515.4"/>+<polygon class="nerve-simplex" points="1296.8,579.8 1340.8,573.2 1357.0,515.4"/>+<polygon class="nerve-simplex" points="1296.8,579.8 1340.8,573.2 1324.7,631.0"/>+<polygon class="nerve-simplex" points="1296.8,579.8 1266.7,612.0 1208.8,593.1"/>+<polygon class="nerve-simplex" points="1296.8,579.8 1266.7,612.0 1324.7,631.0"/>+<polygon class="nerve-simplex" points="1201.2,610.8 1139.4,600.7 1208.8,593.1"/>+<polygon class="nerve-simplex" points="1201.2,610.8 1139.4,600.7 1070.0,608.3"/>+<polygon class="nerve-simplex" points="1201.2,610.8 1266.7,612.0 1208.8,593.1"/>+<polygon class="nerve-simplex" points="1201.2,610.8 1266.7,612.0 1324.7,631.0"/>+<polygon class="nerve-simplex" points="1201.2,610.8 1197.4,619.6 1070.0,608.3"/>+<polygon class="nerve-simplex" points="1201.2,610.8 1197.4,619.6 1324.7,631.0"/>+<circle class="object-vertex" cx="1130.8" cy="452.8" r="6.0" opacity="1" stroke="#fff" stroke-width="2"/>+<circle class="object-vertex" cx="1258.2" cy="475.6" r="3.4" opacity=".78"/>+<circle class="object-vertex" cx="1208.8" cy="593.1" r="3.4" opacity=".78"/>+<circle class="object-vertex" cx="1174.5" cy="341.0" r="3.4" opacity=".78"/>+<circle class="object-vertex" cx="1307.6" cy="382.7" r="3.4" opacity=".78"/>+<circle class="object-vertex" cx="1070.0" cy="608.3" r="3.4" opacity=".78"/>+<circle class="object-vertex" cx="1357.0" cy="515.4" r="3.4" opacity=".78"/>+<circle class="object-vertex" cx="1013.0" cy="492.6" r="3.4" opacity=".78"/>+<circle class="object-vertex" cx="1039.6" cy="363.7" r="3.4" opacity=".78"/>+<circle class="object-vertex" cx="1324.7" cy="631.0" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1194.5" cy="464.2" r="6.0" opacity="1" stroke="#fff" stroke-width="2"/>+<circle class="object-edge" cx="1169.8" cy="523.0" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1233.5" cy="534.3" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1216.4" cy="408.3" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1152.7" cy="396.9" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1282.9" cy="429.1" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1241.1" cy="361.8" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1100.4" cy="530.5" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1139.4" cy="600.7" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1282.9" cy="554.2" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1307.6" cy="495.5" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1332.3" cy="449.0" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1071.9" cy="472.7" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1041.5" cy="550.4" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1107.1" cy="352.4" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1085.2" cy="408.3" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1026.3" cy="428.2" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1266.7" cy="612.0" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1340.8" cy="573.2" r="3.4" opacity=".78"/>+<circle class="object-edge" cx="1197.4" cy="619.6" r="3.4" opacity=".78"/>+<circle class="object-face" cx="1199.3" cy="507.2" r="6.0" opacity="1" stroke="#fff" stroke-width="2"/>+<circle class="object-face" cx="1187.9" cy="423.1" r="3.4" opacity=".78"/>+<circle class="object-face" cx="1246.8" cy="399.8" r="3.4" opacity=".78"/>+<circle class="object-face" cx="1136.5" cy="551.4" r="3.4" opacity=".78"/>+<circle class="object-face" cx="1274.6" cy="528.0" r="3.4" opacity=".78"/>+<circle class="object-face" cx="1307.6" cy="457.9" r="3.4" opacity=".78"/>+<circle class="object-face" cx="1071.3" cy="517.9" r="3.4" opacity=".78"/>+<circle class="object-face" cx="1115.0" cy="385.9" r="3.4" opacity=".78"/>+<circle class="object-face" cx="1061.1" cy="436.4" r="3.4" opacity=".78"/>+<circle class="object-face" cx="1296.8" cy="579.8" r="3.4" opacity=".78"/>+<circle class="object-face" cx="1201.2" cy="610.8" r="3.4" opacity=".78"/>+<text class="mono profile-value" x="1211.3" y="495.2" text-anchor="start">selected flag</text>+<text class="mono panel-note" x="1352.0" y="642.0" text-anchor="end">simplex-0</text>+<rect x="50" y="720" width="1340" height="156" rx="22" fill="#09171c" stroke="#8bbeb2" stroke-opacity=".20"/>+<text class="mono kicker" x="76.0" y="752.0" text-anchor="start">NORMALIZATION PROFILE</text>+<text class="serif panel-title" x="76.0" y="789.0" text-anchor="start">Identity insertions are cost, not geometry.</text>+<text class="sans panel-note" x="76.0" y="817.0" text-anchor="start">Identity insertions swell dimension two to 385.</text>+<rect x="76" y="838" width="12" height="4" rx="2" fill="#72d6c2"/>+<text class="mono profile-label" x="96.0" y="845.0" text-anchor="start">NORMALIZED</text>+<rect x="196" y="838" width="12" height="4" rx="2" fill="#bc8cff"/>+<text class="mono profile-label" x="216.0" y="845.0" text-anchor="start">UNNORMALIZED</text>+<text class="mono profile-label" x="590.0" y="775.0" text-anchor="end">DIM 0</text>+<rect x="615" y="762.0" width="230" height="11" rx="5.5" fill="#13272d"/>+<rect x="615" y="762.0" width="24.5" height="11" rx="5.5" fill="#72d6c2"/>+<text class="mono profile-value" x="858.0" y="773.0" text-anchor="start">41</text>+<rect x="965" y="762.0" width="310" height="11" rx="5.5" fill="#1d1830"/>+<rect x="965" y="762.0" width="33.0" height="11" rx="5.5" fill="#bc8cff"/>+<text class="mono profile-value" x="1288.0" y="773.0" text-anchor="start">41</text>+<text class="mono profile-label" x="590.0" y="819.0" text-anchor="end">DIM 1</text>+<rect x="615" y="806.0" width="230" height="11" rx="5.5" fill="#13272d"/>+<rect x="615" y="806.0" width="83.0" height="11" rx="5.5" fill="#72d6c2"/>+<text class="mono profile-value" x="858.0" y="817.0" text-anchor="start">139</text>+<rect x="965" y="806.0" width="310" height="11" rx="5.5" fill="#1d1830"/>+<rect x="965" y="806.0" width="144.9" height="11" rx="5.5" fill="#bc8cff"/>+<text class="mono profile-value" x="1288.0" y="817.0" text-anchor="start">180</text>+<text class="mono profile-label" x="590.0" y="863.0" text-anchor="end">DIM 2</text>+<rect x="615" y="850.0" width="230" height="11" rx="5.5" fill="#13272d"/>+<rect x="615" y="850.0" width="39.4" height="11" rx="5.5" fill="#72d6c2"/>+<text class="mono profile-value" x="858.0" y="861.0" text-anchor="start">66</text>+<rect x="965" y="850.0" width="310" height="11" rx="5.5" fill="#1d1830"/>+<rect x="965" y="850.0" width="310.0" height="11" rx="5.5" fill="#bc8cff"/>+<text class="mono profile-value" x="1288.0" y="861.0" text-anchor="start">385</text>+</svg>
+ docs/delaunay-compare/Main.hs view
@@ -0,0 +1,27 @@+-- | Haskell owner of the upstream-compatible construction comparison.+module Main (main) where++import Moonlight.Triangulation.Bench.DelaunayCompare.Domain (renderCompareObstruction)+import Moonlight.Triangulation.Bench.DelaunayCompare.Native (withNativeApi)+import Moonlight.Triangulation.Bench.DelaunayCompare.Suite+  ( preflightSuite+  , suiteAgreementMessage+  , suiteBenchmarks+  , withPreparedSuite+  )+import System.Exit (die)+import Test.Tasty.Bench (defaultMain)++main :: IO ()+main = do+  outcome <-+    withNativeApi $ \api ->+      withPreparedSuite api $ \suite -> do+        agreement <- preflightSuite api suite+        case agreement of+          Left obstruction -> pure (Left obstruction)+          Right () -> do+            putStrLn suiteAgreementMessage+            defaultMain (suiteBenchmarks api suite)+            pure (Right ())+  either (die . renderCompareObstruction) pure outcome
+ docs/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Domain.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}++-- | The closed case matrix and typed obstruction surface for the comparison.+module Moonlight.Triangulation.Bench.DelaunayCompare.Domain+  ( SizeBand (..)+  , allSizeBands+  , sizeBandLabel+  , PointDistribution (..)+  , allPointDistributions+  , pointDistributionLabel+  , Implementation (..)+  , allImplementations+  , implementationLabel+  , NativeImplementation (..)+  , nativeImplementationLabel+  , implementationOfNative+  , PointCount+  , pointCountValue+  , pointCountsFor+  , FixtureSpec (..)+  , allFixtureSpecs+  , DelaunaySummary (..)+  , NativeStatus (..)+  , NativePreparationFailure (..)+  , NativeRunFailure (..)+  , CompareObstruction (..)+  , renderCompareObstruction+  ) where++import Control.DeepSeq (NFData)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import GHC.Generics (Generic)+import Moonlight.Triangulation.Types (BuildError)++data SizeBand+  = Small+  | Big+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++allSizeBands :: [SizeBand]+allSizeBands = [Small, Big]++sizeBandLabel :: SizeBand -> String+sizeBandLabel = \case+  Small -> "small"+  Big -> "big"++data PointDistribution+  = LocalInsertion+  | Uniform+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++allPointDistributions :: [PointDistribution]+allPointDistributions = [LocalInsertion, Uniform]++pointDistributionLabel :: PointDistribution -> String+pointDistributionLabel = \case+  LocalInsertion -> "local insertion"+  Uniform -> "uniform"++data Implementation+  = Spade+  | SpadeHierarchy+  | Cdt+  | Delaunator+  | Moonlight+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Upstream order, with Moonlight appended rather than interposed.+allImplementations :: [Implementation]+allImplementations = [Spade, SpadeHierarchy, Cdt, Delaunator, Moonlight]++implementationLabel :: Implementation -> String+implementationLabel = \case+  Spade -> "spade 2"+  SpadeHierarchy -> "spade 2 hierarchy"+  Cdt -> "cdt"+  Delaunator -> "delaunator"+  Moonlight -> "moonlight-triangulation"++data NativeImplementation+  = NativeSpade+  | NativeSpadeHierarchy+  | NativeCdt+  | NativeDelaunator+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++nativeImplementationLabel :: NativeImplementation -> String+nativeImplementationLabel = implementationLabel . implementationOfNative++implementationOfNative :: NativeImplementation -> Implementation+implementationOfNative = \case+  NativeSpade -> Spade+  NativeSpadeHierarchy -> SpadeHierarchy+  NativeCdt -> Cdt+  NativeDelaunator -> Delaunator++newtype PointCount = PointCount Int+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++pointCountValue :: PointCount -> Int+pointCountValue (PointCount count) = count++data FixtureSpec = FixtureSpec+  { fixtureSizeBand :: !SizeBand+  , fixturePointDistribution :: !PointDistribution+  , fixturePointCount :: !PointCount+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++allFixtureSpecs :: [FixtureSpec]+allFixtureSpecs =+  concatMap+    ( \sizeBand ->+        liftA2+          (FixtureSpec sizeBand)+          allPointDistributions+          (pointCountsFor sizeBand)+    )+    allSizeBands++pointCountsFor :: SizeBand -> [PointCount]+pointCountsFor = \case+  Small -> PointCount <$> [2_000, 4_000, 6_000, 8_000, 10_000, 12_000, 14_000]+  Big -> PointCount <$> [50_000, 100_000, 150_000, 200_000, 250_000]++data DelaunaySummary = DelaunaySummary+  { summaryVertexCount :: !Int+  , summaryTriangleCount :: !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data NativeStatus+  = NativeNullPointer+  | NativeUnknownTag+  | NativeCoordinateCountMismatch+  | NativeDistributionConstructionFailed+  | NativeTriangulationFailed+  | NativePanicked+  | NativeUnknownStatus !Int+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data NativePreparationFailure+  = NativePreparationStatus !NativeStatus+  | NativePreparationReturnedNull+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data NativeRunFailure+  = NativeRunStatus !NativeStatus+  | NativeCountExceedsHaskellInt !Integer+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data CompareObstruction+  = RustManifestNotFound !(NonEmpty FilePath)+  | CargoInvocationFailed !FilePath !String+  | CargoBuildFailed !FilePath !Int !String+  | UnsupportedDynamicLibraryHost !String+  | DynamicLibraryOpenFailed !FilePath !String+  | DynamicSymbolLoadFailed !FilePath !String !String+  | FixtureGenerationFailed !FixtureSpec !NativeStatus+  | FixturePreparationFailed !FixtureSpec !NativeImplementation !NativeStatus+  | NativePreparedNull !FixtureSpec !NativeImplementation+  | MoonlightConstructionFailed !FixtureSpec !BuildError+  | NativeConstructionFailed !FixtureSpec !NativeImplementation !NativeRunFailure+  | SummaryDisagreement !FixtureSpec !Implementation !DelaunaySummary !DelaunaySummary+  | ComparisonObstructions !(NonEmpty CompareObstruction)+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++renderCompareObstruction :: CompareObstruction -> String+renderCompareObstruction = \case+  RustManifestNotFound candidates ->+    "Rust referent manifest not found; checked " <> show (NonEmpty.toList candidates)+  CargoInvocationFailed manifest details ->+    "could not invoke Cargo for " <> manifest <> ": " <> details+  CargoBuildFailed manifest exitCode details ->+    "Cargo failed for "+      <> manifest+      <> " with exit code "+      <> show exitCode+      <> if null details then "" else ":\n" <> details+  UnsupportedDynamicLibraryHost host ->+    "delaunay-compare does not know the dynamic-library suffix for host " <> show host+  DynamicLibraryOpenFailed path details ->+    "could not load Rust referent library " <> path <> ": " <> details+  DynamicSymbolLoadFailed path symbol details ->+    "could not load symbol " <> symbol <> " from " <> path <> ": " <> details+  FixtureGenerationFailed fixture status ->+    "upstream fixture generation failed for " <> renderFixture fixture <> ": " <> show status+  FixturePreparationFailed fixture implementation status ->+    "native preparation failed for "+      <> nativeImplementationLabel implementation+      <> " on "+      <> renderFixture fixture+      <> ": "+      <> show status+  NativePreparedNull fixture implementation ->+    "native preparation returned a null handle for "+      <> nativeImplementationLabel implementation+      <> " on "+      <> renderFixture fixture+  MoonlightConstructionFailed fixture buildError ->+    "Moonlight construction failed for " <> renderFixture fixture <> ": " <> show buildError+  NativeConstructionFailed fixture implementation failure ->+    "native construction failed for "+      <> nativeImplementationLabel implementation+      <> " on "+      <> renderFixture fixture+      <> ": "+      <> show failure+  SummaryDisagreement fixture implementation expected observed ->+    "construction summary disagreement for "+      <> implementationLabel implementation+      <> " on "+      <> renderFixture fixture+      <> "; Moonlight="+      <> show expected+      <> ", observed="+      <> show observed+  ComparisonObstructions obstructions ->+    unlines ("delaunay comparison obstructed:" : fmap (("  - " <>) . renderCompareObstruction) (NonEmpty.toList obstructions))++renderFixture :: FixtureSpec -> String+renderFixture fixture =+  sizeBandLabel (fixtureSizeBand fixture)+    <> "/"+    <> pointDistributionLabel (fixturePointDistribution fixture)+    <> "/"+    <> show (pointCountValue (fixturePointCount fixture))
+ docs/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Native.hs view
@@ -0,0 +1,307 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Resource-safe dynamic boundary to the Rust crates under comparison.+module Moonlight.Triangulation.Bench.DelaunayCompare.Native+  ( NativeApi+  , NativeFixture+  , GeneratedCoordinates+  , withNativeApi+  , generateCoordinates+  , generatedCoordinatePairs+  , prepareNativeFixture+  , runNativeFixture+  , releaseNativeFixture+  ) where++import Control.Exception (IOException, bracket, displayException, try)+import Control.Monad (filterM)+import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)+import Data.Bifunctor (first)+import Data.Int (Int32)+import Data.List (unfoldr)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Moonlight.Triangulation.Bench.DelaunayCompare.Domain+import Foreign.C.Types (CDouble, CInt (..), CSize (..))+import Foreign.Marshal.Alloc (alloca)+import Foreign.Ptr (FunPtr, Ptr, nullPtr)+import Foreign.Storable (peek, poke)+import qualified Data.Vector as Vector+import qualified Data.Vector.Storable as StorableVector+import qualified Data.Vector.Storable.Mutable as MutableStorableVector+import System.Directory (doesFileExist, makeAbsolute)+import System.Environment (lookupEnv)+import System.Exit (ExitCode (..))+import System.FilePath ((</>), takeDirectory)+import System.Info (os)+import System.Posix.DynamicLinker+  ( DL+  , RTLDFlags (RTLD_LOCAL, RTLD_NOW)+  , dlclose+  , dlopen+  , dlsym+  )+import System.Process+  ( CreateProcess (cwd)+  , proc+  , readCreateProcessWithExitCode+  )++type GenerateFunction = CInt -> CSize -> Ptr CDouble -> CSize -> IO CInt+type PrepareFunction = CInt -> Ptr CDouble -> CSize -> Ptr (Ptr ()) -> IO CInt+type RunFunction = Ptr () -> Ptr CSize -> Ptr CSize -> IO CInt+type ReleaseFunction = Ptr () -> IO ()++foreign import ccall safe "dynamic"+  bindGenerateFunction :: FunPtr GenerateFunction -> GenerateFunction++foreign import ccall safe "dynamic"+  bindPrepareFunction :: FunPtr PrepareFunction -> PrepareFunction++foreign import ccall safe "dynamic"+  bindRunFunction :: FunPtr RunFunction -> RunFunction++foreign import ccall unsafe "dynamic"+  bindReleaseFunction :: FunPtr ReleaseFunction -> ReleaseFunction++data NativeApi = NativeApi+  { nativeGenerate :: !GenerateFunction+  , nativePrepare :: !PrepareFunction+  , nativeRun :: !RunFunction+  , nativeRelease :: !ReleaseFunction+  }++newtype NativeFixture = NativeFixture (Ptr ())++data GeneratedCoordinates = GeneratedCoordinates+  { generatedPointCount :: !PointCount+  , generatedCoordinateValues :: !(StorableVector.Vector CDouble)+  }++withNativeApi+  :: (NativeApi -> IO (Either CompareObstruction result))+  -> IO (Either CompareObstruction result)+withNativeApi action = do+  manifestResult <- resolveRustManifest+  case manifestResult of+    Left obstruction -> pure (Left obstruction)+    Right manifest -> do+      libraryResult <- buildRustLibrary manifest+      case libraryResult of+        Left obstruction -> pure (Left obstruction)+        Right libraryPath -> withLoadedNativeApi libraryPath action++resolveRustManifest :: IO (Either CompareObstruction FilePath)+resolveRustManifest = do+  configured <- lookupEnv "MOONLIGHT_DELAUNAY_COMPARE_RUST_MANIFEST"+  let candidates =+        case configured of+          Just path -> path :| []+          Nothing ->+            "docs/delaunay-compare/rust/Cargo.toml"+              :| [ "foundation/moonlight-planar/docs/delaunay-compare/rust/Cargo.toml"+                 , "compiler/foundation/moonlight-planar/docs/delaunay-compare/rust/Cargo.toml"+                 ]+  existing <- filterM doesFileExist (NonEmpty.toList candidates)+  case existing of+    manifest : _ -> Right <$> makeAbsolute manifest+    [] -> pure (Left (RustManifestNotFound candidates))++buildRustLibrary :: FilePath -> IO (Either CompareObstruction FilePath)+buildRustLibrary manifest = do+  libraryNameResult <- dynamicLibraryName+  case libraryNameResult of+    Left obstruction -> pure (Left obstruction)+    Right libraryName -> do+      let rustRoot = takeDirectory manifest+          targetDirectory = rustRoot </> "target"+          command =+            ( proc+                "cargo"+                [ "build"+                , "--quiet"+                , "--release"+                , "--lib"+                , "--manifest-path"+                , manifest+                , "--target-dir"+                , targetDirectory+                ]+            )+              { cwd = Just rustRoot+              }+      invocation <- try @IOException (readCreateProcessWithExitCode command "")+      pure $+        case invocation of+          Left exception ->+            Left (CargoInvocationFailed manifest (displayException exception))+          Right (ExitFailure exitCode, standardOutput, standardError) ->+            Left+              ( CargoBuildFailed+                  manifest+                  exitCode+                  (standardError <> standardOutput)+              )+          Right (ExitSuccess, _, _) ->+            Right (targetDirectory </> "release" </> libraryName)++dynamicLibraryName :: IO (Either CompareObstruction FilePath)+dynamicLibraryName =+  pure $+    case os of+      "darwin" -> Right "libmoonlight_delaunay_compare_referents.dylib"+      "linux" -> Right "libmoonlight_delaunay_compare_referents.so"+      host -> Left (UnsupportedDynamicLibraryHost host)++withLoadedNativeApi+  :: FilePath+  -> (NativeApi -> IO (Either CompareObstruction result))+  -> IO (Either CompareObstruction result)+withLoadedNativeApi libraryPath action = do+  opened <- try @IOException (dlopen libraryPath [RTLD_NOW, RTLD_LOCAL])+  case opened of+    Left exception ->+      pure (Left (DynamicLibraryOpenFailed libraryPath (displayException exception)))+    Right handle ->+      bracket+        (pure handle)+        dlclose+        ( \loadedHandle -> do+            apiResult <- loadNativeApi libraryPath loadedHandle+            case apiResult of+              Left obstruction -> pure (Left obstruction)+              Right api -> action api+        )++loadNativeApi :: FilePath -> DL -> IO (Either CompareObstruction NativeApi)+loadNativeApi libraryPath handle =+  runExceptT $+    NativeApi+      <$> loadSymbol libraryPath handle "delaunay_compare_generate" bindGenerateFunction+      <*> loadSymbol libraryPath handle "delaunay_compare_prepare" bindPrepareFunction+      <*> loadSymbol libraryPath handle "delaunay_compare_run" bindRunFunction+      <*> loadSymbol libraryPath handle "delaunay_compare_release" bindReleaseFunction++loadSymbol+  :: FilePath+  -> DL+  -> String+  -> (FunPtr function -> boundFunction)+  -> ExceptT CompareObstruction IO boundFunction+loadSymbol libraryPath handle symbol bind =+  ExceptT $ do+    loaded <- try @IOException (dlsym handle symbol)+    pure $+      first+        (DynamicSymbolLoadFailed libraryPath symbol . displayException)+        (bind <$> loaded)++generateCoordinates+  :: NativeApi+  -> FixtureSpec+  -> IO (Either NativeStatus GeneratedCoordinates)+generateCoordinates api fixture = do+  let pointCount = fixturePointCount fixture+      coordinateCount = 2 * pointCountValue pointCount+  mutableCoordinates <- MutableStorableVector.new coordinateCount+  statusCode <-+    MutableStorableVector.unsafeWith mutableCoordinates $ \coordinatePointer ->+      nativeGenerate api+        (distributionTag (fixturePointDistribution fixture))+        (fromIntegral (pointCountValue pointCount))+        coordinatePointer+        (fromIntegral coordinateCount)+  case decodeNativeStatus statusCode of+    Left status -> pure (Left status)+    Right () -> do+      coordinates <- StorableVector.unsafeFreeze mutableCoordinates+      pure (Right (GeneratedCoordinates pointCount coordinates))++generatedCoordinatePairs :: GeneratedCoordinates -> Vector.Vector (Double, Double)+generatedCoordinatePairs generated =+  Vector.fromList+    ( unfoldr+        takeCoordinatePair+        (realToFrac <$> StorableVector.toList (generatedCoordinateValues generated))+    )+ where+  takeCoordinatePair :: [Double] -> Maybe ((Double, Double), [Double])+  takeCoordinatePair = \case+    x : y : remaining -> Just ((x, y), remaining)+    _ -> Nothing++prepareNativeFixture+  :: NativeApi+  -> NativeImplementation+  -> GeneratedCoordinates+  -> IO (Either NativePreparationFailure NativeFixture)+prepareNativeFixture api implementation coordinates =+  alloca $ \preparedOutput -> do+    poke preparedOutput nullPtr+    statusCode <-+      StorableVector.unsafeWith (generatedCoordinateValues coordinates) $ \coordinatePointer ->+        nativePrepare api+          (implementationTag implementation)+          coordinatePointer+          (fromIntegral (pointCountValue (generatedPointCount coordinates)))+          preparedOutput+    case decodeNativeStatus statusCode of+      Left status -> pure (Left (NativePreparationStatus status))+      Right () -> do+        prepared <- peek preparedOutput+        pure $+          if prepared == nullPtr+            then Left NativePreparationReturnedNull+            else Right (NativeFixture prepared)++runNativeFixture+  :: NativeApi+  -> NativeFixture+  -> IO (Either NativeRunFailure DelaunaySummary)+runNativeFixture api (NativeFixture prepared) =+  alloca $ \vertexCountOutput ->+    alloca $ \triangleCountOutput -> do+      statusCode <- nativeRun api prepared vertexCountOutput triangleCountOutput+      case decodeNativeStatus statusCode of+        Left status -> pure (Left (NativeRunStatus status))+        Right () -> do+          vertexCount <- peek vertexCountOutput+          triangleCount <- peek triangleCountOutput+          pure $ DelaunaySummary <$> cSizeToInt vertexCount <*> cSizeToInt triangleCount++releaseNativeFixture :: NativeApi -> NativeFixture -> IO ()+releaseNativeFixture api (NativeFixture prepared) = nativeRelease api prepared++decodeNativeStatus :: CInt -> Either NativeStatus ()+decodeNativeStatus statusCode =+  case fromIntegral statusCode :: Int32 of+    0 -> Right ()+    1 -> Left NativeNullPointer+    2 -> Left NativeUnknownTag+    3 -> Left NativeCoordinateCountMismatch+    4 -> Left NativeDistributionConstructionFailed+    5 -> Left NativeTriangulationFailed+    6 -> Left NativePanicked+    unknown -> Left (NativeUnknownStatus (fromIntegral unknown))++cSizeToInt :: CSize -> Either NativeRunFailure Int+cSizeToInt value =+  let integerValue = toInteger value+   in if integerValue > toInteger (maxBound :: Int)+        then Left (NativeCountExceedsHaskellInt integerValue)+        else Right (fromInteger integerValue)++distributionTag :: PointDistribution -> CInt+distributionTag = \case+  LocalInsertion -> 0+  Uniform -> 1++implementationTag :: NativeImplementation -> CInt+implementationTag = \case+  NativeSpade -> 0+  NativeSpadeHierarchy -> 1+  NativeCdt -> 2+  NativeDelaunator -> 3
+ docs/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Picture.hs view
@@ -0,0 +1,466 @@+{-# LANGUAGE LambdaCase #-}++-- | Typed receipt parsing and pure Spade-style SVG projection.+module Moonlight.Triangulation.Bench.DelaunayCompare.Picture+  ( BenchmarkReceipt+  , PictureObstruction (..)+  , parseBenchmarkReceipt+  , pictureFileName+  , renderComparisonPicture+  , renderPictureObstruction+  ) where++import Data.List (group, sort, sortOn)+import qualified Data.Map.Strict as Map+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set+import Moonlight.Triangulation.Bench.DelaunayCompare.Domain+import Numeric (showFFloat)+import Text.Read (readMaybe)++data ObservationKey = ObservationKey+  { observationFixture :: !FixtureSpec+  , observationImplementation :: !Implementation+  }+  deriving stock (Eq, Ord, Show)++data BenchmarkObservation = BenchmarkObservation+  { benchmarkKey :: !ObservationKey+  , benchmarkMeanPicoseconds :: !Double+  , benchmarkSpreadPicoseconds :: !Double+  }+  deriving stock (Eq, Show)++newtype BenchmarkReceipt = BenchmarkReceipt+  { receiptObservations :: Map.Map ObservationKey BenchmarkObservation+  }++data PictureObstruction+  = MissingCsvHeader+  | UnexpectedCsvHeader !String+  | MalformedCsvRow !Int !String+  | UnknownBenchmarkName !Int !String+  | InvalidBenchmarkScalar !Int !String !String+  | DuplicateBenchmarkObservations ![ObservationKey]+  | MissingBenchmarkObservations ![ObservationKey]+  deriving stock (Eq, Show)++parseBenchmarkReceipt :: String -> Either PictureObstruction BenchmarkReceipt+parseBenchmarkReceipt source =+  case lines source of+    [] -> Left MissingCsvHeader+    header : rows+      | header /= expectedCsvHeader -> Left (UnexpectedCsvHeader header)+      | otherwise -> do+          observations <- traverse (uncurry parseObservationRow) (zip [2 ..] rows)+          let keys = benchmarkKey <$> observations+              duplicateKeys =+                mapMaybe+                  ( \case+                      key : _ : _ -> Just key+                      _ -> Nothing+                  )+                  (group (sort keys))+              observationMap = Map.fromList ((\observation -> (benchmarkKey observation, observation)) <$> observations)+              missingKeys = Set.toList (expectedObservationKeys `Set.difference` Map.keysSet observationMap)+          case (duplicateKeys, missingKeys) of+            (duplicate : duplicates, _) -> Left (DuplicateBenchmarkObservations (duplicate : duplicates))+            ([], missing : remaining) -> Left (MissingBenchmarkObservations (missing : remaining))+            ([], []) -> Right (BenchmarkReceipt observationMap)++renderComparisonPicture+  :: SizeBand+  -> BenchmarkReceipt+  -> String+renderComparisonPicture sizeBand receipt =+  renderSvg sizeBand pointCounts axisMaximum panels+ where+  pointCounts = pointCountValue <$> pointCountsFor sizeBand+  panels = picturePanel receipt sizeBand <$> allPointDistributions+  allObservations = concatMap (concatMap pictureSeriesObservations . picturePanelSeries) panels+  maximumMilliseconds =+    foldr+      (max . observationUpperMilliseconds)+      0+      allObservations+  axisMaximum = niceCeiling maximumMilliseconds++pictureFileName :: SizeBand -> FilePath+pictureFileName = \case+  Small -> "moonlight-delaunay-compare-small.svg"+  Big -> "moonlight-delaunay-compare-big.svg"++renderPictureObstruction :: PictureObstruction -> String+renderPictureObstruction = \case+  MissingCsvHeader -> "benchmark CSV has no header"+  UnexpectedCsvHeader header ->+    "benchmark CSV header was " <> show header <> "; expected " <> show expectedCsvHeader+  MalformedCsvRow lineNumber row ->+    "benchmark CSV row " <> show lineNumber <> " is not a three-column tasty-bench row: " <> show row+  UnknownBenchmarkName lineNumber name ->+    "benchmark CSV row " <> show lineNumber <> " names an unknown comparison case: " <> show name+  InvalidBenchmarkScalar lineNumber field value ->+    "benchmark CSV row "+      <> show lineNumber+      <> " has invalid "+      <> field+      <> ": "+      <> show value+  DuplicateBenchmarkObservations keys ->+    "benchmark CSV repeats comparison cases: " <> show keys+  MissingBenchmarkObservations keys ->+    "benchmark CSV omits comparison cases: " <> show keys++expectedCsvHeader :: String+expectedCsvHeader = "Name,Mean (ps),2*Stdev (ps)"++expectedObservationKeys :: Set.Set ObservationKey+expectedObservationKeys =+  Set.fromList (liftA2 ObservationKey allFixtureSpecs allImplementations)++expectedBenchmarkNames :: Map.Map String ObservationKey+expectedBenchmarkNames =+  Map.fromList ((\key -> (benchmarkName key, key)) <$> Set.toList expectedObservationKeys)++benchmarkName :: ObservationKey -> String+benchmarkName key =+  "All.comparison: creation benchmark ("+    <> sizeBandLabel (fixtureSizeBand fixture)+    <> ")."+    <> implementationLabel (observationImplementation key)+    <> "."+    <> pointDistributionLabel (fixturePointDistribution fixture)+    <> "."+    <> show (pointCountValue (fixturePointCount fixture))+ where+  fixture = observationFixture key++parseObservationRow :: Int -> String -> Either PictureObstruction BenchmarkObservation+parseObservationRow lineNumber row =+  case csvTriple row of+    Nothing -> Left (MalformedCsvRow lineNumber row)+    Just (name, rawMean, rawSpread) -> do+      key <- maybe (Left (UnknownBenchmarkName lineNumber name)) Right (Map.lookup name expectedBenchmarkNames)+      meanPicoseconds <- parseNonNegativeScalar lineNumber "mean picoseconds" rawMean+      spreadPicoseconds <- parseNonNegativeScalar lineNumber "two-standard-deviation spread" rawSpread+      pure+        BenchmarkObservation+          { benchmarkKey = key+          , benchmarkMeanPicoseconds = meanPicoseconds+          , benchmarkSpreadPicoseconds = spreadPicoseconds+          }++csvTriple :: String -> Maybe (String, String, String)+csvTriple row =+  case break (== ',') row of+    (firstColumn, ',' : remaining) ->+      case break (== ',') remaining of+        (secondColumn, ',' : thirdColumn)+          | ',' `notElem` thirdColumn -> Just (firstColumn, secondColumn, thirdColumn)+        _ -> Nothing+    _ -> Nothing++parseNonNegativeScalar :: Int -> String -> String -> Either PictureObstruction Double+parseNonNegativeScalar lineNumber field rawValue =+  case readMaybe rawValue of+    Just value+      | value >= 0 && not (isInfinite value) && not (isNaN value) -> Right value+    _ -> Left (InvalidBenchmarkScalar lineNumber field rawValue)++data PictureSeries = PictureSeries+  { pictureSeriesImplementation :: !Implementation+  , pictureSeriesObservations :: ![BenchmarkObservation]+  }++data PicturePanel = PicturePanel+  { picturePanelDistribution :: !PointDistribution+  , picturePanelSeries :: ![PictureSeries]+  }++picturePanel+  :: BenchmarkReceipt+  -> SizeBand+  -> PointDistribution+  -> PicturePanel+picturePanel receipt sizeBand distribution =+  PicturePanel distribution (pictureSeries receipt sizeBand distribution <$> allImplementations)++pictureSeries+  :: BenchmarkReceipt+  -> SizeBand+  -> PointDistribution+  -> Implementation+  -> PictureSeries+pictureSeries receipt sizeBand distribution implementation =+  PictureSeries implementation observations+ where+  observations =+    sortOn (pointCountValue . fixturePointCount . observationFixture . benchmarkKey)+      [ observation+      | observation <- Map.elems (receiptObservations receipt)+      , let key = benchmarkKey observation+            fixture = observationFixture key+      , fixtureSizeBand fixture == sizeBand+      , fixturePointDistribution fixture == distribution+      , observationImplementation key == implementation+      ]++data PictureLayout = PictureLayout+  { pictureWidth :: !Double+  , pictureHeight :: !Double+  , picturePlotTop :: !Double+  , picturePlotBottom :: !Double+  , picturePanelWidth :: !Double+  , picturePanelLefts :: ![Double]+  }++pictureLayout :: PictureLayout+pictureLayout =+  PictureLayout+    { pictureWidth = 1280+    , pictureHeight = 720+    , picturePlotTop = 168+    , picturePlotBottom = 610+    , picturePanelWidth = 540+    , picturePanelLefts = [70, 670]+    }++renderSvg :: SizeBand -> [Int] -> Double -> [PicturePanel] -> String+renderSvg sizeBand pointCounts axisMaximum panels =+  unlines+    ( [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>"+      , "<svg xmlns=\"http://www.w3.org/2000/svg\" viewBox=\"0 0 "+          <> coordinate (pictureWidth pictureLayout)+          <> " "+          <> coordinate (pictureHeight pictureLayout)+          <> "\" role=\"img\" aria-labelledby=\"title description\">"+      , "<title id=\"title\">" <> pictureTitle sizeBand <> "</title>"+      , "<desc id=\"description\">CPU construction time for Spade, cdt, delaunator, and Moonlight over the upstream Delaunay comparison fixtures. Lower lines are faster.</desc>"+      , "<defs>"+      , "  <pattern id=\"triangulation-mesh\" width=\"54\" height=\"46\" patternUnits=\"userSpaceOnUse\">"+      , "    <path d=\"M0 46L27 0L54 46ZM0 46L54 46M27 0L27 46\" fill=\"none\" stroke=\"rgb(255,140,0)\" stroke-width=\"0.7\"/>"+      , "  </pattern>"+      , "  <clipPath id=\"header-mesh-clip\"><rect x=\"955\" y=\"8\" width=\"290\" height=\"82\" rx=\"20\"/></clipPath>"+      , "</defs>"+      , "<rect width=\""+          <> coordinate (pictureWidth pictureLayout)+          <> "\" height=\""+          <> coordinate (pictureHeight pictureLayout)+          <> "\" fill=\"white\"/>"+      , "<rect x=\"955\" y=\"8\" width=\"290\" height=\"82\" fill=\"url(#triangulation-mesh)\" opacity=\"0.10\" clip-path=\"url(#header-mesh-clip)\"/>"+      , svgText 640 34 "middle" 24 "500" (pictureTitle sizeBand)+      , svgText 640 61 "middle" 13 "400" "Moonlight against Spade's construction referents · CPU time · lower is faster"+      ]+        <> renderLegend+        <> concat (zipWith (renderPanel pointCounts axisMaximum) (picturePanelLefts pictureLayout) panels)+        <> [ svgText 640 704 "middle" 11 "400" "Whiskers show tasty-bench's reported 2× standard-deviation spread."+           , "</svg>"+           ]+    )++pictureTitle :: SizeBand -> String+pictureTitle = \case+  Small -> "Moonlight Delaunay construction · small point sets"+  Big -> "Moonlight Delaunay construction · big point sets"++renderLegend :: [String]+renderLegend =+  concat+    ( zipWith+        renderLegendItem+        [105, 315, 560, 735, 940]+        allImplementations+    )++renderLegendItem :: Double -> Implementation -> [String]+renderLegendItem x implementation =+  [ "<g aria-label=\"" <> implementationLabel implementation <> "\">"+  , "  <line x1=\"" <> coordinate x <> "\" y1=\"101\" x2=\"" <> coordinate (x + 34) <> "\" y2=\"101\" stroke=\"" <> implementationColor implementation <> "\" stroke-width=\"" <> seriesStrokeWidth implementation <> "\"" <> seriesDash implementation <> "/>"+  , "  " <> renderMarker implementation (x + 17) 101+  , "  " <> svgText (x + 43) 105 "start" 12 "400" (implementationLabel implementation)+  , "</g>"+  ]++renderPanel :: [Int] -> Double -> Double -> PicturePanel -> [String]+renderPanel pointCounts axisMaximum panelLeft panel =+  [ "<g aria-label=\"" <> panelLabel <> "\">"+  , svgText (panelLeft + panelWidth / 2) 144 "middle" 15 "500" panelLabel+  ]+    <> concatMap (renderHorizontalGrid panelLeft panelWidth axisMaximum) [0 .. 5]+    <> concatMap (renderVerticalTick panelLeft panelWidth pointCounts) pointCounts+    <> [ "<rect x=\"" <> coordinate panelLeft <> "\" y=\"" <> coordinate plotTop <> "\" width=\"" <> coordinate panelWidth <> "\" height=\"" <> coordinate plotHeight <> "\" fill=\"none\" stroke=\"rgb(25,25,25)\" stroke-width=\"1\"/>"+       , svgText (panelLeft + panelWidth / 2) 664 "middle" 12 "400" "input size (points)"+       , "<text x=\"" <> coordinate (panelLeft - 55) <> "\" y=\"" <> coordinate (plotTop + plotHeight / 2) <> "\" text-anchor=\"middle\" font-family=\"Helvetica, Arial, sans-serif\" font-size=\"12\" fill=\"rgb(20,20,20)\" transform=\"rotate(-90 " <> coordinate (panelLeft - 55) <> " " <> coordinate (plotTop + plotHeight / 2) <> ")\">CPU time (ms)</text>"+       ]+    <> concatMap (renderSeries panelLeft panelWidth pointCounts axisMaximum) (picturePanelSeries panel)+    <> ["</g>"]+ where+  panelLabel = pointDistributionLabel (picturePanelDistribution panel)+  panelWidth = picturePanelWidth pictureLayout+  plotTop = picturePlotTop pictureLayout+  plotHeight = picturePlotBottom pictureLayout - plotTop++renderHorizontalGrid :: Double -> Double -> Double -> Int -> [String]+renderHorizontalGrid panelLeft panelWidth axisMaximum tickIndex =+  [ "<line x1=\"" <> coordinate panelLeft <> "\" y1=\"" <> coordinate y <> "\" x2=\"" <> coordinate (panelLeft + panelWidth) <> "\" y2=\"" <> coordinate y <> "\" stroke=\"rgb(170,170,170)\" stroke-width=\"0.7\" stroke-dasharray=\"2 4\"/>"+  , svgText (panelLeft - 10) (y + 4) "end" 11 "400" (axisLabel tickValue)+  ]+ where+  tickValue = axisMaximum * fromIntegral tickIndex / 5+  y = pictureY axisMaximum tickValue++renderVerticalTick :: Double -> Double -> [Int] -> Int -> [String]+renderVerticalTick panelLeft panelWidth pointCounts pointCount =+  [ "<line x1=\"" <> coordinate x <> "\" y1=\"610\" x2=\"" <> coordinate x <> "\" y2=\"616\" stroke=\"rgb(25,25,25)\" stroke-width=\"1\"/>"+  , svgText x 635 "middle" 11 "400" (pointCountLabel pointCount)+  ]+ where+  x = pictureX panelLeft panelWidth pointCounts pointCount++renderSeries :: Double -> Double -> [Int] -> Double -> PictureSeries -> [String]+renderSeries panelLeft panelWidth pointCounts axisMaximum series =+  [ "<g aria-label=\"" <> implementationLabel implementation <> "\">"+  , "  <polyline points=\"" <> unwords (observationPoint <$> observations) <> "\" fill=\"none\" stroke=\"" <> implementationColor implementation <> "\" stroke-width=\"" <> seriesStrokeWidth implementation <> "\" stroke-linecap=\"round\" stroke-linejoin=\"round\"" <> seriesDash implementation <> "/>"+  ]+    <> concatMap renderObservation observations+    <> ["</g>"]+ where+  implementation = pictureSeriesImplementation series+  observations = pictureSeriesObservations series+  observationPoint observation =+    coordinate (observationX observation) <> "," <> coordinate (observationY observation)+  observationX =+    pictureX panelLeft panelWidth pointCounts+      . pointCountValue+      . fixturePointCount+      . observationFixture+      . benchmarkKey+  observationY = pictureY axisMaximum . observationMeanMilliseconds+  renderObservation observation =+    [ "  <line x1=\"" <> coordinate x <> "\" y1=\"" <> coordinate upperY <> "\" x2=\"" <> coordinate x <> "\" y2=\"" <> coordinate lowerY <> "\" stroke=\"" <> implementationColor implementation <> "\" stroke-width=\"0.9\" opacity=\"0.48\"/>"+    , "  <line x1=\"" <> coordinate (x - 3) <> "\" y1=\"" <> coordinate upperY <> "\" x2=\"" <> coordinate (x + 3) <> "\" y2=\"" <> coordinate upperY <> "\" stroke=\"" <> implementationColor implementation <> "\" stroke-width=\"0.9\" opacity=\"0.48\"/>"+    , "  <line x1=\"" <> coordinate (x - 3) <> "\" y1=\"" <> coordinate lowerY <> "\" x2=\"" <> coordinate (x + 3) <> "\" y2=\"" <> coordinate lowerY <> "\" stroke=\"" <> implementationColor implementation <> "\" stroke-width=\"0.9\" opacity=\"0.48\"/>"+    , "  " <> renderMarker implementation x y+    ]+   where+    x = observationX observation+    y = observationY observation+    upperY = pictureY axisMaximum (observationUpperMilliseconds observation)+    lowerY = pictureY axisMaximum (observationLowerMilliseconds observation)++implementationColor :: Implementation -> String+implementationColor = \case+  Spade -> "rgb(0,0,139)"+  SpadeHierarchy -> "rgb(139,0,139)"+  Cdt -> "rgb(178,34,34)"+  Delaunator -> "rgb(0,139,139)"+  Moonlight -> "rgb(255,140,0)"++seriesStrokeWidth :: Implementation -> String+seriesStrokeWidth = \case+  Moonlight -> "3.2"+  _ -> "2.0"++seriesDash :: Implementation -> String+seriesDash = \case+  SpadeHierarchy -> " stroke-dasharray=\"7 4\""+  _ -> ""++renderMarker :: Implementation -> Double -> Double -> String+renderMarker implementation x y =+  case implementation of+    Spade -> circle 3.2+    SpadeHierarchy ->+      "<path d=\"M " <> coordinate x <> " " <> coordinate (y - 4.3) <> " L " <> coordinate (x - 4.1) <> " " <> coordinate (y + 3.5) <> " L " <> coordinate (x + 4.1) <> " " <> coordinate (y + 3.5) <> " Z\" fill=\"white\" stroke=\"" <> color <> "\" stroke-width=\"1.6\"/>"+    Cdt ->+      "<rect x=\"" <> coordinate (x - 3.2) <> "\" y=\"" <> coordinate (y - 3.2) <> "\" width=\"6.4\" height=\"6.4\" fill=\"white\" stroke=\"" <> color <> "\" stroke-width=\"1.6\"/>"+    Delaunator ->+      "<path d=\"M " <> coordinate x <> " " <> coordinate (y - 4.2) <> " L " <> coordinate (x + 4.2) <> " " <> coordinate y <> " L " <> coordinate x <> " " <> coordinate (y + 4.2) <> " L " <> coordinate (x - 4.2) <> " " <> coordinate y <> " Z\" fill=\"white\" stroke=\"" <> color <> "\" stroke-width=\"1.6\"/>"+    Moonlight ->+      "<path d=\"M " <> coordinate x <> " " <> coordinate (y - 5.4) <> " L " <> coordinate (x + 1.7) <> " " <> coordinate (y - 1.7) <> " L " <> coordinate (x + 5.4) <> " " <> coordinate y <> " L " <> coordinate (x + 1.7) <> " " <> coordinate (y + 1.7) <> " L " <> coordinate x <> " " <> coordinate (y + 5.4) <> " L " <> coordinate (x - 1.7) <> " " <> coordinate (y + 1.7) <> " L " <> coordinate (x - 5.4) <> " " <> coordinate y <> " L " <> coordinate (x - 1.7) <> " " <> coordinate (y - 1.7) <> " Z\" fill=\"" <> color <> "\" stroke=\"white\" stroke-width=\"1\"/>"+ where+  color = implementationColor implementation+  circle radius =+    "<circle cx=\"" <> coordinate x <> "\" cy=\"" <> coordinate y <> "\" r=\"" <> coordinate radius <> "\" fill=\"white\" stroke=\"" <> color <> "\" stroke-width=\"1.6\"/>"++pictureX :: Double -> Double -> [Int] -> Int -> Double+pictureX panelLeft panelWidth pointCounts pointCount =+  case pointCounts of+    [] -> panelLeft+    firstCount : remainingCounts ->+      let minimumCount = firstCount+          maximumCount = foldr max firstCount remainingCounts+          countRange = maximumCount - minimumCount+       in if countRange == 0+            then panelLeft + panelWidth / 2+            else+              panelLeft+                + panelWidth+                  * fromIntegral (pointCount - minimumCount)+                  / fromIntegral countRange++pictureY :: Double -> Double -> Double+pictureY axisMaximum milliseconds =+  picturePlotBottom pictureLayout+    - plotHeight * min axisMaximum (max 0 milliseconds) / axisMaximum+ where+  plotHeight = picturePlotBottom pictureLayout - picturePlotTop pictureLayout++observationMeanMilliseconds :: BenchmarkObservation -> Double+observationMeanMilliseconds = picosecondsToMilliseconds . benchmarkMeanPicoseconds++observationUpperMilliseconds :: BenchmarkObservation -> Double+observationUpperMilliseconds observation =+  picosecondsToMilliseconds+    (benchmarkMeanPicoseconds observation + benchmarkSpreadPicoseconds observation)++observationLowerMilliseconds :: BenchmarkObservation -> Double+observationLowerMilliseconds observation =+  picosecondsToMilliseconds+    (max 0 (benchmarkMeanPicoseconds observation - benchmarkSpreadPicoseconds observation))++picosecondsToMilliseconds :: Double -> Double+picosecondsToMilliseconds picoseconds = picoseconds / 1.0e9++niceCeiling :: Double -> Double+niceCeiling value+  | value <= 0 = 1+  | otherwise = niceFraction * magnitude+ where+  magnitude = 10 ** fromIntegral (floor (logBase 10 value) :: Int)+  fraction = value / magnitude+  niceFraction+    | fraction <= 1 = 1+    | fraction <= 2 = 2+    | fraction <= 5 = 5+    | otherwise = 10++axisLabel :: Double -> String+axisLabel value+  | value >= 10 = showFFloat (Just 0) value ""+  | value >= 1 = showFFloat (Just 1) value ""+  | otherwise = showFFloat (Just 2) value ""++pointCountLabel :: Int -> String+pointCountLabel pointCount+  | pointCount `mod` 1000 == 0 = show (pointCount `div` 1000) <> "k"+  | otherwise = show pointCount++coordinate :: Double -> String+coordinate value = showFFloat (Just 1) value ""++svgText :: Double -> Double -> String -> Int -> String -> String -> String+svgText x y anchor fontSize fontWeight content =+  "<text x=\""+    <> coordinate x+    <> "\" y=\""+    <> coordinate y+    <> "\" text-anchor=\""+    <> anchor+    <> "\" font-family=\"Helvetica, Arial, sans-serif\" font-size=\""+    <> show fontSize+    <> "\" font-weight=\""+    <> fontWeight+    <> "\" fill=\"rgb(20,20,20)\">"+    <> content+    <> "</text>"
+ docs/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Suite.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Fixture descent, compatibility gluing, and the authoritative benchmark view.+module Moonlight.Triangulation.Bench.DelaunayCompare.Suite+  ( PreparedSuite+  , withPreparedSuite+  , preflightSuite+  , suiteBenchmarks+  , suiteAgreementMessage+  ) where++import Control.DeepSeq (force)+import Control.Exception (bracket, evaluate)+import Data.Bifunctor (first)+import Data.Either (lefts, rights)+import Data.Foldable (toList, traverse_)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Vector as Vector+import Moonlight.Triangulation.Bench.DelaunayCompare.Domain+import Moonlight.Triangulation.Bench.DelaunayCompare.Native+import Moonlight.Triangulation.BulkLoad (delaunayGeometry)+import Moonlight.Triangulation.Dcel (numInnerFaces, numVertices)+import Moonlight.Triangulation.Types (BuildError, Point (Point))+import Test.Tasty.Bench (Benchmark, bench, bgroup, nf, nfIO)++data NativeSections value = NativeSections+  { nativeSpadeSection :: !value+  , nativeSpadeHierarchySection :: !value+  , nativeCdtSection :: !value+  , nativeDelaunatorSection :: !value+  }+  deriving stock (Functor, Foldable, Traversable)++nativeImplementationSections :: NativeSections NativeImplementation+nativeImplementationSections =+  NativeSections+    { nativeSpadeSection = NativeSpade+    , nativeSpadeHierarchySection = NativeSpadeHierarchy+    , nativeCdtSection = NativeCdt+    , nativeDelaunatorSection = NativeDelaunator+    }++nativeSectionAt :: NativeImplementation -> NativeSections value -> value+nativeSectionAt implementation sections =+  case implementation of+    NativeSpade -> nativeSpadeSection sections+    NativeSpadeHierarchy -> nativeSpadeHierarchySection sections+    NativeCdt -> nativeCdtSection sections+    NativeDelaunator -> nativeDelaunatorSection sections++data PreparedFixture = PreparedFixture+  { preparedSpec :: !FixtureSpec+  , preparedMoonlightPoints :: !(Vector.Vector Point)+  , preparedNativeFixtures :: !(NativeSections NativeFixture)+  }++newtype PreparedSuite = PreparedSuite [PreparedFixture]++withPreparedSuite+  :: NativeApi+  -> (PreparedSuite -> IO (Either CompareObstruction result))+  -> IO (Either CompareObstruction result)+withPreparedSuite api action = do+  prepared <- prepareSuite api+  case prepared of+    Left obstruction -> pure (Left obstruction)+    Right suite -> bracket (pure suite) (releaseSuite api) action++prepareSuite :: NativeApi -> IO (Either CompareObstruction PreparedSuite)+prepareSuite api = do+  outcomes <- traverse (prepareFixture api) allFixtureSpecs+  case NonEmpty.nonEmpty (lefts outcomes) of+    Just obstructions -> do+      traverse_ (releasePreparedFixture api) (rights outcomes)+      pure (Left (ComparisonObstructions obstructions))+    Nothing -> pure (Right (PreparedSuite (rights outcomes)))++prepareFixture :: NativeApi -> FixtureSpec -> IO (Either CompareObstruction PreparedFixture)+prepareFixture api fixture = do+  generated <- generateCoordinates api fixture+  case generated of+    Left status -> pure (Left (FixtureGenerationFailed fixture status))+    Right coordinates -> do+      nativeFixtures <- prepareNativeFixtures api fixture coordinates+      pure $+        PreparedFixture+          fixture+          (Vector.map (uncurry Point) (generatedCoordinatePairs coordinates))+          <$> nativeFixtures++prepareNativeFixtures+  :: NativeApi+  -> FixtureSpec+  -> GeneratedCoordinates+  -> IO (Either CompareObstruction (NativeSections NativeFixture))+prepareNativeFixtures api fixture coordinates = do+  outcomes <- traverse prepareSection nativeImplementationSections+  case sequenceA outcomes of+    Right nativeFixtures -> pure (Right nativeFixtures)+    Left obstruction -> do+      traverse_ (releaseNativeFixture api) (rights (toList outcomes))+      pure (Left obstruction)+ where+  prepareSection implementation = do+    prepared <- prepareNativeFixture api implementation coordinates+    pure $+      first+        (preparationObstruction implementation)+        prepared++  preparationObstruction implementation failure =+    case failure of+      NativePreparationStatus status -> FixturePreparationFailed fixture implementation status+      NativePreparationReturnedNull -> NativePreparedNull fixture implementation++releaseSuite :: NativeApi -> PreparedSuite -> IO ()+releaseSuite api (PreparedSuite fixtures) =+  traverse_ (releasePreparedFixture api) fixtures++releasePreparedFixture :: NativeApi -> PreparedFixture -> IO ()+releasePreparedFixture api = releasePreparedNativeFixtures api . preparedNativeFixtures++releasePreparedNativeFixtures :: NativeApi -> NativeSections NativeFixture -> IO ()+releasePreparedNativeFixtures api = traverse_ (releaseNativeFixture api)++preflightSuite :: NativeApi -> PreparedSuite -> IO (Either CompareObstruction ())+preflightSuite api (PreparedSuite fixtures) = do+  outcomes <- traverse (preflightFixture api) fixtures+  pure $+    case NonEmpty.nonEmpty (lefts outcomes) of+      Just obstructions -> Left (ComparisonObstructions obstructions)+      Nothing -> Right ()++preflightFixture :: NativeApi -> PreparedFixture -> IO (Either CompareObstruction ())+preflightFixture api fixture = do+  moonlightResult <-+    evaluate+      ( force+          (moonlightConstructionSummary (preparedMoonlightPoints fixture))+      )+  nativeOutcomes <- traverse runSection nativeImplementationSections+  pure $ do+    moonlightSummary <-+      first+        (MoonlightConstructionFailed spec)+        moonlightResult+    nativeSummaries <- sequenceA nativeOutcomes+    traverse_+      ( \implementation ->+          requireSummaryAgreement+            spec+            moonlightSummary+            ( implementationOfNative implementation+            , nativeSectionAt implementation nativeSummaries+            )+      )+      nativeImplementationSections+ where+  spec = preparedSpec fixture+  nativeFixtures = preparedNativeFixtures fixture+  runSection implementation =+    first (NativeConstructionFailed spec implementation)+      <$> runNativeFixture api (nativeSectionAt implementation nativeFixtures)++requireSummaryAgreement+  :: FixtureSpec+  -> DelaunaySummary+  -> (Implementation, DelaunaySummary)+  -> Either CompareObstruction ()+requireSummaryAgreement fixture expected (implementation, observed) =+  if observed == expected+    then Right ()+    else Left (SummaryDisagreement fixture implementation expected observed)++moonlightConstructionSummary+  :: Vector.Vector Point+  -> Either BuildError DelaunaySummary+moonlightConstructionSummary points = do+  triangulation <- delaunayGeometry points+  pure+    DelaunaySummary+      { summaryVertexCount = numVertices triangulation+      , summaryTriangleCount = numInnerFaces triangulation+      }++suiteBenchmarks :: NativeApi -> PreparedSuite -> [Benchmark]+suiteBenchmarks api (PreparedSuite fixtures) =+  fmap (sizeBandBenchmarks api fixtures) allSizeBands++sizeBandBenchmarks+  :: NativeApi+  -> [PreparedFixture]+  -> SizeBand+  -> Benchmark+sizeBandBenchmarks api fixtures sizeBand =+  bgroup+    ("comparison: creation benchmark (" <> sizeBandLabel sizeBand <> ")")+    (fmap (implementationBenchmarks api fixtures sizeBand) allImplementations)++implementationBenchmarks+  :: NativeApi+  -> [PreparedFixture]+  -> SizeBand+  -> Implementation+  -> Benchmark+implementationBenchmarks api fixtures sizeBand implementation =+  bgroup+    (implementationLabel implementation)+    ( fmap+        (distributionBenchmarks api fixtures sizeBand implementation)+        allPointDistributions+    )++distributionBenchmarks+  :: NativeApi+  -> [PreparedFixture]+  -> SizeBand+  -> Implementation+  -> PointDistribution+  -> Benchmark+distributionBenchmarks api fixtures sizeBand implementation distribution =+  bgroup+    (pointDistributionLabel distribution)+    ( fmap+        (fixtureBenchmark api implementation)+        ( filter+            (matchesFixture sizeBand distribution . preparedSpec)+            fixtures+        )+    )++matchesFixture :: SizeBand -> PointDistribution -> FixtureSpec -> Bool+matchesFixture sizeBand distribution fixture =+  fixtureSizeBand fixture == sizeBand+    && fixturePointDistribution fixture == distribution++fixtureBenchmark :: NativeApi -> Implementation -> PreparedFixture -> Benchmark+fixtureBenchmark api implementation fixture =+  bench (show (pointCountValue (fixturePointCount (preparedSpec fixture)))) $+    case implementation of+      Moonlight -> nf moonlightConstructionSummary (preparedMoonlightPoints fixture)+      Spade -> nativeBenchmark NativeSpade+      SpadeHierarchy -> nativeBenchmark NativeSpadeHierarchy+      Cdt -> nativeBenchmark NativeCdt+      Delaunator -> nativeBenchmark NativeDelaunator+ where+  nativeFixtures = preparedNativeFixtures fixture+  nativeBenchmark nativeImplementation =+    nfIO (runNativeFixture api (nativeSectionAt nativeImplementation nativeFixtures))++suiteAgreementMessage :: String+suiteAgreementMessage =+  "delaunay-compare agreement: "+    <> show (length allFixtureSpecs)+    <> " fixtures agree on vertex and triangle counts across "+    <> show (length allImplementations)+    <> " implementations"
+ docs/delaunay-compare/PictureMain.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeApplications #-}++-- | Thin effect boundary for rendering benchmark receipts as SVG pictures.+module Main (main) where++import Control.Exception (IOException, displayException, try)+import Control.Monad.Trans.Except (ExceptT (ExceptT), except, runExceptT)+import Data.Bifunctor (first)+import Data.Foldable (traverse_)+import Moonlight.Triangulation.Bench.DelaunayCompare.Domain (allSizeBands)+import Moonlight.Triangulation.Bench.DelaunayCompare.Picture+import System.Directory (createDirectoryIfMissing)+import System.Environment (getArgs)+import System.Exit (die)+import System.FilePath ((</>))+import System.IO (readFile')++data PictureCommandFailure+  = PictureCommandUsage+  | PictureCommandReadFailed !FilePath !String+  | PictureCommandCreateDirectoryFailed !FilePath !String+  | PictureCommandReceiptObstructed !PictureObstruction+  | PictureCommandWriteFailed !FilePath !String++main :: IO ()+main = do+  arguments <- getArgs+  outcome <- runExceptT (runPictureCommand arguments)+  either (die . renderPictureCommandFailure) pure outcome++runPictureCommand :: [String] -> ExceptT PictureCommandFailure IO ()+runPictureCommand = \case+  [inputCsv, outputDirectory] -> do+    source <-+      ExceptT+        ( first+            (PictureCommandReadFailed inputCsv . displayException)+            <$> try @IOException (readFile' inputCsv)+        )+    receipt <- except (first PictureCommandReceiptObstructed (parseBenchmarkReceipt source))+    let pictures =+          ( \sizeBand ->+              (pictureFileName sizeBand, renderComparisonPicture sizeBand receipt)+          )+            <$> allSizeBands+    ExceptT+      ( first+          (PictureCommandCreateDirectoryFailed outputDirectory . displayException)+          <$> try @IOException (createDirectoryIfMissing True outputDirectory)+      )+    traverse_ (writePicture outputDirectory) pictures+  _ -> except (Left PictureCommandUsage)++writePicture :: FilePath -> (FilePath, String) -> ExceptT PictureCommandFailure IO ()+writePicture outputDirectory (fileName, svgDocument) =+  let outputPath = outputDirectory </> fileName+   in ExceptT+        ( first+            (PictureCommandWriteFailed outputPath . displayException)+            <$> try @IOException (writeFile outputPath svgDocument)+        )++renderPictureCommandFailure :: PictureCommandFailure -> String+renderPictureCommandFailure = \case+  PictureCommandUsage ->+    "usage: moonlight-triangulation-delaunay-pictures INPUT.csv OUTPUT_DIRECTORY"+  PictureCommandReadFailed path details ->+    "could not read benchmark CSV " <> path <> ": " <> details+  PictureCommandCreateDirectoryFailed path details ->+    "could not create picture directory " <> path <> ": " <> details+  PictureCommandReceiptObstructed obstruction ->+    renderPictureObstruction obstruction+  PictureCommandWriteFailed path details ->+    "could not write comparison picture " <> path <> ": " <> details
+ docs/delaunay-compare/README.md view
@@ -0,0 +1,191 @@+# Moonlight Delaunay Compare++[Browse all exhibits.](../README.md)++`moonlight-triangulation-delaunay-compare` is Moonlight's package-owned port of Spade's+[`delaunay_compare`](https://github.com/Stoeoef/spade/tree/c8befc96bbbc1898a89cb19f9f3104a848936374/delaunay_compare)+construction suite. It retains the upstream case matrix and appends+`moonlight-triangulation` to the implementation list:++1. `spade 2`+2. `spade 2 hierarchy`+3. `cdt`+4. `delaunator`+5. `moonlight-triangulation`++Haskell owns fixture selection, grouping, compatibility descent, timing, and+reporting. The Rust library under `rust/src/lib.rs` is only a typed foreign+boundary to the four Rust implementations and to the exact upstream `rand`+fixture stream; it contains no benchmark policy.++This page owns only the construction slice. The+[operation comparison](../../bench/spade-compare/README.md) owns the broader+Moonlight–Spade board.++## Pictures++Both pictures are derived from the single retained board.++![Small-point Delaunay construction comparison](results/moonlight-delaunay-compare-small.svg)++![Big-point Delaunay construction comparison](results/moonlight-delaunay-compare-big.svg)++These retain Spade's plain GNUPLOT idiom: white field, Helvetica, dashed grey+grid, jewel-coloured point series, and the same small/big split. Moonlight is+the heavier orange star. The faint triangulation mesh is the sole bit of+levity; benchmark charts need not resemble tax forms.++## Result++- timed cases: `120`+- fixture summaries agreeing across all five implementations: `24 / 24`+- Moonlight mean below plain Spade: `24 / 24`+- Moonlight mean below Spade hierarchy: `24 / 24`+- Moonlight below plain Spade with non-overlapping reported 2σ: `18 / 24`+- Moonlight below Spade hierarchy with non-overlapping reported 2σ: `22 / 24`+- lowest fixture mean: `delaunator` `21 / 24`; `cdt` `3 / 24`+- median reported 2σ / mean: Moonlight `6.88%`; plain Spade `6.67%`++Selected means are in milliseconds. Δ is+`100 × (Moonlight / competitor − 1)`.++| fixture | points | Moonlight | plain Spade | Δ | Spade hierarchy | Δ |+|---|---:|---:|---:|---:|---:|---:|+| local insertion | 4,000 | 0.587 | 0.771 | −23.8% | 0.800 | −26.6% |+| local insertion | 6,000 | 0.971 | 1.300 | −25.3% | 1.365 | −28.9% |+| local insertion | 8,000 | 1.354 | 1.776 | −23.7% | 1.903 | −28.8% |+| local insertion | 250,000 | 60.300 | 72.713 | −17.1% | 77.496 | −22.2% |+| uniform | 4,000 | 0.552 | 0.706 | −21.8% | 0.741 | −25.6% |+| uniform | 14,000 | 2.663 | 3.067 | −13.2% | 3.318 | −19.7% |+| uniform | 250,000 | 60.028 | 72.783 | −17.5% | 77.435 | −22.5% |++The measured Moonlight path is the canonical circle-sweep bulk loader. Its+geometry ingress keeps coordinates in immutable planes, moves only a 32-bit+vertex-id plane through three radix passes, and restores the complete+`(distance, x, y, vertex)` order inside equal-prefix fibres before descent.+Fresh dense vertices are committed once, and the sweep consumes reserved cells+without constructing a second packed geometry arena.++Receipt identity:++- command completed: `2026-08-23T00:00:15Z`, 318.68 s over 120 cases+- host: Apple M4 Pro, arm64, macOS 26.5.2, GHC 9.14.1, rustc 1.92.0+- Haskell build: cabal-install 3.16.1.0, focused `-O1` package profile,+  comparison executable `-O2`, hot predicate, sweep, and repair modules LLVM+  `-O3`+- checkout base HEAD: `41906f44f0`, plus the three optimized runtime-source+  owners named by the manifest+- CSV: [`moonlight-delaunay-compare-2026-08-22.csv`](results/moonlight-delaunay-compare-2026-08-22.csv), SHA-256+  `cce6af4ac7d570970a69124f5648db4e13ca41e91e05383306407a0dca323be7`+- benchmark runtime-source hashes:+  [`moonlight-delaunay-compare-2026-08-22.source-sha256`](results/moonlight-delaunay-compare-2026-08-22.source-sha256), SHA-256+  `069d3bb1639b6d865fe4491b2fbbb9d0cdc8324173e30bebf690ed6592190c20`++The Haskell projection in+`Moonlight.Triangulation.Bench.DelaunayCompare.Picture` parses the tasty-bench+CSV against the exact closed 120-case registry and reports typed obstructions+for malformed, unknown, duplicated, or missing observations before gluing+either picture.++## Run++From the repository root, list the complete benchmark tree:++```console+scripts/safe-cabal.sh run \+  moonlight-planar:exe:moonlight-triangulation-delaunay-compare \+  --project-file=cabal.project.planar-dev \+  -- --list-tests+```++Run the comparison on one uncontended thread with wall-clock timing:++```console+scripts/safe-cabal.sh run \+  moonlight-planar:exe:moonlight-triangulation-delaunay-compare \+  --project-file=cabal.project.planar-dev \+  -- --time-mode wall -j1+```++The Haskell executable builds the pinned Rust library through Cargo before it+loads the library. Cargo's incremental no-op is cheap after the first run. Set+`MOONLIGHT_DELAUNAY_COMPARE_RUST_MANIFEST` only when invoking an installed executable+outside this repository layout.++## Reproduce a board++Every candidate run uses one CPU-time worker, a 30-second per-case timeout, and+tasty-bench's `--stdev 5` calibration target. Name the candidate by the date it+completed; after validation, it replaces the retained CSV and source manifest+rather than accumulating a benchmark diary.++```console+caffeinate -i scripts/safe-cabal.sh run \+  moonlight-planar:exe:moonlight-triangulation-delaunay-compare \+  --project-file=cabal.project.planar-dev -- \+  --stdev 5 --timeout 30s --time-mode cpu -j1 \+  --csv foundation/moonlight-planar/docs/delaunay-compare/results/moonlight-delaunay-compare-YYYY-MM-DD.csv \+  --color never --hide-progress --min-duration-to-report 1h+```++Both pictures are then regenerated from the candidate CSV, which is the only+CSV they may be derived from:++```console+scripts/safe-cabal.sh run \+  moonlight-planar:exe:moonlight-triangulation-delaunay-pictures \+  --project-file=cabal.project.planar-dev -- \+  foundation/moonlight-planar/docs/delaunay-compare/results/moonlight-delaunay-compare-YYYY-MM-DD.csv \+  foundation/moonlight-planar/docs/delaunay-compare/results+```++The runtime-source manifest beside the CSV is regenerated from the measured+worktree immediately after a completed command. It hashes the closed list of+files that entered timed actions; picture sources and package-only metadata are+excluded because they did not. The receipt, CSV, and big SVG stay+benchmark-owned beside the executable and outside Cabal package inputs. The+small SVG is also the package documentation projection, so it enters the sdist+without entering any compiled component.++## Upstream-compatible fixtures++Both distributions use the 32-byte `StdRng` seed from upstream, including its+embedded newline byte. Rust unit tests pin the first three points of both+streams by their exact binary64 bit patterns.++- `local insertion` starts at `(0, 1)` and adds independent inclusive steps+  from `[-1, 1]`.+- `uniform` draws each coordinate independently and inclusively from+  `[-1e9, 1e9]`.+- `small` contains 2,000 through 14,000 points in increments of 2,000.+- `big` contains 50,000 through 250,000 points in increments of 50,000.++Native input conversion happens once during suite preparation, outside every+timed action, exactly as upstream's `DelaunayCrate.init` separates conversion+from `run_creation`. Spade still clones its owned vertex vector inside each+construction call because that is what its bulk-load API and upstream adapter+require; `cdt`, `delaunator`, and Moonlight consume their prepared vectors by+reference.++## Compatibility gate++Before `tasty-bench` runs, every one of the 24 fixtures descends across all five+implementations. The sections glue only when vertex and inner-triangle counts+agree. A generator, preparation, construction, foreign-boundary, or summary+failure is a typed obstruction and terminates the command before timing.++This count gate is deliberately not a second topology authority. The broader+operation comparison owns canonical-edge and operation agreement. This command+answers the narrower upstream question: bulk construction time over the+upstream point distributions and sizes.++The upstream `examples/real_data_benchmark.rs` CDT/shapefile program is a+separate executable and is not folded into this creation suite. No 45 MB dataset+or network fetch is concealed in benchmark startup.++## Harness difference++Upstream uses Rust Criterion. This port uses Haskell `tasty-bench`, so it does+not pretend Criterion's warm-up seconds or sample-count knobs map one-to-one to+another calibrator. The inputs, sizes, implementation calls, and timed/setup+boundary are preserved; calibration and reporting are honestly Haskell.
+ docs/delaunay-compare/results/moonlight-delaunay-compare-small.svg view
@@ -0,0 +1,415 @@+<?xml version="1.0" encoding="utf-8"?>+<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 1280.0 720.0" role="img" aria-labelledby="title description">+<title id="title">Moonlight Delaunay construction · small point sets</title>+<desc id="description">CPU construction time for Spade, cdt, delaunator, and Moonlight over the upstream Delaunay comparison fixtures. Lower lines are faster.</desc>+<defs>+  <pattern id="triangulation-mesh" width="54" height="46" patternUnits="userSpaceOnUse">+    <path d="M0 46L27 0L54 46ZM0 46L54 46M27 0L27 46" fill="none" stroke="rgb(255,140,0)" stroke-width="0.7"/>+  </pattern>+  <clipPath id="header-mesh-clip"><rect x="955" y="8" width="290" height="82" rx="20"/></clipPath>+</defs>+<rect width="1280.0" height="720.0" fill="white"/>+<rect x="955" y="8" width="290" height="82" fill="url(#triangulation-mesh)" opacity="0.10" clip-path="url(#header-mesh-clip)"/>+<text x="640.0" y="34.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="24" font-weight="500" fill="rgb(20,20,20)">Moonlight Delaunay construction · small point sets</text>+<text x="640.0" y="61.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="13" font-weight="400" fill="rgb(20,20,20)">Moonlight against Spade's construction referents · CPU time · lower is faster</text>+<g aria-label="spade 2">+  <line x1="105.0" y1="101" x2="139.0" y2="101" stroke="rgb(0,0,139)" stroke-width="2.0"/>+  <circle cx="122.0" cy="101.0" r="3.2" fill="white" stroke="rgb(0,0,139)" stroke-width="1.6"/>+  <text x="148.0" y="105.0" text-anchor="start" font-family="Helvetica, Arial, sans-serif" font-size="12" font-weight="400" fill="rgb(20,20,20)">spade 2</text>+</g>+<g aria-label="spade 2 hierarchy">+  <line x1="315.0" y1="101" x2="349.0" y2="101" stroke="rgb(139,0,139)" stroke-width="2.0" stroke-dasharray="7 4"/>+  <path d="M 332.0 96.7 L 327.9 104.5 L 336.1 104.5 Z" fill="white" stroke="rgb(139,0,139)" stroke-width="1.6"/>+  <text x="358.0" y="105.0" text-anchor="start" font-family="Helvetica, Arial, sans-serif" font-size="12" font-weight="400" fill="rgb(20,20,20)">spade 2 hierarchy</text>+</g>+<g aria-label="cdt">+  <line x1="560.0" y1="101" x2="594.0" y2="101" stroke="rgb(178,34,34)" stroke-width="2.0"/>+  <rect x="573.8" y="97.8" width="6.4" height="6.4" fill="white" stroke="rgb(178,34,34)" stroke-width="1.6"/>+  <text x="603.0" y="105.0" text-anchor="start" font-family="Helvetica, Arial, sans-serif" font-size="12" font-weight="400" fill="rgb(20,20,20)">cdt</text>+</g>+<g aria-label="delaunator">+  <line x1="735.0" y1="101" x2="769.0" y2="101" stroke="rgb(0,139,139)" stroke-width="2.0"/>+  <path d="M 752.0 96.8 L 756.2 101.0 L 752.0 105.2 L 747.8 101.0 Z" fill="white" stroke="rgb(0,139,139)" stroke-width="1.6"/>+  <text x="778.0" y="105.0" text-anchor="start" font-family="Helvetica, Arial, sans-serif" font-size="12" font-weight="400" fill="rgb(20,20,20)">delaunator</text>+</g>+<g aria-label="moonlight-triangulation">+  <line x1="940.0" y1="101" x2="974.0" y2="101" stroke="rgb(255,140,0)" stroke-width="3.2"/>+  <path d="M 957.0 95.6 L 958.7 99.3 L 962.4 101.0 L 958.7 102.7 L 957.0 106.4 L 955.3 102.7 L 951.6 101.0 L 955.3 99.3 Z" fill="rgb(255,140,0)" stroke="white" stroke-width="1"/>+  <text x="983.0" y="105.0" text-anchor="start" font-family="Helvetica, Arial, sans-serif" font-size="12" font-weight="400" fill="rgb(20,20,20)">moonlight-triangulation</text>+</g>+<g aria-label="local insertion">+<text x="340.0" y="144.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="15" font-weight="500" fill="rgb(20,20,20)">local insertion</text>+<line x1="70.0" y1="610.0" x2="610.0" y2="610.0" stroke="rgb(170,170,170)" stroke-width="0.7" stroke-dasharray="2 4"/>+<text x="60.0" y="614.0" text-anchor="end" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">0.00</text>+<line x1="70.0" y1="521.6" x2="610.0" y2="521.6" stroke="rgb(170,170,170)" stroke-width="0.7" stroke-dasharray="2 4"/>+<text x="60.0" y="525.6" text-anchor="end" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">1.0</text>+<line x1="70.0" y1="433.2" x2="610.0" y2="433.2" stroke="rgb(170,170,170)" stroke-width="0.7" stroke-dasharray="2 4"/>+<text x="60.0" y="437.2" text-anchor="end" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">2.0</text>+<line x1="70.0" y1="344.8" x2="610.0" y2="344.8" stroke="rgb(170,170,170)" stroke-width="0.7" stroke-dasharray="2 4"/>+<text x="60.0" y="348.8" text-anchor="end" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">3.0</text>+<line x1="70.0" y1="256.4" x2="610.0" y2="256.4" stroke="rgb(170,170,170)" stroke-width="0.7" stroke-dasharray="2 4"/>+<text x="60.0" y="260.4" text-anchor="end" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">4.0</text>+<line x1="70.0" y1="168.0" x2="610.0" y2="168.0" stroke="rgb(170,170,170)" stroke-width="0.7" stroke-dasharray="2 4"/>+<text x="60.0" y="172.0" text-anchor="end" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">5.0</text>+<line x1="70.0" y1="610" x2="70.0" y2="616" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="70.0" y="635.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">2k</text>+<line x1="160.0" y1="610" x2="160.0" y2="616" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="160.0" y="635.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">4k</text>+<line x1="250.0" y1="610" x2="250.0" y2="616" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="250.0" y="635.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">6k</text>+<line x1="340.0" y1="610" x2="340.0" y2="616" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="340.0" y="635.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">8k</text>+<line x1="430.0" y1="610" x2="430.0" y2="616" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="430.0" y="635.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">10k</text>+<line x1="520.0" y1="610" x2="520.0" y2="616" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="520.0" y="635.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">12k</text>+<line x1="610.0" y1="610" x2="610.0" y2="616" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="610.0" y="635.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">14k</text>+<rect x="70.0" y="168.0" width="540.0" height="442.0" fill="none" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="340.0" y="664.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="12" font-weight="400" fill="rgb(20,20,20)">input size (points)</text>+<text x="15.0" y="389.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="12" fill="rgb(20,20,20)" transform="rotate(-90 15.0 389.0)">CPU time (ms)</text>+<g aria-label="spade 2">+  <polyline points="70.0,583.1 160.0,541.9 250.0,495.1 340.0,453.0 430.0,407.7 520.0,366.9 610.0,314.3" fill="none" stroke="rgb(0,0,139)" stroke-width="2.0" stroke-linecap="round" stroke-linejoin="round"/>+  <line x1="70.0" y1="581.7" x2="70.0" y2="584.5" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="67.0" y1="581.7" x2="73.0" y2="581.7" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="67.0" y1="584.5" x2="73.0" y2="584.5" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <circle cx="70.0" cy="583.1" r="3.2" fill="white" stroke="rgb(0,0,139)" stroke-width="1.6"/>+  <line x1="160.0" y1="537.6" x2="160.0" y2="546.2" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="157.0" y1="537.6" x2="163.0" y2="537.6" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="157.0" y1="546.2" x2="163.0" y2="546.2" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <circle cx="160.0" cy="541.9" r="3.2" fill="white" stroke="rgb(0,0,139)" stroke-width="1.6"/>+  <line x1="250.0" y1="487.9" x2="250.0" y2="502.2" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="247.0" y1="487.9" x2="253.0" y2="487.9" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="247.0" y1="502.2" x2="253.0" y2="502.2" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <circle cx="250.0" cy="495.1" r="3.2" fill="white" stroke="rgb(0,0,139)" stroke-width="1.6"/>+  <line x1="340.0" y1="445.2" x2="340.0" y2="460.9" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="337.0" y1="445.2" x2="343.0" y2="445.2" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="337.0" y1="460.9" x2="343.0" y2="460.9" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <circle cx="340.0" cy="453.0" r="3.2" fill="white" stroke="rgb(0,0,139)" stroke-width="1.6"/>+  <line x1="430.0" y1="395.0" x2="430.0" y2="420.4" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="427.0" y1="395.0" x2="433.0" y2="395.0" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="427.0" y1="420.4" x2="433.0" y2="420.4" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <circle cx="430.0" cy="407.7" r="3.2" fill="white" stroke="rgb(0,0,139)" stroke-width="1.6"/>+  <line x1="520.0" y1="354.2" x2="520.0" y2="379.6" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="517.0" y1="354.2" x2="523.0" y2="354.2" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="517.0" y1="379.6" x2="523.0" y2="379.6" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <circle cx="520.0" cy="366.9" r="3.2" fill="white" stroke="rgb(0,0,139)" stroke-width="1.6"/>+  <line x1="610.0" y1="291.9" x2="610.0" y2="336.8" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="607.0" y1="291.9" x2="613.0" y2="291.9" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="607.0" y1="336.8" x2="613.0" y2="336.8" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <circle cx="610.0" cy="314.3" r="3.2" fill="white" stroke="rgb(0,0,139)" stroke-width="1.6"/>+</g>+<g aria-label="spade 2 hierarchy">+  <polyline points="70.0,582.7 160.0,539.3 250.0,489.3 340.0,441.8 430.0,391.2 520.0,346.0 610.0,292.9" fill="none" stroke="rgb(139,0,139)" stroke-width="2.0" stroke-linecap="round" stroke-linejoin="round" stroke-dasharray="7 4"/>+  <line x1="70.0" y1="580.0" x2="70.0" y2="585.3" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="67.0" y1="580.0" x2="73.0" y2="580.0" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="67.0" y1="585.3" x2="73.0" y2="585.3" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 70.0 578.4 L 65.9 586.2 L 74.1 586.2 Z" fill="white" stroke="rgb(139,0,139)" stroke-width="1.6"/>+  <line x1="160.0" y1="532.3" x2="160.0" y2="546.2" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="157.0" y1="532.3" x2="163.0" y2="532.3" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="157.0" y1="546.2" x2="163.0" y2="546.2" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 160.0 535.0 L 155.9 542.8 L 164.1 542.8 Z" fill="white" stroke="rgb(139,0,139)" stroke-width="1.6"/>+  <line x1="250.0" y1="482.4" x2="250.0" y2="496.2" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="247.0" y1="482.4" x2="253.0" y2="482.4" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="247.0" y1="496.2" x2="253.0" y2="496.2" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 250.0 485.0 L 245.9 492.8 L 254.1 492.8 Z" fill="white" stroke="rgb(139,0,139)" stroke-width="1.6"/>+  <line x1="340.0" y1="430.2" x2="340.0" y2="453.3" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="337.0" y1="430.2" x2="343.0" y2="430.2" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="337.0" y1="453.3" x2="343.0" y2="453.3" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 340.0 437.5 L 335.9 445.3 L 344.1 445.3 Z" fill="white" stroke="rgb(139,0,139)" stroke-width="1.6"/>+  <line x1="430.0" y1="381.5" x2="430.0" y2="400.9" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="427.0" y1="381.5" x2="433.0" y2="381.5" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="427.0" y1="400.9" x2="433.0" y2="400.9" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 430.0 386.9 L 425.9 394.7 L 434.1 394.7 Z" fill="white" stroke="rgb(139,0,139)" stroke-width="1.6"/>+  <line x1="520.0" y1="324.9" x2="520.0" y2="367.2" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="517.0" y1="324.9" x2="523.0" y2="324.9" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="517.0" y1="367.2" x2="523.0" y2="367.2" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 520.0 341.7 L 515.9 349.5 L 524.1 349.5 Z" fill="white" stroke="rgb(139,0,139)" stroke-width="1.6"/>+  <line x1="610.0" y1="274.3" x2="610.0" y2="311.5" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="607.0" y1="274.3" x2="613.0" y2="274.3" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="607.0" y1="311.5" x2="613.0" y2="311.5" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 610.0 288.6 L 605.9 296.4 L 614.1 296.4 Z" fill="white" stroke="rgb(139,0,139)" stroke-width="1.6"/>+</g>+<g aria-label="cdt">+  <polyline points="70.0,593.6 160.0,570.7 250.0,538.0 340.0,506.8 430.0,475.6 520.0,445.6 610.0,411.9" fill="none" stroke="rgb(178,34,34)" stroke-width="2.0" stroke-linecap="round" stroke-linejoin="round"/>+  <line x1="70.0" y1="592.9" x2="70.0" y2="594.2" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="67.0" y1="592.9" x2="73.0" y2="592.9" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="67.0" y1="594.2" x2="73.0" y2="594.2" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <rect x="66.8" y="590.4" width="6.4" height="6.4" fill="white" stroke="rgb(178,34,34)" stroke-width="1.6"/>+  <line x1="160.0" y1="567.9" x2="160.0" y2="573.5" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="157.0" y1="567.9" x2="163.0" y2="567.9" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="157.0" y1="573.5" x2="163.0" y2="573.5" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <rect x="156.8" y="567.5" width="6.4" height="6.4" fill="white" stroke="rgb(178,34,34)" stroke-width="1.6"/>+  <line x1="250.0" y1="532.4" x2="250.0" y2="543.6" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="247.0" y1="532.4" x2="253.0" y2="532.4" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="247.0" y1="543.6" x2="253.0" y2="543.6" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <rect x="246.8" y="534.8" width="6.4" height="6.4" fill="white" stroke="rgb(178,34,34)" stroke-width="1.6"/>+  <line x1="340.0" y1="500.2" x2="340.0" y2="513.3" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="337.0" y1="500.2" x2="343.0" y2="500.2" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="337.0" y1="513.3" x2="343.0" y2="513.3" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <rect x="336.8" y="503.6" width="6.4" height="6.4" fill="white" stroke="rgb(178,34,34)" stroke-width="1.6"/>+  <line x1="430.0" y1="468.6" x2="430.0" y2="482.6" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="427.0" y1="468.6" x2="433.0" y2="468.6" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="427.0" y1="482.6" x2="433.0" y2="482.6" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <rect x="426.8" y="472.4" width="6.4" height="6.4" fill="white" stroke="rgb(178,34,34)" stroke-width="1.6"/>+  <line x1="520.0" y1="435.9" x2="520.0" y2="455.3" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="517.0" y1="435.9" x2="523.0" y2="435.9" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="517.0" y1="455.3" x2="523.0" y2="455.3" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <rect x="516.8" y="442.4" width="6.4" height="6.4" fill="white" stroke="rgb(178,34,34)" stroke-width="1.6"/>+  <line x1="610.0" y1="392.8" x2="610.0" y2="430.9" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="607.0" y1="392.8" x2="613.0" y2="392.8" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="607.0" y1="430.9" x2="613.0" y2="430.9" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <rect x="606.8" y="408.7" width="6.4" height="6.4" fill="white" stroke="rgb(178,34,34)" stroke-width="1.6"/>+</g>+<g aria-label="delaunator">+  <polyline points="70.0,597.4 160.0,580.1 250.0,554.3 340.0,527.1 430.0,495.7 520.0,461.5 610.0,432.1" fill="none" stroke="rgb(0,139,139)" stroke-width="2.0" stroke-linecap="round" stroke-linejoin="round"/>+  <line x1="70.0" y1="596.7" x2="70.0" y2="598.0" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="67.0" y1="596.7" x2="73.0" y2="596.7" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="67.0" y1="598.0" x2="73.0" y2="598.0" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 70.0 593.2 L 74.2 597.4 L 70.0 601.6 L 65.8 597.4 Z" fill="white" stroke="rgb(0,139,139)" stroke-width="1.6"/>+  <line x1="160.0" y1="577.8" x2="160.0" y2="582.4" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="157.0" y1="577.8" x2="163.0" y2="577.8" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="157.0" y1="582.4" x2="163.0" y2="582.4" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 160.0 575.9 L 164.2 580.1 L 160.0 584.3 L 155.8 580.1 Z" fill="white" stroke="rgb(0,139,139)" stroke-width="1.6"/>+  <line x1="250.0" y1="550.2" x2="250.0" y2="558.5" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="247.0" y1="550.2" x2="253.0" y2="550.2" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="247.0" y1="558.5" x2="253.0" y2="558.5" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 250.0 550.1 L 254.2 554.3 L 250.0 558.5 L 245.8 554.3 Z" fill="white" stroke="rgb(0,139,139)" stroke-width="1.6"/>+  <line x1="340.0" y1="522.0" x2="340.0" y2="532.2" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="337.0" y1="522.0" x2="343.0" y2="522.0" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="337.0" y1="532.2" x2="343.0" y2="532.2" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 340.0 522.9 L 344.2 527.1 L 340.0 531.3 L 335.8 527.1 Z" fill="white" stroke="rgb(0,139,139)" stroke-width="1.6"/>+  <line x1="430.0" y1="486.9" x2="430.0" y2="504.5" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="427.0" y1="486.9" x2="433.0" y2="486.9" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="427.0" y1="504.5" x2="433.0" y2="504.5" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 430.0 491.5 L 434.2 495.7 L 430.0 499.9 L 425.8 495.7 Z" fill="white" stroke="rgb(0,139,139)" stroke-width="1.6"/>+  <line x1="520.0" y1="453.0" x2="520.0" y2="470.1" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="517.0" y1="453.0" x2="523.0" y2="453.0" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="517.0" y1="470.1" x2="523.0" y2="470.1" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 520.0 457.3 L 524.2 461.5 L 520.0 465.7 L 515.8 461.5 Z" fill="white" stroke="rgb(0,139,139)" stroke-width="1.6"/>+  <line x1="610.0" y1="418.1" x2="610.0" y2="446.1" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="607.0" y1="418.1" x2="613.0" y2="418.1" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="607.0" y1="446.1" x2="613.0" y2="446.1" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 610.0 427.9 L 614.2 432.1 L 610.0 436.3 L 605.8 432.1 Z" fill="white" stroke="rgb(0,139,139)" stroke-width="1.6"/>+</g>+<g aria-label="moonlight-triangulation">+  <polyline points="70.0,585.5 160.0,558.1 250.0,524.2 340.0,490.3 430.0,456.2 520.0,417.5 610.0,361.2" fill="none" stroke="rgb(255,140,0)" stroke-width="3.2" stroke-linecap="round" stroke-linejoin="round"/>+  <line x1="70.0" y1="583.9" x2="70.0" y2="587.1" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="67.0" y1="583.9" x2="73.0" y2="583.9" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="67.0" y1="587.1" x2="73.0" y2="587.1" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 70.0 580.1 L 71.7 583.8 L 75.4 585.5 L 71.7 587.2 L 70.0 590.9 L 68.3 587.2 L 64.6 585.5 L 68.3 583.8 Z" fill="rgb(255,140,0)" stroke="white" stroke-width="1"/>+  <line x1="160.0" y1="554.3" x2="160.0" y2="561.9" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="157.0" y1="554.3" x2="163.0" y2="554.3" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="157.0" y1="561.9" x2="163.0" y2="561.9" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 160.0 552.7 L 161.7 556.4 L 165.4 558.1 L 161.7 559.8 L 160.0 563.5 L 158.3 559.8 L 154.6 558.1 L 158.3 556.4 Z" fill="rgb(255,140,0)" stroke="white" stroke-width="1"/>+  <line x1="250.0" y1="518.4" x2="250.0" y2="529.9" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="247.0" y1="518.4" x2="253.0" y2="518.4" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="247.0" y1="529.9" x2="253.0" y2="529.9" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 250.0 518.8 L 251.7 522.5 L 255.4 524.2 L 251.7 525.9 L 250.0 529.6 L 248.3 525.9 L 244.6 524.2 L 248.3 522.5 Z" fill="rgb(255,140,0)" stroke="white" stroke-width="1"/>+  <line x1="340.0" y1="480.9" x2="340.0" y2="499.6" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="337.0" y1="480.9" x2="343.0" y2="480.9" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="337.0" y1="499.6" x2="343.0" y2="499.6" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 340.0 484.9 L 341.7 488.6 L 345.4 490.3 L 341.7 492.0 L 340.0 495.7 L 338.3 492.0 L 334.6 490.3 L 338.3 488.6 Z" fill="rgb(255,140,0)" stroke="white" stroke-width="1"/>+  <line x1="430.0" y1="449.5" x2="430.0" y2="462.9" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="427.0" y1="449.5" x2="433.0" y2="449.5" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="427.0" y1="462.9" x2="433.0" y2="462.9" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 430.0 450.8 L 431.7 454.5 L 435.4 456.2 L 431.7 457.9 L 430.0 461.6 L 428.3 457.9 L 424.6 456.2 L 428.3 454.5 Z" fill="rgb(255,140,0)" stroke="white" stroke-width="1"/>+  <line x1="520.0" y1="398.7" x2="520.0" y2="436.3" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="517.0" y1="398.7" x2="523.0" y2="398.7" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="517.0" y1="436.3" x2="523.0" y2="436.3" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 520.0 412.1 L 521.7 415.8 L 525.4 417.5 L 521.7 419.2 L 520.0 422.9 L 518.3 419.2 L 514.6 417.5 L 518.3 415.8 Z" fill="rgb(255,140,0)" stroke="white" stroke-width="1"/>+  <line x1="610.0" y1="346.9" x2="610.0" y2="375.6" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="607.0" y1="346.9" x2="613.0" y2="346.9" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="607.0" y1="375.6" x2="613.0" y2="375.6" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 610.0 355.8 L 611.7 359.5 L 615.4 361.2 L 611.7 362.9 L 610.0 366.6 L 608.3 362.9 L 604.6 361.2 L 608.3 359.5 Z" fill="rgb(255,140,0)" stroke="white" stroke-width="1"/>+</g>+</g>+<g aria-label="uniform">+<text x="940.0" y="144.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="15" font-weight="500" fill="rgb(20,20,20)">uniform</text>+<line x1="670.0" y1="610.0" x2="1210.0" y2="610.0" stroke="rgb(170,170,170)" stroke-width="0.7" stroke-dasharray="2 4"/>+<text x="660.0" y="614.0" text-anchor="end" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">0.00</text>+<line x1="670.0" y1="521.6" x2="1210.0" y2="521.6" stroke="rgb(170,170,170)" stroke-width="0.7" stroke-dasharray="2 4"/>+<text x="660.0" y="525.6" text-anchor="end" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">1.0</text>+<line x1="670.0" y1="433.2" x2="1210.0" y2="433.2" stroke="rgb(170,170,170)" stroke-width="0.7" stroke-dasharray="2 4"/>+<text x="660.0" y="437.2" text-anchor="end" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">2.0</text>+<line x1="670.0" y1="344.8" x2="1210.0" y2="344.8" stroke="rgb(170,170,170)" stroke-width="0.7" stroke-dasharray="2 4"/>+<text x="660.0" y="348.8" text-anchor="end" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">3.0</text>+<line x1="670.0" y1="256.4" x2="1210.0" y2="256.4" stroke="rgb(170,170,170)" stroke-width="0.7" stroke-dasharray="2 4"/>+<text x="660.0" y="260.4" text-anchor="end" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">4.0</text>+<line x1="670.0" y1="168.0" x2="1210.0" y2="168.0" stroke="rgb(170,170,170)" stroke-width="0.7" stroke-dasharray="2 4"/>+<text x="660.0" y="172.0" text-anchor="end" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">5.0</text>+<line x1="670.0" y1="610" x2="670.0" y2="616" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="670.0" y="635.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">2k</text>+<line x1="760.0" y1="610" x2="760.0" y2="616" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="760.0" y="635.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">4k</text>+<line x1="850.0" y1="610" x2="850.0" y2="616" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="850.0" y="635.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">6k</text>+<line x1="940.0" y1="610" x2="940.0" y2="616" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="940.0" y="635.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">8k</text>+<line x1="1030.0" y1="610" x2="1030.0" y2="616" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="1030.0" y="635.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">10k</text>+<line x1="1120.0" y1="610" x2="1120.0" y2="616" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="1120.0" y="635.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">12k</text>+<line x1="1210.0" y1="610" x2="1210.0" y2="616" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="1210.0" y="635.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">14k</text>+<rect x="670.0" y="168.0" width="540.0" height="442.0" fill="none" stroke="rgb(25,25,25)" stroke-width="1"/>+<text x="940.0" y="664.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="12" font-weight="400" fill="rgb(20,20,20)">input size (points)</text>+<text x="615.0" y="389.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="12" fill="rgb(20,20,20)" transform="rotate(-90 615.0 389.0)">CPU time (ms)</text>+<g aria-label="spade 2">+  <polyline points="670.0,583.7 760.0,547.6 850.0,506.8 940.0,466.9 1030.0,426.3 1120.0,383.7 1210.0,338.9" fill="none" stroke="rgb(0,0,139)" stroke-width="2.0" stroke-linecap="round" stroke-linejoin="round"/>+  <line x1="670.0" y1="582.4" x2="670.0" y2="585.0" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="667.0" y1="582.4" x2="673.0" y2="582.4" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="667.0" y1="585.0" x2="673.0" y2="585.0" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <circle cx="670.0" cy="583.7" r="3.2" fill="white" stroke="rgb(0,0,139)" stroke-width="1.6"/>+  <line x1="760.0" y1="542.4" x2="760.0" y2="552.8" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="757.0" y1="542.4" x2="763.0" y2="542.4" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="757.0" y1="552.8" x2="763.0" y2="552.8" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <circle cx="760.0" cy="547.6" r="3.2" fill="white" stroke="rgb(0,0,139)" stroke-width="1.6"/>+  <line x1="850.0" y1="497.7" x2="850.0" y2="515.8" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="847.0" y1="497.7" x2="853.0" y2="497.7" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="847.0" y1="515.8" x2="853.0" y2="515.8" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <circle cx="850.0" cy="506.8" r="3.2" fill="white" stroke="rgb(0,0,139)" stroke-width="1.6"/>+  <line x1="940.0" y1="463.1" x2="940.0" y2="470.7" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="937.0" y1="463.1" x2="943.0" y2="463.1" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="937.0" y1="470.7" x2="943.0" y2="470.7" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <circle cx="940.0" cy="466.9" r="3.2" fill="white" stroke="rgb(0,0,139)" stroke-width="1.6"/>+  <line x1="1030.0" y1="415.5" x2="1030.0" y2="437.1" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1027.0" y1="415.5" x2="1033.0" y2="415.5" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1027.0" y1="437.1" x2="1033.0" y2="437.1" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <circle cx="1030.0" cy="426.3" r="3.2" fill="white" stroke="rgb(0,0,139)" stroke-width="1.6"/>+  <line x1="1120.0" y1="370.6" x2="1120.0" y2="396.9" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1117.0" y1="370.6" x2="1123.0" y2="370.6" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1117.0" y1="396.9" x2="1123.0" y2="396.9" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <circle cx="1120.0" cy="383.7" r="3.2" fill="white" stroke="rgb(0,0,139)" stroke-width="1.6"/>+  <line x1="1210.0" y1="317.9" x2="1210.0" y2="359.9" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1207.0" y1="317.9" x2="1213.0" y2="317.9" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1207.0" y1="359.9" x2="1213.0" y2="359.9" stroke="rgb(0,0,139)" stroke-width="0.9" opacity="0.48"/>+  <circle cx="1210.0" cy="338.9" r="3.2" fill="white" stroke="rgb(0,0,139)" stroke-width="1.6"/>+</g>+<g aria-label="spade 2 hierarchy">+  <polyline points="670.0,583.3 760.0,544.5 850.0,499.8 940.0,455.4 1030.0,406.4 1120.0,364.4 1210.0,316.7" fill="none" stroke="rgb(139,0,139)" stroke-width="2.0" stroke-linecap="round" stroke-linejoin="round" stroke-dasharray="7 4"/>+  <line x1="670.0" y1="582.1" x2="670.0" y2="584.6" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="667.0" y1="582.1" x2="673.0" y2="582.1" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="667.0" y1="584.6" x2="673.0" y2="584.6" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 670.0 579.0 L 665.9 586.8 L 674.1 586.8 Z" fill="white" stroke="rgb(139,0,139)" stroke-width="1.6"/>+  <line x1="760.0" y1="541.1" x2="760.0" y2="547.8" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="757.0" y1="541.1" x2="763.0" y2="541.1" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="757.0" y1="547.8" x2="763.0" y2="547.8" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 760.0 540.2 L 755.9 548.0 L 764.1 548.0 Z" fill="white" stroke="rgb(139,0,139)" stroke-width="1.6"/>+  <line x1="850.0" y1="489.8" x2="850.0" y2="509.8" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="847.0" y1="489.8" x2="853.0" y2="489.8" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="847.0" y1="509.8" x2="853.0" y2="509.8" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 850.0 495.5 L 845.9 503.3 L 854.1 503.3 Z" fill="white" stroke="rgb(139,0,139)" stroke-width="1.6"/>+  <line x1="940.0" y1="443.6" x2="940.0" y2="467.2" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="937.0" y1="443.6" x2="943.0" y2="443.6" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="937.0" y1="467.2" x2="943.0" y2="467.2" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 940.0 451.1 L 935.9 458.9 L 944.1 458.9 Z" fill="white" stroke="rgb(139,0,139)" stroke-width="1.6"/>+  <line x1="1030.0" y1="387.9" x2="1030.0" y2="424.9" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1027.0" y1="387.9" x2="1033.0" y2="387.9" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1027.0" y1="424.9" x2="1033.0" y2="424.9" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 1030.0 402.1 L 1025.9 409.9 L 1034.1 409.9 Z" fill="white" stroke="rgb(139,0,139)" stroke-width="1.6"/>+  <line x1="1120.0" y1="344.7" x2="1120.0" y2="384.0" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1117.0" y1="344.7" x2="1123.0" y2="344.7" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1117.0" y1="384.0" x2="1123.0" y2="384.0" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 1120.0 360.1 L 1115.9 367.9 L 1124.1 367.9 Z" fill="white" stroke="rgb(139,0,139)" stroke-width="1.6"/>+  <line x1="1210.0" y1="306.8" x2="1210.0" y2="326.6" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1207.0" y1="306.8" x2="1213.0" y2="306.8" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1207.0" y1="326.6" x2="1213.0" y2="326.6" stroke="rgb(139,0,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 1210.0 312.4 L 1205.9 320.2 L 1214.1 320.2 Z" fill="white" stroke="rgb(139,0,139)" stroke-width="1.6"/>+</g>+<g aria-label="cdt">+  <polyline points="670.0,593.7 760.0,570.4 850.0,534.1 940.0,500.7 1030.0,465.7 1120.0,431.7 1210.0,396.1" fill="none" stroke="rgb(178,34,34)" stroke-width="2.0" stroke-linecap="round" stroke-linejoin="round"/>+  <line x1="670.0" y1="592.7" x2="670.0" y2="594.6" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="667.0" y1="592.7" x2="673.0" y2="592.7" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="667.0" y1="594.6" x2="673.0" y2="594.6" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <rect x="666.8" y="590.5" width="6.4" height="6.4" fill="white" stroke="rgb(178,34,34)" stroke-width="1.6"/>+  <line x1="760.0" y1="569.0" x2="760.0" y2="571.7" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="757.0" y1="569.0" x2="763.0" y2="569.0" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="757.0" y1="571.7" x2="763.0" y2="571.7" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <rect x="756.8" y="567.2" width="6.4" height="6.4" fill="white" stroke="rgb(178,34,34)" stroke-width="1.6"/>+  <line x1="850.0" y1="529.0" x2="850.0" y2="539.3" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="847.0" y1="529.0" x2="853.0" y2="529.0" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="847.0" y1="539.3" x2="853.0" y2="539.3" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <rect x="846.8" y="530.9" width="6.4" height="6.4" fill="white" stroke="rgb(178,34,34)" stroke-width="1.6"/>+  <line x1="940.0" y1="491.0" x2="940.0" y2="510.3" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="937.0" y1="491.0" x2="943.0" y2="491.0" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="937.0" y1="510.3" x2="943.0" y2="510.3" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <rect x="936.8" y="497.5" width="6.4" height="6.4" fill="white" stroke="rgb(178,34,34)" stroke-width="1.6"/>+  <line x1="1030.0" y1="455.0" x2="1030.0" y2="476.4" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1027.0" y1="455.0" x2="1033.0" y2="455.0" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1027.0" y1="476.4" x2="1033.0" y2="476.4" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <rect x="1026.8" y="462.5" width="6.4" height="6.4" fill="white" stroke="rgb(178,34,34)" stroke-width="1.6"/>+  <line x1="1120.0" y1="420.1" x2="1120.0" y2="443.4" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1117.0" y1="420.1" x2="1123.0" y2="420.1" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1117.0" y1="443.4" x2="1123.0" y2="443.4" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <rect x="1116.8" y="428.5" width="6.4" height="6.4" fill="white" stroke="rgb(178,34,34)" stroke-width="1.6"/>+  <line x1="1210.0" y1="379.4" x2="1210.0" y2="412.8" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1207.0" y1="379.4" x2="1213.0" y2="379.4" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1207.0" y1="412.8" x2="1213.0" y2="412.8" stroke="rgb(178,34,34)" stroke-width="0.9" opacity="0.48"/>+  <rect x="1206.8" y="392.9" width="6.4" height="6.4" fill="white" stroke="rgb(178,34,34)" stroke-width="1.6"/>+</g>+<g aria-label="delaunator">+  <polyline points="670.0,597.2 760.0,580.7 850.0,558.9 940.0,530.2 1030.0,497.9 1120.0,466.9 1210.0,434.3" fill="none" stroke="rgb(0,139,139)" stroke-width="2.0" stroke-linecap="round" stroke-linejoin="round"/>+  <line x1="670.0" y1="596.0" x2="670.0" y2="598.5" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="667.0" y1="596.0" x2="673.0" y2="596.0" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="667.0" y1="598.5" x2="673.0" y2="598.5" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 670.0 593.0 L 674.2 597.2 L 670.0 601.4 L 665.8 597.2 Z" fill="white" stroke="rgb(0,139,139)" stroke-width="1.6"/>+  <line x1="760.0" y1="578.8" x2="760.0" y2="582.6" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="757.0" y1="578.8" x2="763.0" y2="578.8" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="757.0" y1="582.6" x2="763.0" y2="582.6" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 760.0 576.5 L 764.2 580.7 L 760.0 584.9 L 755.8 580.7 Z" fill="white" stroke="rgb(0,139,139)" stroke-width="1.6"/>+  <line x1="850.0" y1="554.6" x2="850.0" y2="563.2" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="847.0" y1="554.6" x2="853.0" y2="554.6" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="847.0" y1="563.2" x2="853.0" y2="563.2" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 850.0 554.7 L 854.2 558.9 L 850.0 563.1 L 845.8 558.9 Z" fill="white" stroke="rgb(0,139,139)" stroke-width="1.6"/>+  <line x1="940.0" y1="529.0" x2="940.0" y2="531.5" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="937.0" y1="529.0" x2="943.0" y2="529.0" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="937.0" y1="531.5" x2="943.0" y2="531.5" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 940.0 526.0 L 944.2 530.2 L 940.0 534.4 L 935.8 530.2 Z" fill="white" stroke="rgb(0,139,139)" stroke-width="1.6"/>+  <line x1="1030.0" y1="487.6" x2="1030.0" y2="508.3" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1027.0" y1="487.6" x2="1033.0" y2="487.6" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1027.0" y1="508.3" x2="1033.0" y2="508.3" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 1030.0 493.7 L 1034.2 497.9 L 1030.0 502.1 L 1025.8 497.9 Z" fill="white" stroke="rgb(0,139,139)" stroke-width="1.6"/>+  <line x1="1120.0" y1="461.4" x2="1120.0" y2="472.4" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1117.0" y1="461.4" x2="1123.0" y2="461.4" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1117.0" y1="472.4" x2="1123.0" y2="472.4" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 1120.0 462.7 L 1124.2 466.9 L 1120.0 471.1 L 1115.8 466.9 Z" fill="white" stroke="rgb(0,139,139)" stroke-width="1.6"/>+  <line x1="1210.0" y1="419.9" x2="1210.0" y2="448.7" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1207.0" y1="419.9" x2="1213.0" y2="419.9" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1207.0" y1="448.7" x2="1213.0" y2="448.7" stroke="rgb(0,139,139)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 1210.0 430.1 L 1214.2 434.3 L 1210.0 438.5 L 1205.8 434.3 Z" fill="white" stroke="rgb(0,139,139)" stroke-width="1.6"/>+</g>+<g aria-label="moonlight-triangulation">+  <polyline points="670.0,585.5 760.0,561.2 850.0,530.7 940.0,496.8 1030.0,462.3 1120.0,419.3 1210.0,374.6" fill="none" stroke="rgb(255,140,0)" stroke-width="3.2" stroke-linecap="round" stroke-linejoin="round"/>+  <line x1="670.0" y1="584.0" x2="670.0" y2="587.0" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="667.0" y1="584.0" x2="673.0" y2="584.0" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="667.0" y1="587.0" x2="673.0" y2="587.0" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 670.0 580.1 L 671.7 583.8 L 675.4 585.5 L 671.7 587.2 L 670.0 590.9 L 668.3 587.2 L 664.6 585.5 L 668.3 583.8 Z" fill="rgb(255,140,0)" stroke="white" stroke-width="1"/>+  <line x1="760.0" y1="560.5" x2="760.0" y2="562.0" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="757.0" y1="560.5" x2="763.0" y2="560.5" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="757.0" y1="562.0" x2="763.0" y2="562.0" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 760.0 555.8 L 761.7 559.5 L 765.4 561.2 L 761.7 562.9 L 760.0 566.6 L 758.3 562.9 L 754.6 561.2 L 758.3 559.5 Z" fill="rgb(255,140,0)" stroke="white" stroke-width="1"/>+  <line x1="850.0" y1="522.8" x2="850.0" y2="538.6" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="847.0" y1="522.8" x2="853.0" y2="522.8" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="847.0" y1="538.6" x2="853.0" y2="538.6" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 850.0 525.3 L 851.7 529.0 L 855.4 530.7 L 851.7 532.4 L 850.0 536.1 L 848.3 532.4 L 844.6 530.7 L 848.3 529.0 Z" fill="rgb(255,140,0)" stroke="white" stroke-width="1"/>+  <line x1="940.0" y1="485.9" x2="940.0" y2="507.6" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="937.0" y1="485.9" x2="943.0" y2="485.9" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="937.0" y1="507.6" x2="943.0" y2="507.6" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 940.0 491.4 L 941.7 495.1 L 945.4 496.8 L 941.7 498.5 L 940.0 502.2 L 938.3 498.5 L 934.6 496.8 L 938.3 495.1 Z" fill="rgb(255,140,0)" stroke="white" stroke-width="1"/>+  <line x1="1030.0" y1="451.9" x2="1030.0" y2="472.7" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1027.0" y1="451.9" x2="1033.0" y2="451.9" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1027.0" y1="472.7" x2="1033.0" y2="472.7" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 1030.0 456.9 L 1031.7 460.6 L 1035.4 462.3 L 1031.7 464.0 L 1030.0 467.7 L 1028.3 464.0 L 1024.6 462.3 L 1028.3 460.6 Z" fill="rgb(255,140,0)" stroke="white" stroke-width="1"/>+  <line x1="1120.0" y1="401.2" x2="1120.0" y2="437.4" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1117.0" y1="401.2" x2="1123.0" y2="401.2" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1117.0" y1="437.4" x2="1123.0" y2="437.4" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 1120.0 413.9 L 1121.7 417.6 L 1125.4 419.3 L 1121.7 421.0 L 1120.0 424.7 L 1118.3 421.0 L 1114.6 419.3 L 1118.3 417.6 Z" fill="rgb(255,140,0)" stroke="white" stroke-width="1"/>+  <line x1="1210.0" y1="364.2" x2="1210.0" y2="385.0" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1207.0" y1="364.2" x2="1213.0" y2="364.2" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <line x1="1207.0" y1="385.0" x2="1213.0" y2="385.0" stroke="rgb(255,140,0)" stroke-width="0.9" opacity="0.48"/>+  <path d="M 1210.0 369.2 L 1211.7 372.9 L 1215.4 374.6 L 1211.7 376.3 L 1210.0 380.0 L 1208.3 376.3 L 1204.6 374.6 L 1208.3 372.9 Z" fill="rgb(255,140,0)" stroke="white" stroke-width="1"/>+</g>+</g>+<text x="640.0" y="704.0" text-anchor="middle" font-family="Helvetica, Arial, sans-serif" font-size="11" font-weight="400" fill="rgb(20,20,20)">Whiskers show tasty-bench's reported 2× standard-deviation spread.</text>+</svg>
+ docs/delaunay-compare/rust/Cargo.lock view
@@ -0,0 +1,264 @@+# This file is automatically @generated by Cargo.+# It is not intended for manual editing.+version = 4++[[package]]+name = "allocator-api2"+version = "0.2.21"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "683d7910e743518b0e34f1186f92494becacb047c7b6bf616c96772180fef923"++[[package]]+name = "autocfg"+version = "1.5.1"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "f2032f911046de80f0a198e0901378627c33f59ea0ac00e363d481118bd70a53"++[[package]]+name = "cdt"+version = "0.1.0"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "b91b872294f63ef586b32aa94141561681aa35ca2d703960cca4f661f4e18184"+dependencies = [+ "geometry-predicates",+ "thiserror",+]++[[package]]+name = "cfg-if"+version = "1.0.4"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "9330f8b2ff13f34540b44e946ef35111825727b38d33286ef986142615121801"++[[package]]+name = "delaunator"+version = "1.1.0"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "3e1ee323c1275374f7e612d3724d12707079fb6a2117349fe144def656f5a880"+dependencies = [+ "robust",+]++[[package]]+name = "equivalent"+version = "1.0.2"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "877a4ace8713b0bcf2a4e7eec82529c029f1d0619886d18145fea96c3ffe5c0f"++[[package]]+name = "foldhash"+version = "0.2.0"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "77ce24cb58228fbb8aa041425bb1050850ac19177686ea6e0f41a70416f56fdb"++[[package]]+name = "geometry-predicates"+version = "0.3.0"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "8dba84198cf199c11b83f1cb9243eaeb70dc50b719d2835ebf34bf2481bca010"++[[package]]+name = "getrandom"+version = "0.3.4"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "899def5c37c4fd7b2664648c28120ecec138e4d395b459e5ca34f9cce2dd77fd"+dependencies = [+ "cfg-if",+ "libc",+ "r-efi",+ "wasip2",+]++[[package]]+name = "hashbrown"+version = "0.16.1"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "841d1cc9bed7f9236f321df977030373f4a4163ae1a7dbfe1a51a2c1a51d9100"+dependencies = [+ "allocator-api2",+ "equivalent",+ "foldhash",+]++[[package]]+name = "libc"+version = "0.2.189"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "3eaf3ede3fee6db1a4c2ee091bf8a8b4dccdc6d17f656fb07896ee72867612f2"++[[package]]+name = "moonlight-delaunay-compare-referents"+version = "0.1.0"+dependencies = [+ "cdt",+ "delaunator",+ "rand",+ "spade",+]++[[package]]+name = "num-traits"+version = "0.2.19"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "071dfc062690e90b734c0b2273ce72ad0ffa95f0c74596bc250dcfd960262841"+dependencies = [+ "autocfg",+]++[[package]]+name = "ppv-lite86"+version = "0.2.21"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "85eae3c4ed2f50dcfe72643da4befc30deadb458a9b590d720cde2f2b1e97da9"+dependencies = [+ "zerocopy",+]++[[package]]+name = "proc-macro2"+version = "1.0.107"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "985e7ec9bb745e6ce6535b544d84d6cd6f7ad8bd711c398938ae983b91a766d9"+dependencies = [+ "unicode-ident",+]++[[package]]+name = "quote"+version = "1.0.47"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "1fbf4db142a473a8d80c26bbf18454ed458bf8d26c8219c331daecfdbd079001"+dependencies = [+ "proc-macro2",+]++[[package]]+name = "r-efi"+version = "5.3.0"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "69cdb34c158ceb288df11e18b4bd39de994f6657d83847bdffdbd7f346754b0f"++[[package]]+name = "rand"+version = "0.9.5"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "b9ef1d0d795eb7d84685bca4f72f3649f064e6641543d3a8c415898726a57b41"+dependencies = [+ "rand_chacha",+ "rand_core",+]++[[package]]+name = "rand_chacha"+version = "0.9.0"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "d3022b5f1df60f26e1ffddd6c66e8aa15de382ae63b3a0c1bfc0e4d3e3f325cb"+dependencies = [+ "ppv-lite86",+ "rand_core",+]++[[package]]+name = "rand_core"+version = "0.9.5"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "76afc826de14238e6e8c374ddcc1fa19e374fd8dd986b0d2af0d02377261d83c"+dependencies = [+ "getrandom",+]++[[package]]+name = "robust"+version = "1.2.0"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "4e27ee8bb91ca0adcf0ecb116293afa12d393f9c2b9b9cd54d33e8078fe19839"++[[package]]+name = "smallvec"+version = "1.15.2"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "8ed6a63f02c8539c91a8685a86f4099661ba3da017932f6ebbea6de3f0fa7c90"++[[package]]+name = "spade"+version = "2.15.1"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "9699399fd9349b00b184f5635b074f9ec93afffef30c853f8c875b32c0f8c7fa"+dependencies = [+ "hashbrown",+ "num-traits",+ "robust",+ "smallvec",+]++[[package]]+name = "syn"+version = "2.0.119"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "872831b642d1a07999a962a351ed35b955ea2cfc8f3862091e2a240a84f17297"+dependencies = [+ "proc-macro2",+ "quote",+ "unicode-ident",+]++[[package]]+name = "thiserror"+version = "1.0.69"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "b6aaf5339b578ea85b50e080feb250a3e8ae8cfcdff9a461c9ec2904bc923f52"+dependencies = [+ "thiserror-impl",+]++[[package]]+name = "thiserror-impl"+version = "1.0.69"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "4fee6c4efc90059e10f81e6d42c60a18f76588c3d74cb83a0b242a2b6c7504c1"+dependencies = [+ "proc-macro2",+ "quote",+ "syn",+]++[[package]]+name = "unicode-ident"+version = "1.0.24"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "e6e4313cd5fcd3dad5cafa179702e2b244f760991f45397d14d4ebf38247da75"++[[package]]+name = "wasip2"+version = "1.0.4+wasi-0.2.12"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "b67efb37e106e55ce722a510d6b5f9c17f083e5fc79afc2badeb12cc313d9487"+dependencies = [+ "wit-bindgen",+]++[[package]]+name = "wit-bindgen"+version = "0.57.1"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "1ebf944e87a7c253233ad6766e082e3cd714b5d03812acc24c318f549614536e"++[[package]]+name = "zerocopy"+version = "0.8.56"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "556764e583adb45a9f8d413c2a147fa7e8d821e48e12b14fd560b607998b75eb"+dependencies = [+ "zerocopy-derive",+]++[[package]]+name = "zerocopy-derive"+version = "0.8.56"+source = "registry+https://github.com/rust-lang/crates.io-index"+checksum = "f2ab42fc20575779bd240faa45f94a74256f755c0fa9e89f0ede20d91d0cdfc1"+dependencies = [+ "proc-macro2",+ "quote",+ "syn",+]
+ docs/delaunay-compare/rust/Cargo.toml view
@@ -0,0 +1,20 @@+[workspace]++[package]+name = "moonlight-delaunay-compare-referents"+version = "0.1.0"+edition = "2021"++[lib]+name = "moonlight_delaunay_compare_referents"+crate-type = ["cdylib"]++[dependencies]+cdt = "0.1"+delaunator = "1.0.1"+rand = "0.9.1"+spade = "2.15"++[profile.release]+opt-level = 3+lto = "thin"
+ docs/delaunay-compare/rust/src/lib.rs view
@@ -0,0 +1,397 @@+//! Rust referent boundary for Moonlight's Delaunay construction comparison.+//!+//! Fixture choice, benchmark grouping, agreement, timing, and reporting belong+//! to Haskell. This library retains only the operations that cannot move there:+//! Spade's exact seeded generator and direct calls into the Rust crates under+//! comparison.++use core::ffi::c_void;+use core::hint::black_box;+use core::ptr;+use rand::distr::{Distribution, Uniform};+use rand::rngs::StdRng;+use rand::SeedableRng;+use spade::{HierarchyHintGenerator, Point2, Triangulation};+use std::panic::{catch_unwind, AssertUnwindSafe};++const UPSTREAM_SEED: [u8; 32] = [+    0xfb, 0xdc, 0x4e, 0xa0, 0x30, 0xde, 0x82, 0xba, 0x69, 0x97, 0x3c, 0x52, 0x49, 0x4d, 0x00, 0xca,+    0x0a, 0x5c, 0x21, 0xa3, 0x8d, 0x5c, 0xf2, 0x34, 0x4e, 0x58, 0x7d, 0x80, 0x16, 0x66, 0x23, 0x30,+];++const UNIFORM_RANGE: f64 = 1.0e9;+const LOCAL_STEP_RANGE: f64 = 1.0;++type PlainSpade = spade::DelaunayTriangulation<Point2<f64>>;+type HierarchySpade =+    spade::DelaunayTriangulation<Point2<f64>, (), (), (), HierarchyHintGenerator<f64>>;++#[repr(i32)]+#[derive(Clone, Copy, Debug)]+enum BoundaryStatus {+    Success = 0,+    NullPointer = 1,+    UnknownTag = 2,+    CoordinateCountMismatch = 3,+    DistributionConstructionFailed = 4,+    TriangulationFailed = 5,+    Panicked = 6,+}++impl BoundaryStatus {+    const fn code(self) -> i32 {+        self as i32+    }+}++#[derive(Clone, Copy)]+enum PointDistribution {+    LocalInsertion,+    Uniform,+}++impl TryFrom<i32> for PointDistribution {+    type Error = BoundaryStatus;++    fn try_from(tag: i32) -> Result<Self, Self::Error> {+        match tag {+            0 => Ok(Self::LocalInsertion),+            1 => Ok(Self::Uniform),+            _ => Err(BoundaryStatus::UnknownTag),+        }+    }+}++#[derive(Clone, Copy)]+enum NativeImplementation {+    Spade,+    SpadeHierarchy,+    Cdt,+    Delaunator,+}++impl TryFrom<i32> for NativeImplementation {+    type Error = BoundaryStatus;++    fn try_from(tag: i32) -> Result<Self, Self::Error> {+        match tag {+            0 => Ok(Self::Spade),+            1 => Ok(Self::SpadeHierarchy),+            2 => Ok(Self::Cdt),+            3 => Ok(Self::Delaunator),+            _ => Err(BoundaryStatus::UnknownTag),+        }+    }+}++enum PreparedImplementation {+    Spade(Vec<Point2<f64>>),+    SpadeHierarchy(Vec<Point2<f64>>),+    Cdt(Vec<(f64, f64)>),+    Delaunator(Vec<delaunator::Point>),+}++#[derive(Clone, Copy)]+struct ConstructionSummary {+    vertices: usize,+    triangles: usize,+}++impl PreparedImplementation {+    fn from_coordinates(implementation: NativeImplementation, coordinates: &[[f64; 2]]) -> Self {+        match implementation {+            NativeImplementation::Spade => {+                Self::Spade(coordinates.iter().copied().map(Point2::from).collect())+            }+            NativeImplementation::SpadeHierarchy => {+                Self::SpadeHierarchy(coordinates.iter().copied().map(Point2::from).collect())+            }+            NativeImplementation::Cdt => {+                Self::Cdt(coordinates.iter().map(|[x, y]| (*x, *y)).collect())+            }+            NativeImplementation::Delaunator => Self::Delaunator(+                coordinates+                    .iter()+                    .map(|[x, y]| delaunator::Point { x: *x, y: *y })+                    .collect(),+            ),+        }+    }++    fn run(&self) -> Result<ConstructionSummary, BoundaryStatus> {+        match self {+            Self::Spade(vertices) => {+                let triangulation = PlainSpade::bulk_load(vertices.clone())+                    .map_err(|_| BoundaryStatus::TriangulationFailed)?;+                let summary = ConstructionSummary {+                    vertices: triangulation.num_vertices(),+                    triangles: triangulation.num_inner_faces(),+                };+                black_box(triangulation);+                Ok(summary)+            }+            Self::SpadeHierarchy(vertices) => {+                let triangulation = HierarchySpade::bulk_load(vertices.clone())+                    .map_err(|_| BoundaryStatus::TriangulationFailed)?;+                let summary = ConstructionSummary {+                    vertices: triangulation.num_vertices(),+                    triangles: triangulation.num_inner_faces(),+                };+                black_box(triangulation);+                Ok(summary)+            }+            Self::Cdt(vertices) => {+                let triangles = cdt::triangulate_points(vertices)+                    .map_err(|_| BoundaryStatus::TriangulationFailed)?;+                let summary = ConstructionSummary {+                    vertices: vertices.len(),+                    triangles: triangles.len(),+                };+                black_box(triangles);+                Ok(summary)+            }+            Self::Delaunator(vertices) => {+                let triangulation = delaunator::triangulate(vertices);+                let summary = ConstructionSummary {+                    vertices: vertices.len(),+                    triangles: triangulation.triangles.len() / 3,+                };+                black_box(triangulation);+                Ok(summary)+            }+        }+    }+}++fn boundary_status(action: impl FnOnce() -> Result<(), BoundaryStatus>) -> i32 {+    match catch_unwind(AssertUnwindSafe(action)) {+        Ok(Ok(())) => BoundaryStatus::Success.code(),+        Ok(Err(status)) => status.code(),+        Err(_) => BoundaryStatus::Panicked.code(),+    }+}++fn coordinate_count(point_count: usize) -> Result<usize, BoundaryStatus> {+    point_count+        .checked_mul(2)+        .ok_or(BoundaryStatus::CoordinateCountMismatch)+}++fn uniform_samples(point_count: usize) -> Result<impl Iterator<Item = [f64; 2]>, BoundaryStatus> {+    let distribution = Uniform::new_inclusive(-UNIFORM_RANGE, UNIFORM_RANGE)+        .map_err(|_| BoundaryStatus::DistributionConstructionFailed)?;+    let mut generator = StdRng::from_seed(UPSTREAM_SEED);+    Ok(core::iter::from_fn(move || {+        Some([+            distribution.sample(&mut generator),+            distribution.sample(&mut generator),+        ])+    })+    .take(point_count))+}++fn local_insertion_samples(+    point_count: usize,+) -> Result<impl Iterator<Item = [f64; 2]>, BoundaryStatus> {+    let distribution = Uniform::new_inclusive(-LOCAL_STEP_RANGE, LOCAL_STEP_RANGE)+        .map_err(|_| BoundaryStatus::DistributionConstructionFailed)?;+    let mut generator = StdRng::from_seed(UPSTREAM_SEED);+    let mut previous = [0.0, 1.0];+    Ok(core::iter::from_fn(move || {+        previous = [+            previous[0] + distribution.sample(&mut generator),+            previous[1] + distribution.sample(&mut generator),+        ];+        Some(previous)+    })+    .take(point_count))+}++fn write_coordinates(+    distribution: PointDistribution,+    point_count: usize,+    output: &mut [f64],+) -> Result<(), BoundaryStatus> {+    let expected_count = coordinate_count(point_count)?;+    if output.len() != expected_count {+        return Err(BoundaryStatus::CoordinateCountMismatch);+    }++    let samples: Box<dyn Iterator<Item = [f64; 2]>> = match distribution {+        PointDistribution::LocalInsertion => Box::new(local_insertion_samples(point_count)?),+        PointDistribution::Uniform => Box::new(uniform_samples(point_count)?),+    };++    output+        .chunks_exact_mut(2)+        .zip(samples)+        .for_each(|(coordinate_pair, [x, y])| {+            coordinate_pair.copy_from_slice(&[x, y]);+        });+    Ok(())+}++/// Fill `coordinates` with Spade's exact seeded benchmark distribution.+///+/// # Safety+///+/// A non-null `coordinates` pointer must be writable for `coordinate_count`+/// consecutive `f64` values.+#[no_mangle]+pub unsafe extern "C" fn delaunay_compare_generate(+    distribution_tag: i32,+    point_count: usize,+    coordinates: *mut f64,+    supplied_coordinate_count: usize,+) -> i32 {+    boundary_status(|| {+        let distribution = PointDistribution::try_from(distribution_tag)?;+        let expected_count = coordinate_count(point_count)?;+        if supplied_coordinate_count != expected_count {+            return Err(BoundaryStatus::CoordinateCountMismatch);+        }+        if coordinates.is_null() && supplied_coordinate_count != 0 {+            return Err(BoundaryStatus::NullPointer);+        }+        let output = if supplied_coordinate_count == 0 {+            &mut []+        } else {+            // SAFETY: the caller contract and checks above establish a non-null+            // writable region of exactly `supplied_coordinate_count` values.+            unsafe { core::slice::from_raw_parts_mut(coordinates, supplied_coordinate_count) }+        };+        write_coordinates(distribution, point_count, output)+    })+}++/// Prepare the implementation-specific native input outside the timed region.+///+/// # Safety+///+/// A non-null `coordinates` pointer must be readable for `2 * point_count`+/// consecutive `f64` values. `prepared_output` must be writable for one pointer.+#[no_mangle]+pub unsafe extern "C" fn delaunay_compare_prepare(+    implementation_tag: i32,+    coordinates: *const f64,+    point_count: usize,+    prepared_output: *mut *mut c_void,+) -> i32 {+    boundary_status(|| {+        let implementation = NativeImplementation::try_from(implementation_tag)?;+        if prepared_output.is_null() {+            return Err(BoundaryStatus::NullPointer);+        }+        let supplied_coordinate_count = coordinate_count(point_count)?;+        if coordinates.is_null() && supplied_coordinate_count != 0 {+            return Err(BoundaryStatus::NullPointer);+        }+        let flat_coordinates = if supplied_coordinate_count == 0 {+            &[]+        } else {+            // SAFETY: the caller contract and checks above establish a non-null+            // readable region of exactly `supplied_coordinate_count` values.+            unsafe { core::slice::from_raw_parts(coordinates, supplied_coordinate_count) }+        };+        let coordinate_pairs = flat_coordinates.as_chunks::<2>().0;+        let prepared = PreparedImplementation::from_coordinates(implementation, coordinate_pairs);+        // SAFETY: `prepared_output` was checked non-null and points to writable+        // storage for one opaque pointer by the caller contract.+        unsafe {+            ptr::write(prepared_output, Box::into_raw(Box::new(prepared)).cast());+        }+        Ok(())+    })+}++/// Construct one triangulation from a prepared native input.+///+/// # Safety+///+/// `prepared` must be a live pointer returned by `delaunay_compare_prepare`.+/// Both output pointers must be writable for one `usize`.+#[no_mangle]+pub unsafe extern "C" fn delaunay_compare_run(+    prepared: *const c_void,+    vertex_count_output: *mut usize,+    triangle_count_output: *mut usize,+) -> i32 {+    boundary_status(|| {+        if prepared.is_null() || vertex_count_output.is_null() || triangle_count_output.is_null() {+            return Err(BoundaryStatus::NullPointer);+        }+        // SAFETY: the caller contract requires a live pointer produced by the+        // matching prepare function and keeps it alive for this call.+        let prepared_implementation = unsafe { &*prepared.cast::<PreparedImplementation>() };+        let summary = prepared_implementation.run()?;+        // SAFETY: both output pointers were checked non-null and the caller+        // contract gives writable storage for one value at each address.+        unsafe {+            ptr::write(vertex_count_output, summary.vertices);+            ptr::write(triangle_count_output, summary.triangles);+        }+        Ok(())+    })+}++/// Release one prepared native input. A null pointer is a no-op.+///+/// # Safety+///+/// A non-null pointer must have been returned by `delaunay_compare_prepare`+/// and must not have been released before.+#[no_mangle]+pub unsafe extern "C" fn delaunay_compare_release(prepared: *mut c_void) {+    if !prepared.is_null() {+        // SAFETY: the caller contract transfers the one remaining ownership of+        // the allocation produced by `Box::into_raw` in the prepare function.+        unsafe {+            drop(Box::from_raw(prepared.cast::<PreparedImplementation>()));+        }+    }+}++#[cfg(test)]+mod tests {+    use super::{local_insertion_samples, uniform_samples};++    #[test]+    fn local_insertion_prefix_matches_upstream_fixture_bits() {+        let observed = local_insertion_samples(3)+            .expect("the fixed local-insertion distribution is valid")+            .flatten()+            .map(f64::to_bits)+            .collect::<Vec<_>>();+        assert_eq!(+            observed,+            [+                0xbfe28b04856ac6db,+                0x3ff8c718b563a19a,+                0x3fc014ab09d22a14,+                0x4003a1ee45dc4712,+                0xbfd097c41d82adc4,+                0x4008d420538d5c3d,+            ]+        );+    }++    #[test]+    fn uniform_prefix_matches_upstream_fixture_bits() {+        let observed = uniform_samples(3)+            .expect("the fixed uniform distribution is valid")+            .flatten()+            .map(f64::to_bits)+            .collect::<Vec<_>>();+        assert_eq!(+            observed,+            [+                0xc1c1450134a5bd5a,+                0x41c0598b1e249a72,+                0x41c5037dbf1c0b38,+                0x41cafc1cf53845c8,+                0xc1b6f1036f0b1386,+                0x41c35b5d4df8b356,+            ]+        );+    }+}
+ docs/development.md view
@@ -0,0 +1,25 @@+# Local development++[Return to the package overview.](../README.md#consumer-libraries)+· [Browse the documentation.](./README.md)++Run component-qualified commands from the repository's `compiler/` directory.+The optimized construction kernel uses the triangulation development project:++```console+../scripts/safe-cabal.sh build moonlight-planar:lib:build \+  --project-file=cabal.project.planar-dev \+  --builddir=dist-newstyle-planar-dev+```++For type and interface feedback, use the same component at `-O0`:++```console+../scripts/safe-cabal.sh build moonlight-planar:lib:build \+  --project-file=cabal.project.planar-dev \+  --builddir=dist-newstyle-triangulation-fast \+  --disable-optimization+```++Performance evidence uses the optimized profile; the `-O0` profile is the+shorter feedback path.
+ docs/examples/Moonlight/Triangulation/Example/ActivationZigzag.hs view
@@ -0,0 +1,60 @@+module Moonlight.Triangulation.Example.ActivationZigzag+  ( ActivationZigzagExampleError (..)+  , squareLoopAcrossDepths+  ) where++import Data.Bifunctor (first)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty+import Data.Vector qualified as Vector+import Moonlight.Homology.Chain (HomologicalDegree (..))+import Moonlight.Triangulation.Types+  ( Point (..)+  , RadiusSquaredError+  , mkRadiusSquared+  )+import Moonlight.Triangulation.Zigzag+  ( ActivationInterval+  , ActivationPoint (..)+  , ActivationSlice (..)+  , ActivationZigzagError+  , ZigzagInterval (..)+  , activationAlphaPersistence+  )++data ActivationZigzagExampleError+  = ActivationRadiusFailed !RadiusSquaredError+  | ActivationPersistenceFailed !(ActivationZigzagError Int String)+  deriving stock (Eq, Show)++-- | Observe a square before its boundary appears, while it carries one loop,+-- and after its two Delaunay faces fill that loop.  The returned interval uses+-- the expanded observation/union stages rather than pretending the slices are+-- a monotone filtration.+squareLoopAcrossDepths :: Either ActivationZigzagExampleError [ActivationInterval Int]+squareLoopAcrossDepths = do+  let depths :: NonEmpty Int+      depths = 0 :| [1, 2]+  thresholds <-+    traverse+      (first ActivationRadiusFailed . mkRadiusSquared . fromIntegral)+      depths+  intervals <-+    first ActivationPersistenceFailed+      ( activationAlphaPersistence+          ( NonEmpty.zipWith+              (\depthValue threshold -> ActivationSlice depthValue threshold squarePoints)+              depths+              thresholds+          )+      )+  pure (filter ((== HomologicalDegree 1) . zigzagIntervalDegree) intervals)++squarePoints :: Vector.Vector (ActivationPoint String)+squarePoints =+  Vector.fromList+    [ ActivationPoint "south-west" (Point (-1) (-1))+    , ActivationPoint "south-east" (Point 1 (-1))+    , ActivationPoint "north-east" (Point 1 1)+    , ActivationPoint "north-west" (Point (-1) 1)+    ]
+ docs/examples/Moonlight/Triangulation/Example/AlphaBoundary.hs view
@@ -0,0 +1,54 @@+module Moonlight.Triangulation.Example.AlphaBoundary+  ( AlphaBoundaryExampleError (..)+  , BoundaryShape (..)+  , alphaBoundaryShapes+  ) where++import Data.Bifunctor (first)+import qualified Data.Vector as Vector+import Moonlight.Triangulation++data AlphaBoundaryExampleError+  = AlphaBoundaryBuildFailed !BuildError+  | AlphaBoundaryRadiusFailed !RadiusSquaredError+  | AlphaBoundaryDescentFailed !BoundaryObstruction+  deriving stock (Eq, Show)++data BoundaryShape = BoundaryShape+  { boundaryOuterVertexCount :: !Int+  , boundaryHoleCount :: !Int+  }+  deriving stock (Eq, Show)++-- | Descend the closed alpha-shape face section of one square to its boundary.+alphaBoundaryShapes :: Either AlphaBoundaryExampleError [BoundaryShape]+alphaBoundaryShapes = do+  mesh <-+    first AlphaBoundaryBuildFailed+      ( delaunayGeometry+          ( Vector.fromList+              [ Point 0 0+              , Point 2 0+              , Point 2 2+              , Point 0 2+              ]+          )+      )+  threshold <- first AlphaBoundaryRadiusFailed (mkRadiusSquared 2)+  let selectedComponents =+        fmap snd+          (filter fst (faceComponents mesh (alphaShapeContainsFace threshold mesh)))+  traverse+    ( fmap boundaryShape+        . first AlphaBoundaryDescentFailed+        . componentBoundary mesh+    )+    selectedComponents++boundaryShape :: RegionBoundary -> BoundaryShape+boundaryShape boundary =+  BoundaryShape+    { boundaryOuterVertexCount =+        length (boundaryLoopVertices (regionBoundaryOuterLoop boundary))+    , boundaryHoleCount = length (regionBoundaryHoleLoops boundary)+    }
+ docs/examples/Moonlight/Triangulation/Example/ConstrainedRegion.hs view
@@ -0,0 +1,37 @@+module Moonlight.Triangulation.Example.ConstrainedRegion+  ( constrainedRegionCounts+  ) where++import qualified Data.Vector as Vector+import Moonlight.Triangulation++-- | Count every face and only the bounded odd-depth domain faces of an annulus.+constrainedRegionCounts :: Either CdtError (Int, Int)+constrainedRegionCounts = do+  result <-+    constrainedDelaunay+      unitElementDefaults+      (Vector.fromList annulusPoints)+      (Vector.fromList (closedLoop 0 <> closedLoop 4))+  let annulus = buildTriangulation result+  pure (numFaces annulus, length (boundedRegionFaces annulus))++annulusPoints :: [Point]+annulusPoints =+  [ Point (-2) (-2)+  , Point 2 (-2)+  , Point 2 2+  , Point (-2) 2+  , Point (-1) (-1)+  , Point 1 (-1)+  , Point 1 1+  , Point (-1) 1+  ]++closedLoop :: Int -> [(Int, Int)]+closedLoop offset =+  [ (offset, offset + 1)+  , (offset + 1, offset + 2)+  , (offset + 2, offset + 3)+  , (offset + 3, offset)+  ]
+ docs/examples/Moonlight/Triangulation/Example/PlanarRegion.hs view
@@ -0,0 +1,137 @@+module Moonlight.Triangulation.Example.PlanarRegion+  ( ExactFractionSummary (..)+  , CellValuationSummary (..)+  , PlanarExampleError (..)+  , PlanarExampleSummary (..)+  , planarExample+  ) where++import Data.Bifunctor (first)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Map.Strict as Map+import Moonlight.Triangulation++data ExactFractionSummary = ExactFractionSummary+  { fractionNumerator :: !Integer+  , fractionDenominator :: !Integer+  }+  deriving stock (Eq, Show)++data CellValuationSummary = CellValuationSummary+  { cellEulerCharacteristic :: !Int+  , cellExactArea :: !ExactFractionSummary+  }+  deriving stock (Eq, Show)++data PlanarExampleSummary = PlanarExampleSummary+  { booleanValuations :: ![CellValuationSummary]+  , morphologyAreas :: ![ExactFractionSummary]+  }+  deriving stock (Eq, Show)++data PlanarExampleError+  = PlanarRegionFailed !RegionValidationError+  | PlanarOverlayFailed !(OverlayError Bool Bool)+  | PlanarSelectionFailed !OverlaySelectionError+  | PlanarValuationFailed !ValuationError+  | PlanarMinkowskiFailed !MinkowskiError+  deriving stock (Eq, Show)++-- | Compute exact Boolean valuations and morphology through the public facade.+planarExample :: Either PlanarExampleError PlanarExampleSummary+planarExample = do+  left <- rectangleRegion 0 0 4 4+  right <- rectangleRegion 2 1 6 3+  leftLayer <- insideLayer left+  rightLayer <- insideLayer right+  overlay <- first PlanarOverlayFailed (overlayLayers leftLayer rightLayer)+  unionCells <- first PlanarSelectionFailed (overlayClosedUnion id id overlay)+  intersectionCells <-+    first PlanarSelectionFailed (overlayClosedIntersection id id overlay)+  differenceCells <-+    first PlanarSelectionFailed (overlayRegularizedDifference id id overlay)+  cellSummaries <-+    traverse+      cellValuationSummary+      [unionCells, intersectionCells, differenceCells]++  kernelLoop <- rectangleLoop (-1) (-1) 1 1+  kernelPolygon <-+    first PlanarMinkowskiFailed (convexPolygon (exactLoopPoints kernelLoop))+  kernel <- first PlanarMinkowskiFailed (structuringElement kernelPolygon)+  (sumRegion, _) <- first PlanarMinkowskiFailed (minkowskiSum left right)+  (offsetRegion, _) <- first PlanarMinkowskiFailed (polygonOffset kernel left)+  (insetRegion, _) <- first PlanarMinkowskiFailed (polygonInset kernel left)+  (openedRegion, _) <- first PlanarMinkowskiFailed (openWith kernel left)+  (closedRegion, _) <- first PlanarMinkowskiFailed (closeWith kernel left)+  areaSummaries <-+    traverse+      regionAreaSummary+      [sumRegion, offsetRegion, insetRegion, openedRegion, closedRegion]++  pure+    PlanarExampleSummary+      { booleanValuations = cellSummaries+      , morphologyAreas = areaSummaries+      }++rectangleLoop+  :: Integer+  -> Integer+  -> Integer+  -> Integer+  -> Either PlanarExampleError ExactLoop+rectangleLoop minimumX minimumY maximumX maximumY =+  first PlanarRegionFailed+    ( 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+  -> Either PlanarExampleError PlanarRegion+rectangleRegion minimumX minimumY maximumX maximumY = do+  outer <- rectangleLoop minimumX minimumY maximumX maximumY+  component <- first PlanarRegionFailed (polygonComponent outer [])+  first PlanarRegionFailed (planarRegion [component])++insideLayer :: PlanarRegion -> Either PlanarExampleError (PlanarLayer Bool)+insideLayer =+  first PlanarRegionFailed+    . planarLayer False+    . Map.singleton True++cellValuationSummary+  :: ExactCellSet+  -> Either PlanarExampleError CellValuationSummary+cellValuationSummary cells = do+  valuations <- first PlanarValuationFailed (cellValuations cells)+  pure+    CellValuationSummary+      { cellEulerCharacteristic =+          eulerCharacteristicValue (valuationEuler valuations)+      , cellExactArea = exactAreaSummary valuations+      }++regionAreaSummary+  :: PlanarRegion+  -> Either PlanarExampleError ExactFractionSummary+regionAreaSummary region =+  exactAreaSummary+    <$> first PlanarValuationFailed (regionValuations region)++exactAreaSummary :: PlanarValuations -> ExactFractionSummary+exactAreaSummary valuations =+  let area = exactAreaValue (valuationArea valuations)+   in ExactFractionSummary+        { fractionNumerator = exactRationalNumerator area+        , fractionDenominator = exactRationalDenominator area+        }
+ docs/examples/Moonlight/Triangulation/Example/SetAlgebra.hs view
@@ -0,0 +1,26 @@+module Moonlight.Triangulation.Example.SetAlgebra+  ( siteCounts+  ) where++import qualified Data.Vector as Vector+import Moonlight.Triangulation++-- | Join and meet two overlapping site sets through the public facade.+siteCounts :: Either BuildError (Int, Int)+siteCounts = do+  left <- unitSquareAt 0+  right <- unitSquareAt 1+  joined <- left `union` right+  shared <- intersection left right+  pure (numVertices joined, numVertices shared)++unitSquareAt :: Double -> Either BuildError (DelaunayTriangulation ())+unitSquareAt minimumX =+  delaunayGeometry+    ( Vector.fromList+        [ Point minimumX 0+        , Point (minimumX + 1) 0+        , Point (minimumX + 1) 1+        , Point minimumX 1+        ]+    )
+ docs/examples/README.md view
@@ -0,0 +1,20 @@+# Compile-checked usage examples++[Return to the package overview.](../../README.md#use)+· [Browse the documentation.](../README.md)++The ordinary examples import only the public `Moonlight.Triangulation` facade.+The activation example names its opt-in `zigzag` component explicitly. Package+tests compile every module and own their deterministic expected results.++| Workflow | Canonical source |+| --- | --- |+| Join and meet overlapping site sets | [`SetAlgebra.hs`](./Moonlight/Triangulation/Example/SetAlgebra.hs) |+| Recover a constrained annulus interior | [`ConstrainedRegion.hs`](./Moonlight/Triangulation/Example/ConstrainedRegion.hs) |+| Descend an alpha face section to its boundary | [`AlphaBoundary.hs`](./Moonlight/Triangulation/Example/AlphaBoundary.hs) |+| Overlay, measure, and morph exact regions | [`PlanarRegion.hs`](./Moonlight/Triangulation/Example/PlanarRegion.hs) |+| Track an alpha loop across non-nested depths | [`ActivationZigzag.hs`](./Moonlight/Triangulation/Example/ActivationZigzag.hs) |++[The facade example test](../../test/examples/Main.hs) and+[zigzag test](../../test/zigzag/Main.hs) check every published summary against+these sources.
+ docs/mesh-publication.md view
@@ -0,0 +1,56 @@+# Mesh publication schedules++[Read the set-operation types.](../README.md#set-operation-types)+· [Choose an operation.](../README.md#operations)++Programs choose an operation by its semantic result; Moonlight chooses its+execution schedule. The schedule changes identity reuse, allocation, and+throughput, not the represented site set.++## Persistent publication schedules++These are the currently measured publication choices. `canonicalize` remains+the explicit global observation when construction-independent numbering is+required.++| Operation context | Publication schedule |+| --- | --- |+| `siteRelation left right` | Index the smaller support in one transient exact open-addressed section, scan the other operand, then discard the index; no support maps or published cache state. |+| `difference mesh empty`, `symmetricDifference mesh empty`, `symmetricDifference empty mesh` | Return the surviving representative verbatim. |+| `difference left right` with `size right <= (size left - size right) / 128` | Remove the right support through one local copy-on-write session; return `left` verbatim when the supports are disjoint. Larger masks rebuild. |+| Geometry-only `intersection left right` | Return an existing operand for equality or subset, return the empty mesh for disjoint supports, and locally remove the smaller complement when it is at most `overlap / 128`. Other partial overlaps rebuild. |+| `intersectionWith` | Rebuild, because the annotation combiner may rewrite every surviving payload even when topology changes locally. |+| `symmetricDifference left right` with `small <= (large - small) / 128` | Toggle the smaller operand through one local session. Comparable operands and small-output, large-input cases rebuild. |+| Comparable `symmetricDifference left right` | Partition through one transient exact index and a matched bitset, then rebuild only the exclusive output section. |+| Package-internal `BulkLoad.insert` / `BulkLoad.insertAt` | Dense publication below 10,000 resident sites; copy-on-write publication at 10,000 and above. Internal edit sequences descend through one `Session`. |+| `extendConstrainedWith` | Copy-on-write only for a base of at least 200,000 sites, at most 128 incoming sites, exactly one incoming segment, and a pre-thaw corridor with no resident intersection. Every unmeasured or resident-corridor case stays dense. |+| `refineWithinDomain` | Dense publication. The measured local transaction candidate did not improve wall time. |++## Persistent values at scale++`union` classifies a pair before selecting its schedule: empty and repeated+operands return an existing value, separated operands merge at their seam,+subsets reuse their superset, skewed pairs insert the smaller support, and the+remaining cases rebuild.++```haskell+insertionIsCheaper addition base = addition <= 64 || addition <= base `quot` 8+```++Local schedules publish a fresh immutable mesh from the pages they touched, so+readers continue observing the previous value while the next is built. A failed+operation returns its obstruction with both operands unchanged.++`Moonlight.Triangulation.Parallel.unionsConcurrently` interprets the same pure+join tournament with bounded concurrency.++## Source authority++The executable schedule decisions live in+[`SetAlgebra`](../src-build/Moonlight/Triangulation/SetAlgebra.hs),+[`BulkLoad`](../src-build/Moonlight/Triangulation/BulkLoad.hs),+[`Join.Plan`](../src-build/Moonlight/Triangulation/Internal/Join/Plan.hs), and+[`Cdt.Union`](../src-build/Moonlight/Triangulation/Internal/Cdt/Union.hs). The+focused measurements live in+[`JoinBench`](../bench/join/Moonlight/Triangulation/JoinBench.hs); this page is+their consumer-facing projection.
+ docs/persistence-rose/Main.hs view
@@ -0,0 +1,212 @@+module Main (main) where++import Control.Exception (IOException, try)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except+  ( ExceptT (..),+    except,+    runExceptT,+  )+import Data.Bifunctor (first)+import Data.ByteString (ByteString)+import Data.ByteString qualified as ByteString+import Data.Foldable (traverse_)+import Moonlight.Triangulation.Exhibit.PersistenceRose+  ( PersistenceRoseError,+    PersistenceRoseScene,+    alphaEclipseReceipt,+    buildAlphaEclipseScene,+    buildPersistenceRoseScene,+    persistenceRoseFrameSpecs,+    persistenceRoseReceipt,+    renderAlphaEclipse,+    renderAlphaEclipseReceipt,+    renderPersistenceRoseAnimationReceipt,+    renderPersistenceRoseFrame,+    renderPersistenceRosePoster,+    renderPersistenceRoseReceipt,+    stampPersistenceRoseGif,+    verifyPersistenceRoseGif,+  )+import System.Directory (createDirectoryIfMissing)+import System.Environment (getArgs)+import System.Exit (die)+import System.FilePath ((</>), takeDirectory)+import Text.Printf (printf)+import Text.Read (readMaybe)++data PersistenceRoseCommand+  = WritePoster !FilePath+  | WriteEclipse !FilePath+  | WriteFrames !Int !FilePath+  | StampGif !FilePath !FilePath+  | VerifyArtifacts !FilePath+  | PrintReceipt++data PersistenceRoseCommandError+  = PersistenceRoseUsage ![String]+  | PersistenceRoseInvalidFrameCount !String+  | PersistenceRoseConstructionFailed !PersistenceRoseError+  | PersistenceRoseDirectoryFailed !FilePath !IOException+  | PersistenceRoseReadFailed !FilePath !IOException+  | PersistenceRoseWriteFailed !FilePath !IOException+  | PersistenceRoseArtifactMismatch !FilePath++instance Show PersistenceRoseCommandError where+  show commandError =+    case commandError of+      PersistenceRoseUsage arguments ->+        "invalid persistence-rose command "+          <> show arguments+          <> "; expected: poster OUTPUT.svg | eclipse OUTPUT.svg | frames FRAME_COUNT OUTPUT_DIRECTORY | stamp-gif INPUT.gif OUTPUT.gif | verify-artifacts PACKAGE_ROOT | receipt"+      PersistenceRoseInvalidFrameCount submitted ->+        "frame count must be an integer greater than one, received " <> show submitted+      PersistenceRoseConstructionFailed sceneError -> show sceneError+      PersistenceRoseDirectoryFailed path caughtError ->+        "could not create output directory " <> show path <> ": " <> show caughtError+      PersistenceRoseReadFailed path caughtError ->+        "could not read " <> show path <> ": " <> show caughtError+      PersistenceRoseWriteFailed path caughtError ->+        "could not write " <> show path <> ": " <> show caughtError+      PersistenceRoseArtifactMismatch path ->+        "tracked exhibit differs from its canonical renderer: " <> show path++main :: IO ()+main = do+  arguments <- getArgs+  result <- runExceptT (runPersistenceRoseCommand arguments)+  either (die . show) pure result++runPersistenceRoseCommand :: [String] -> ExceptT PersistenceRoseCommandError IO ()+runPersistenceRoseCommand arguments = do+  command <- except (parseCommand arguments)+  case command of+    WriteEclipse outputPath -> do+      scene <- except (first PersistenceRoseConstructionFailed buildAlphaEclipseScene)+      createOutputDirectory (takeDirectory outputPath)+      writeOutput outputPath (renderAlphaEclipse scene)+      lift+        ( putStrLn+            (renderAlphaEclipseReceipt (alphaEclipseReceipt scene) <> "\nwrote alpha eclipse " <> outputPath)+        )+    StampGif inputPath outputPath -> do+      scene <- requirePersistenceRoseScene+      inputBytes <- readBytes inputPath+      (receipt, stamped) <- except (first PersistenceRoseConstructionFailed (stampPersistenceRoseGif scene inputBytes))+      createOutputDirectory (takeDirectory outputPath)+      writeBytes outputPath stamped+      lift+        ( putStrLn+            (renderPersistenceRoseAnimationReceipt receipt <> "\nwrote stamped GIF " <> outputPath)+        )+    VerifyArtifacts packageRoot -> verifyTrackedArtifacts packageRoot+    PrintReceipt -> do+      scene <- requirePersistenceRoseScene+      lift (putStrLn (renderPersistenceRoseReceipt (persistenceRoseReceipt scene)))+    WritePoster outputPath -> do+      scene <- requirePersistenceRoseScene+      let receiptText = renderPersistenceRoseReceipt (persistenceRoseReceipt scene)+      createOutputDirectory (takeDirectory outputPath)+      writeOutput outputPath (renderPersistenceRosePoster scene)+      lift (putStrLn (receiptText <> "\nwrote poster " <> outputPath))+    WriteFrames frameCount outputDirectory -> do+      scene <- requirePersistenceRoseScene+      let receiptText = renderPersistenceRoseReceipt (persistenceRoseReceipt scene)+      frames <- except (first PersistenceRoseConstructionFailed (persistenceRoseFrameSpecs frameCount))+      createOutputDirectory outputDirectory+      traverse_+        (\(frameIndex, frame) -> writeOutput (framePath outputDirectory frameIndex) (renderPersistenceRoseFrame scene frame))+        (zip [0 :: Int ..] frames)+      lift+        ( putStrLn+            ( receiptText+                <> "\nwrote "+                <> show (length frames)+                <> " frames to "+                <> outputDirectory+            )+        )++requirePersistenceRoseScene :: ExceptT PersistenceRoseCommandError IO PersistenceRoseScene+requirePersistenceRoseScene =+  except (first PersistenceRoseConstructionFailed buildPersistenceRoseScene)++parseCommand :: [String] -> Either PersistenceRoseCommandError PersistenceRoseCommand+parseCommand arguments =+  case arguments of+    ["poster", outputPath] -> Right (WritePoster outputPath)+    ["eclipse", outputPath] -> Right (WriteEclipse outputPath)+    ["stamp-gif", inputPath, outputPath] -> Right (StampGif inputPath outputPath)+    ["verify-artifacts", packageRoot] -> Right (VerifyArtifacts packageRoot)+    ["frames", submittedCount, outputDirectory] ->+      case readMaybe submittedCount of+        Just frameCount+          | frameCount > 1 -> Right (WriteFrames frameCount outputDirectory)+        _ -> Left (PersistenceRoseInvalidFrameCount submittedCount)+    ["receipt"] -> Right PrintReceipt+    _ -> Left (PersistenceRoseUsage arguments)++createOutputDirectory :: FilePath -> ExceptT PersistenceRoseCommandError IO ()+createOutputDirectory outputDirectory =+  liftIOException+    (PersistenceRoseDirectoryFailed outputDirectory)+    (createDirectoryIfMissing True outputDirectory)++writeOutput :: FilePath -> String -> ExceptT PersistenceRoseCommandError IO ()+writeOutput outputPath contents =+  liftIOException (PersistenceRoseWriteFailed outputPath) (writeFile outputPath contents)++readOutput :: FilePath -> ExceptT PersistenceRoseCommandError IO String+readOutput inputPath =+  liftIOException (PersistenceRoseReadFailed inputPath) (readFile inputPath)++readBytes :: FilePath -> ExceptT PersistenceRoseCommandError IO ByteString+readBytes inputPath =+  liftIOException (PersistenceRoseReadFailed inputPath) (ByteString.readFile inputPath)++writeBytes :: FilePath -> ByteString -> ExceptT PersistenceRoseCommandError IO ()+writeBytes outputPath contents =+  liftIOException (PersistenceRoseWriteFailed outputPath) (ByteString.writeFile outputPath contents)++verifyTrackedArtifacts :: FilePath -> ExceptT PersistenceRoseCommandError IO ()+verifyTrackedArtifacts packageRoot = do+  roseScene <- requirePersistenceRoseScene+  eclipseScene <- except (first PersistenceRoseConstructionFailed buildAlphaEclipseScene)+  let exhibitRoot = packageRoot </> "docs" </> "persistence-rose"+      posterPath = exhibitRoot </> "moonlight-triangulation-persistence-rose.svg"+      eclipsePath = exhibitRoot </> "moonlight-triangulation-alpha-eclipse.svg"+      gifPath = exhibitRoot </> "moonlight-triangulation-persistence-rose.gif"+  verifyTextArtifact posterPath (renderPersistenceRosePoster roseScene)+  verifyTextArtifact eclipsePath (renderAlphaEclipse eclipseScene)+  gifBytes <- readBytes gifPath+  animationReceipt <-+    except+      (first PersistenceRoseConstructionFailed (verifyPersistenceRoseGif roseScene gifBytes))+  lift+    ( putStrLn+        ( "verified poster, alpha eclipse, and stamped GIF\n"+            <> renderPersistenceRoseAnimationReceipt animationReceipt+        )+    )++verifyTextArtifact+  :: FilePath+  -> String+  -> ExceptT PersistenceRoseCommandError IO ()+verifyTextArtifact artifactPath expectedContents = do+  actualContents <- readOutput artifactPath+  except+    ( if actualContents == expectedContents+        then Right ()+        else Left (PersistenceRoseArtifactMismatch artifactPath)+    )++liftIOException+  :: (IOException -> PersistenceRoseCommandError)+  -> IO value+  -> ExceptT PersistenceRoseCommandError IO value+liftIOException wrapFailure = ExceptT . fmap (first wrapFailure) . try++framePath :: FilePath -> Int -> FilePath+framePath outputDirectory frameIndex =+  outputDirectory </> printf "frame-%04d.svg" frameIndex
+ docs/persistence-rose/Moonlight/Triangulation/Exhibit/PersistenceRose.hs view
@@ -0,0 +1,1625 @@+{-# LANGUAGE NamedFieldPuns #-}++-- | A deterministic, pure observatory assembled from Moonlight's existing+-- geometry, exact filtration, interpolation, and persistence owners.+module Moonlight.Triangulation.Exhibit.PersistenceRose+  ( PersistenceRoseError (..),+    PersistenceRoseReceipt (..),+    PersistenceRoseScene,+    PersistenceRoseFrame,+    PersistenceRoseAnimationReceipt (..),+    AlphaEclipseReceipt (..),+    AlphaEclipseScene,+    buildPersistenceRoseScene,+    buildAlphaEclipseScene,+    persistenceRoseReceipt,+    alphaEclipseReceipt,+    renderPersistenceRoseReceipt,+    renderAlphaEclipseReceipt,+    renderPersistenceRosePoster,+    renderAlphaEclipse,+    persistenceRoseFrameSpecs,+    renderPersistenceRoseFrame,+    persistenceRoseAnimationReceipt,+    renderPersistenceRoseAnimationReceipt,+    stampPersistenceRoseGif,+    verifyPersistenceRoseGif,+  )+where++import Control.Monad (foldM)+import Control.Monad.ST (runST)+import Data.Bifunctor (first)+import Data.Bits ((.&.), xor)+import Data.ByteString (ByteString)+import Data.ByteString qualified as ByteString+import Data.ByteString.Char8 qualified as ByteString.Char8+import Data.List (find, intercalate, sortOn)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.Ord (Down (..))+import Data.Set qualified as Set+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encoding+import Data.Vector qualified as Vector+import Data.Word (Word64, Word8)+import Moonlight.Homology.Chain+  ( HomologicalDegree (..),+    HomologyFailure,+    PersistencePair (..),+  )+import Moonlight.Homology.Persistence+  ( criticalBettiVectors,+    mod2PersistentPairsWithCriticalBettiTable,+  )+import Moonlight.Triangulation+  ( AlphaBirth,+    AlphaFiltration,+    AlphaFiltrationError,+    BuildError,+    DelaunayTriangulation,+    ExactLoop,+    MinkowskiError,+    OverlayError,+    PlanarRegion,+    Point (..),+    PointValidationError,+    PolygonComponent,+    QueryPoint,+    RegionPublicationError,+    RegionValidationError,+    alphaBirthDenominator,+    alphaBirthNumerator,+    alphaBirthToDouble,+    alphaEdgeBirth,+    alphaFaceBirth,+    alphaFiltration,+    alphaFiltrationCriticalBirths,+    convexPolygon,+    delaunayGeometry,+    exactLoop,+    exactLoopPoints,+    exactPointFromPoint,+    exactPointToEmbeddingCandidate,+    innerFaces,+    innerFaceVertexTriples,+    mkQueryPoint,+    overlayLayers,+    overlaySelectedRegion,+    planarLayer,+    planarRegion,+    planarRegionComponents,+    polygonComponent,+    polygonHoleLoops,+    polygonOffset,+    polygonOuterLoop,+    queryPointValue,+    structuringElement,+    undirectedEdges,+    undirectedEndpoints,+    vertexPoint,+    vertices,+  )+import Moonlight.Triangulation.CellComplex+  ( DCELError,+    filteredAlphaComplex,+  )+import Moonlight.Triangulation.FloodFillIterator+  ( BoundaryObstruction,+    FaceComponent,+    boundaryLoopVertices,+    componentBoundaryLoops,+    faceComponentFaces,+    faceComponentsBy,+    outerFaceFloodFill,+  )+import Moonlight.Triangulation.Internal.HandleDefs+  ( FaceId (..),+    UndirectedEdgeId,+    VertexId,+    normalizedDirected,+  )+import Moonlight.Triangulation.Interpolation+  ( InterpolationStats (..),+    NaturalNeighborResult (..),+    naturalNeighborWeights,+    newNaturalNeighborWorkspace,+  )+import Moonlight.Triangulation.Voronoi+  ( VoronoiEdgeGeometry (..),+    asDirectedVoronoiEdge,+    voronoiEdgeGeometry,+  )+import Numeric (showFFloat, showHex)++-- | Every boundary at which the exhibit may be refused. The renderer never+-- invents a fallback geometry or topology state.+data PersistenceRoseError+  = RoseDelaunayBuildFailed !BuildError+  | RoseAlphaFiltrationFailed !AlphaFiltrationError+  | RoseCellComplexLoweringFailed !DCELError+  | RosePersistenceFailed !HomologyFailure+  | RoseCriticalProfileCountMismatch !Int !Int+  | RoseCriticalProfileDegreeCountMismatch !Int !Int+  | RoseBirthRankMissing !AlphaBirth+  | RoseEdgeBirthMissing !UndirectedEdgeId+  | RoseFaceBirthMissing !FaceId+  | RoseBoundaryDescentFailed !Int !BoundaryObstruction+  | RoseNoCriticalStates+  | RoseNoMaskRegions+  | RoseNoPersistentHole+  | RoseNoCoherentHero !Int ![(Int, Int)]+  | RoseVoronoiGeometryMissing !UndirectedEdgeId+  | RoseNaturalNeighborFallbacks !Int+  | RosePointInvalid !PointValidationError+  | RoseRegionInvalid !RegionValidationError+  | RoseOverlayFailed !(OverlayError Bool Bool)+  | RoseOverlayPublicationFailed !RegionPublicationError+  | RoseMinkowskiFailed !MinkowskiError+  | RoseFrameCountTooSmall !Int+  | RoseEclipseFiniteHoleCountMismatch !Int+  | RoseEclipseFiniteHoleMissingDeath+  | RoseEclipseBettiProfileMismatch !Int !Int !Int+  | RoseGifInvalidSignature+  | RoseGifTruncated !Int+  | RoseGifUnexpectedBlock !Int !Word8+  | RoseGifDimensionMismatch !Int !Int !Int !Int+  | RoseGifFrameCountMismatch !Int !Int+  | RoseGifFrameDelayCountMismatch !Int !Int+  | RoseGifDurationMismatch !Int !Int+  | RoseGifProvenanceMismatch+  | RoseGifMarkerTooLong !Int+  deriving stock (Show)++-- | A compact, test-readable projection of everything the scene actually+-- computed. It is intentionally not another geometry representation.+data PersistenceRoseReceipt = PersistenceRoseReceipt+  { roseSiteCount :: !Int,+    roseEdgeCount :: !Int,+    roseFaceCount :: !Int,+    roseCriticalBirthCount :: !Int,+    roseFinitePersistentHoleCount :: !Int,+    roseEssentialPersistentHoleCount :: !Int,+    roseHeroCriticalRank :: !Int,+    roseHeroBettiOne :: !Int,+    roseHeroGeometricHoleCount :: !Int,+    roseVoronoiSegmentCount :: !Int,+    roseNaturalNeighborSampleCount :: !Int,+    roseNaturalNeighborFallbackCount :: !Int,+    roseMaskComponentCount :: !Int+  }+  deriving stock (Eq, Show)++data PersistenceRoseScene = PersistenceRoseScene+  { sceneSites :: ![Point],+    sceneEdges :: ![RankedSegment],+    sceneFaces :: ![RankedTriangle],+    sceneCriticalStates :: !(NonEmpty CriticalState),+    sceneHeroState :: !CriticalState,+    sceneVoronoiSegments :: ![Segment],+    sceneFieldSamples :: ![FieldSample],+    sceneMaskComponents :: ![MaskComponent],+    scenePersistenceArcs :: ![PersistenceArc],+    sceneReceipt :: !PersistenceRoseReceipt+  }++-- | The canonical source projection carried inside the retained GIF. The GIF+-- codec remains an effect-boundary view; this receipt binds that binary view+-- to the exact deterministic SVG frame section used to produce it.+data PersistenceRoseAnimationReceipt = PersistenceRoseAnimationReceipt+  { roseAnimationFrameCount :: !Int,+    roseAnimationFramesPerSecond :: !Int,+    roseAnimationWidth :: !Int,+    roseAnimationHeight :: !Int,+    roseAnimationSourceFingerprint :: !Word64+  }+  deriving stock (Eq, Show)++-- | The exact, test-readable facts shown by the alpha eclipse. The numerator+-- and denominator fields are projections of opaque 'AlphaBirth' values; the+-- renderer never chooses thresholds independently of the filtration.+data AlphaEclipseReceipt = AlphaEclipseReceipt+  { eclipseSiteCount :: !Int,+    eclipseEdgeCount :: !Int,+    eclipseFaceCount :: !Int,+    eclipseHoleBirthNumerator :: !Integer,+    eclipseHoleBirthDenominator :: !Integer,+    eclipseHoleDeathNumerator :: !Integer,+    eclipseHoleDeathDenominator :: !Integer,+    eclipseBettiBeforeBirth :: !Int,+    eclipseBettiAtBirth :: !Int,+    eclipseBettiAtDeath :: !Int+  }+  deriving stock (Eq, Show)++-- | A three-section observation of one fixed resident Delaunay DCEL. Every+-- displayed edge and face is projected from that DCEL with its exact birth+-- rank; only the selected sublevel differs between sections.+data AlphaEclipseScene = AlphaEclipseScene+  { eclipseSites :: ![Point],+    eclipseEdges :: ![RankedSegment],+    eclipseFaces :: ![RankedTriangle],+    eclipseBeforeState :: !CriticalState,+    eclipseBirthState :: !CriticalState,+    eclipseDeathState :: !CriticalState,+    eclipseReceipt :: !AlphaEclipseReceipt+  }++-- | The shared local descent used by both exhibits. This is not a second+-- filtration carrier: it retains the canonical mesh and filtration beside+-- their checked Homology projection and only the ranked rendering views.+data AlphaProjection = AlphaProjection+  { projectionTriangulation :: !(DelaunayTriangulation ()),+    projectionPersistencePairs :: ![PersistencePair AlphaBirth],+    projectionCriticalStates :: !(NonEmpty CriticalState),+    projectionBirthRanks :: !(Map AlphaBirth Int),+    projectionEdges :: ![RankedSegment],+    projectionFaces :: ![RankedTriangle]+  }++newtype PersistenceRoseFrame = PersistenceRoseFrame+  { frameProgress :: Double+  }+  deriving stock (Eq, Show)++data CriticalState = CriticalState+  { criticalRank :: !Int,+    criticalBirth :: !AlphaBirth,+    criticalBettiOne :: !Int,+    criticalHoles :: ![HoleComponent]+  }++data RankedSegment = RankedSegment+  { rankedSegmentGeometry :: !Segment,+    rankedSegmentBirthRank :: !Int+  }++data RankedTriangle = RankedTriangle+  { rankedTrianglePoints :: !(Point, Point, Point),+    rankedTriangleBirthRank :: !Int+  }++data Segment = Segment !Point !Point++newtype HoleComponent = HoleComponent [[Point]]++data FieldSample = FieldSample+  { fieldSamplePoint :: !Point,+    fieldSampleValue :: !Double,+    fieldSampleNeighborCount :: !Int+  }++data MaskComponent = MaskComponent+  { maskOuterLoop :: ![Point],+    maskHoleLoops :: ![[Point]]+  }++data PersistenceArc = PersistenceArc+  { persistenceArcBirthRank :: !Int,+    persistenceArcDeathRank :: !Int+  }++buildPersistenceRoseScene :: Either PersistenceRoseError PersistenceRoseScene+buildPersistenceRoseScene = do+  projection <- buildAlphaProjection roseSites+  let triangulation = projectionTriangulation projection+      criticalStates = projectionCriticalStates projection+      persistencePairs = projectionPersistencePairs projection+      criticalBirthCount = NonEmpty.length criticalStates+  heroState <- chooseHeroState criticalStates+  finiteVoronoiSegments <- projectFiniteVoronoiSegments triangulation+  (fieldSamples, fallbackCount) <- naturalNeighborField triangulation+  if fallbackCount == 0+    then pure ()+    else Left (RoseNaturalNeighborFallbacks fallbackCount)+  maskComponents <- buildRoseMask+  persistenceArcs <-+    projectPersistenceArcs+      (projectionBirthRanks projection)+      criticalBirthCount+      persistencePairs+  let finiteHoles = filter isFinitePositiveHole persistencePairs+      essentialHoles = filter isEssentialHole persistencePairs+      heroHoleCount = length (criticalHoles heroState)+      receipt =+        PersistenceRoseReceipt+          { roseSiteCount = length (vertices triangulation),+            roseEdgeCount = length (projectionEdges projection),+            roseFaceCount = length (projectionFaces projection),+            roseCriticalBirthCount = criticalBirthCount,+            roseFinitePersistentHoleCount = length finiteHoles,+            roseEssentialPersistentHoleCount = length essentialHoles,+            roseHeroCriticalRank = criticalRank heroState,+            roseHeroBettiOne = criticalBettiOne heroState,+            roseHeroGeometricHoleCount = heroHoleCount,+            roseVoronoiSegmentCount = length finiteVoronoiSegments,+            roseNaturalNeighborSampleCount = length fieldSamples,+            roseNaturalNeighborFallbackCount = fallbackCount,+            roseMaskComponentCount = length maskComponents+          }+  pure+    PersistenceRoseScene+      { sceneSites = fmap (vertexPoint triangulation) (vertices triangulation),+        sceneEdges = projectionEdges projection,+        sceneFaces = projectionFaces projection,+        sceneCriticalStates = criticalStates,+        sceneHeroState = heroState,+        sceneVoronoiSegments = finiteVoronoiSegments,+        sceneFieldSamples = fieldSamples,+        sceneMaskComponents = maskComponents,+        scenePersistenceArcs = persistenceArcs,+        sceneReceipt = receipt+      }++buildAlphaProjection :: [Point] -> Either PersistenceRoseError AlphaProjection+buildAlphaProjection sites = do+  triangulation <- first RoseDelaunayBuildFailed (delaunayGeometry (Vector.fromList sites))+  filtration <- first RoseAlphaFiltrationFailed (alphaFiltration triangulation)+  filteredComplex <- first RoseCellComplexLoweringFailed (filteredAlphaComplex filtration)+  (persistencePairs, criticalBettiTable) <-+    first RosePersistenceFailed+      (mod2PersistentPairsWithCriticalBettiTable filteredComplex)+  let criticalBirths = alphaFiltrationCriticalBirths filtration+      criticalProfiles = criticalBettiVectors criticalBettiTable+      birthRanks = Map.fromDistinctAscList (zip criticalBirths [0 ..])+  if length criticalBirths == length criticalProfiles+    then pure ()+    else Left (RoseCriticalProfileCountMismatch (length criticalBirths) (length criticalProfiles))+  criticalStates <-+    traverse+      (buildCriticalState triangulation filtration)+      (zip3 [0 ..] criticalBirths criticalProfiles)+      >>= maybe (Left RoseNoCriticalStates) Right . NonEmpty.nonEmpty+  rankedEdges <-+    traverse+      (projectRankedEdge triangulation filtration birthRanks)+      (undirectedEdges triangulation)+  rankedFaces <-+    traverse+      (projectRankedFace triangulation filtration birthRanks)+      (zip [1 ..] (Vector.toList (innerFaceVertexTriples triangulation)))+  pure+    AlphaProjection+      { projectionTriangulation = triangulation,+        projectionPersistencePairs = persistencePairs,+        projectionCriticalStates = criticalStates,+        projectionBirthRanks = birthRanks,+        projectionEdges = rankedEdges,+        projectionFaces = rankedFaces+      }++buildAlphaEclipseScene :: Either PersistenceRoseError AlphaEclipseScene+buildAlphaEclipseScene = do+  projection <- buildAlphaProjection alphaEclipseSites+  finiteHoles <-+    case filter isFinitePositiveHole (projectionPersistencePairs projection) of+      [finiteHole] -> Right finiteHole+      holes -> Left (RoseEclipseFiniteHoleCountMismatch (length holes))+  deathBirth <-+    maybe+      (Left RoseEclipseFiniteHoleMissingDeath)+      Right+      (persistenceDeath finiteHoles)+  let birth = persistenceBirth finiteHoles+      birthRanks = projectionBirthRanks projection+      states = projectionCriticalStates projection+  birthRank <- maybe (Left (RoseBirthRankMissing birth)) Right (Map.lookup birth birthRanks)+  deathRank <- maybe (Left (RoseBirthRankMissing deathBirth)) Right (Map.lookup deathBirth birthRanks)+  let beforeState = criticalStateAt (max 0 (birthRank - 1)) states+      birthState = criticalStateAt birthRank states+      deathState = criticalStateAt deathRank states+      bettiProfile =+        ( criticalBettiOne beforeState,+          criticalBettiOne birthState,+          criticalBettiOne deathState+        )+  case bettiProfile of+    (0, 1, 0) -> pure ()+    (beforeBetti, birthBetti, deathBetti) ->+      Left (RoseEclipseBettiProfileMismatch beforeBetti birthBetti deathBetti)+  let triangulation = projectionTriangulation projection+      receipt =+        AlphaEclipseReceipt+          { eclipseSiteCount = length (vertices triangulation),+            eclipseEdgeCount = length (projectionEdges projection),+            eclipseFaceCount = length (projectionFaces projection),+            eclipseHoleBirthNumerator = alphaBirthNumerator birth,+            eclipseHoleBirthDenominator = alphaBirthDenominator birth,+            eclipseHoleDeathNumerator = alphaBirthNumerator deathBirth,+            eclipseHoleDeathDenominator = alphaBirthDenominator deathBirth,+            eclipseBettiBeforeBirth = criticalBettiOne beforeState,+            eclipseBettiAtBirth = criticalBettiOne birthState,+            eclipseBettiAtDeath = criticalBettiOne deathState+          }+  pure+    AlphaEclipseScene+      { eclipseSites = fmap (vertexPoint triangulation) (vertices triangulation),+        eclipseEdges = projectionEdges projection,+        eclipseFaces = projectionFaces projection,+        eclipseBeforeState = beforeState,+        eclipseBirthState = birthState,+        eclipseDeathState = deathState,+        eclipseReceipt = receipt+      }++persistenceRoseReceipt :: PersistenceRoseScene -> PersistenceRoseReceipt+persistenceRoseReceipt = sceneReceipt++alphaEclipseReceipt :: AlphaEclipseScene -> AlphaEclipseReceipt+alphaEclipseReceipt = eclipseReceipt++renderPersistenceRoseReceipt :: PersistenceRoseReceipt -> String+renderPersistenceRoseReceipt receipt =+  intercalate+    " · "+    [ "sites " <> show (roseSiteCount receipt),+      "edges " <> show (roseEdgeCount receipt),+      "faces " <> show (roseFaceCount receipt),+      "critical births " <> show (roseCriticalBirthCount receipt),+      "finite H1 intervals " <> show (roseFinitePersistentHoleCount receipt),+      "essential H1 intervals " <> show (roseEssentialPersistentHoleCount receipt),+      "hero rank " <> show (roseHeroCriticalRank receipt),+      "beta1 " <> show (roseHeroBettiOne receipt),+      "geometric holes " <> show (roseHeroGeometricHoleCount receipt),+      "Voronoi segments " <> show (roseVoronoiSegmentCount receipt),+      "Sibson samples " <> show (roseNaturalNeighborSampleCount receipt),+      "fallbacks " <> show (roseNaturalNeighborFallbackCount receipt),+      "mask components " <> show (roseMaskComponentCount receipt)+    ]++renderAlphaEclipseReceipt :: AlphaEclipseReceipt -> String+renderAlphaEclipseReceipt receipt =+  intercalate+    " · "+    [ "sites " <> show (eclipseSiteCount receipt),+      "edges " <> show (eclipseEdgeCount receipt),+      "faces " <> show (eclipseFaceCount receipt),+      "H1 ["+        <> renderExactRatio (eclipseHoleBirthNumerator receipt) (eclipseHoleBirthDenominator receipt)+        <> ", "+        <> renderExactRatio (eclipseHoleDeathNumerator receipt) (eclipseHoleDeathDenominator receipt)+        <> ")",+      "beta1 "+        <> show+          ( eclipseBettiBeforeBirth receipt,+            eclipseBettiAtBirth receipt,+            eclipseBettiAtDeath receipt+          )+    ]++buildCriticalState+  :: DelaunayTriangulation ()+  -> AlphaFiltration+  -> (Int, AlphaBirth, [Int])+  -> Either PersistenceRoseError CriticalState+buildCriticalState triangulation filtration (rankValue, birthValue, profile) = do+  bettiOne <-+    case profile of+      _ : secondDegree : _ : _ -> Right secondDegree+      _ -> Left (RoseCriticalProfileDegreeCountMismatch rankValue (length profile))+  holes <- holeComponentsAt rankValue triangulation filtration birthValue+  pure+    CriticalState+      { criticalRank = rankValue,+        criticalBirth = birthValue,+        criticalBettiOne = bettiOne,+        criticalHoles = holes+      }++chooseHeroState :: NonEmpty CriticalState -> Either PersistenceRoseError CriticalState+chooseHeroState states =+  let stateList = NonEmpty.toList states+      maximumBettiOne = foldl' (\best state -> max best (criticalBettiOne state)) 0 stateList+      maximalStates = filter ((== maximumBettiOne) . criticalBettiOne) stateList+      agreements = fmap (\state -> (criticalBettiOne state, length (criticalHoles state))) maximalStates+      coherentStates =+        filter+          (\state -> criticalBettiOne state > 0 && criticalBettiOne state == length (criticalHoles state))+          stateList+      sevenPetalStates = filter ((== rosePetalCount) . criticalBettiOne) coherentStates+   in if maximumBettiOne <= 0+        then Left RoseNoPersistentHole+        else+          case NonEmpty.nonEmpty sevenPetalStates of+            Just preferredStates -> Right (latestCriticalState preferredStates)+            Nothing ->+              maybe+                (Left (RoseNoCoherentHero maximumBettiOne agreements))+                Right+                (find (\state -> criticalBettiOne state == length (criticalHoles state)) maximalStates)++latestCriticalState :: NonEmpty CriticalState -> CriticalState+latestCriticalState (firstState :| remainingStates) =+  foldl'+    (\latest candidate -> if criticalRank candidate > criticalRank latest then candidate else latest)+    firstState+    remainingStates++holeComponentsAt+  :: Int+  -> DelaunayTriangulation ()+  -> AlphaFiltration+  -> AlphaBirth+  -> Either PersistenceRoseError [HoleComponent]+holeComponentsAt rankValue triangulation filtration threshold = do+  inactiveEdges <-+    inactiveHandlesAt+      RoseEdgeBirthMissing+      (alphaEdgeBirth filtration)+      (undirectedEdges triangulation)+      threshold+  inactiveFaces <-+    inactiveHandlesAt+      RoseFaceBirthMissing+      (alphaFaceBirth filtration)+      (innerFaces triangulation)+      threshold+  let edgeInactive edge = Set.member edge inactiveEdges+      faceInactive face = Set.member face inactiveFaces+      exteriorFaces = Set.fromList (outerFaceFloodFill triangulation edgeInactive)+      inactiveComponents =+        fmap snd+          ( faceComponentsBy+              triangulation+              (\face -> if faceInactive face then Just () else Nothing)+              edgeInactive+          )+      boundedComponents =+        filter+          (all (`Set.notMember` exteriorFaces) . faceComponentFaces)+          inactiveComponents+  traverse+    (projectHoleComponent rankValue triangulation)+    boundedComponents++inactiveHandlesAt+  :: Ord handle+  => (handle -> PersistenceRoseError)+  -> (handle -> Maybe AlphaBirth)+  -> [handle]+  -> AlphaBirth+  -> Either PersistenceRoseError (Set.Set handle)+inactiveHandlesAt missingBirth birthAt handles threshold =+  Set.fromList . mapMaybe id+    <$> traverse+      ( \handle ->+          maybe+            (Left (missingBirth handle))+            (\birth -> Right (if birth > threshold then Just handle else Nothing))+            (birthAt handle)+      )+      handles++projectHoleComponent+  :: Int+  -> DelaunayTriangulation ()+  -> FaceComponent+  -> Either PersistenceRoseError HoleComponent+projectHoleComponent rankValue triangulation component = do+  loops <-+    first (RoseBoundaryDescentFailed rankValue)+      (componentBoundaryLoops triangulation component)+  pure+    ( HoleComponent+        ( fmap+            (fmap (vertexPoint triangulation) . NonEmpty.toList . boundaryLoopVertices)+            (NonEmpty.toList loops)+        )+    )++projectRankedEdge+  :: DelaunayTriangulation ()+  -> AlphaFiltration+  -> Map AlphaBirth Int+  -> UndirectedEdgeId+  -> Either PersistenceRoseError RankedSegment+projectRankedEdge triangulation filtration birthRanks edge = do+  birth <- maybe (Left (RoseEdgeBirthMissing edge)) Right (alphaEdgeBirth filtration edge)+  rankValue <- maybe (Left (RoseBirthRankMissing birth)) Right (Map.lookup birth birthRanks)+  let (fromVertex, toVertex) = undirectedEndpoints triangulation edge+  pure+    RankedSegment+      { rankedSegmentGeometry = Segment (vertexPoint triangulation fromVertex) (vertexPoint triangulation toVertex),+        rankedSegmentBirthRank = rankValue+      }++projectRankedFace+  :: DelaunayTriangulation ()+  -> AlphaFiltration+  -> Map AlphaBirth Int+  -> (Int, (VertexId, VertexId, VertexId))+  -> Either PersistenceRoseError RankedTriangle+projectRankedFace triangulation filtration birthRanks (rawFace, (firstVertex, secondVertex, thirdVertex)) = do+  let face = toFaceId rawFace+  birth <- maybe (Left (RoseFaceBirthMissing face)) Right (alphaFaceBirth filtration face)+  rankValue <- maybe (Left (RoseBirthRankMissing birth)) Right (Map.lookup birth birthRanks)+  pure+    RankedTriangle+      { rankedTrianglePoints =+          ( vertexPoint triangulation firstVertex,+            vertexPoint triangulation secondVertex,+            vertexPoint triangulation thirdVertex+          ),+        rankedTriangleBirthRank = rankValue+      }++toFaceId :: Int -> FaceId+toFaceId = FaceId . fromIntegral++projectFiniteVoronoiSegments+  :: DelaunayTriangulation ()+  -> Either PersistenceRoseError [Segment]+projectFiniteVoronoiSegments triangulation =+  fmap (mapMaybe id)+    . traverse projectSegment+    $ undirectedEdges triangulation+ where+  projectSegment :: UndirectedEdgeId -> Either PersistenceRoseError (Maybe Segment)+  projectSegment edge =+    case voronoiEdgeGeometry triangulation (asDirectedVoronoiEdge (normalizedDirected edge)) of+      Nothing -> Left (RoseVoronoiGeometryMissing edge)+      Just (VoronoiSegment fromPoint toPoint) -> Right (Just (Segment fromPoint toPoint))+      Just (VoronoiRay _ _) -> Right Nothing+      Just (VoronoiLine _ _) -> Right Nothing++naturalNeighborField+  :: DelaunayTriangulation ()+  -> Either PersistenceRoseError ([FieldSample], Int)+naturalNeighborField triangulation = do+  admittedQueries <- traverse (first RosePointInvalid . mkQueryPoint) fieldQueryPoints+  let results = runST $ do+        workspace <- newNaturalNeighborWorkspace triangulation+        traverse (naturalNeighborWeights workspace Nothing) admittedQueries+      pairedResults = zip admittedQueries results+      fallbackCount = length (filter (interpolationUsedFallback . naturalNeighborStats . snd) pairedResults)+      samples = mapMaybe (fieldSampleFromResult triangulation) pairedResults+  pure (samples, fallbackCount)++fieldSampleFromResult+  :: DelaunayTriangulation ()+  -> (QueryPoint, NaturalNeighborResult)+  -> Maybe FieldSample+fieldSampleFromResult triangulation (query, result)+  | Vector.null weights = Nothing+  | interpolationUsedFallback (naturalNeighborStats result) = Nothing+  | otherwise =+      let weightedValue =+            Vector.foldl'+              (\total (vertex, weight) -> total + weight * siteSignal (vertexPoint triangulation vertex))+              0+              weights+       in Just+            FieldSample+              { fieldSamplePoint = queryPointValue query,+                fieldSampleValue = clamp 0 1 weightedValue,+                fieldSampleNeighborCount = Vector.length weights+              }+ where+  weights = naturalNeighborValues result++siteSignal :: Point -> Double+siteSignal (Point x y) =+  clamp 0 1 (0.5 + 0.24 * sin (1.31 * x - 0.73 * y) + 0.18 * cos (0.61 * x + 1.17 * y))++fieldQueryPoints :: [Point]+fieldQueryPoints =+  [ Point (fromIntegral column * 0.34 - 5.1) (fromIntegral row * 0.34 - 4.42)+  | row <- [0 .. 26 :: Int],+    column <- [0 .. 30 :: Int]+  ]++projectPersistenceArcs+  :: Map AlphaBirth Int+  -> Int+  -> [PersistencePair AlphaBirth]+  -> Either PersistenceRoseError [PersistenceArc]+projectPersistenceArcs birthRanks criticalCount pairs = do+  arcs <- traverse pairArc (filter isPositiveHole pairs)+  pure (take 36 (sortOn (Down . persistenceArcLifetime) arcs))+ where+  finalRank = max 0 (criticalCount - 1)+  pairArc pair = do+    birthRank <- rankOf (persistenceBirth pair)+    deathRank <- maybe (Right finalRank) rankOf (persistenceDeath pair)+    pure+      PersistenceArc+        { persistenceArcBirthRank = birthRank,+          persistenceArcDeathRank = deathRank+        }+  rankOf birth = maybe (Left (RoseBirthRankMissing birth)) Right (Map.lookup birth birthRanks)++persistenceArcLifetime :: PersistenceArc -> Int+persistenceArcLifetime PersistenceArc{persistenceArcBirthRank, persistenceArcDeathRank} =+  max 0 (persistenceArcDeathRank - persistenceArcBirthRank)++isPositiveHole :: PersistencePair AlphaBirth -> Bool+isPositiveHole pair =+  persistenceDegree pair == HomologicalDegree 1+    && maybe True (> persistenceBirth pair) (persistenceDeath pair)++isFinitePositiveHole :: PersistencePair AlphaBirth -> Bool+isFinitePositiveHole pair = isPositiveHole pair && maybe False (> persistenceBirth pair) (persistenceDeath pair)++isEssentialHole :: PersistencePair AlphaBirth -> Bool+isEssentialHole pair = persistenceDegree pair == HomologicalDegree 1 && persistenceDeath pair == Nothing++buildRoseMask :: Either PersistenceRoseError [MaskComponent]+buildRoseMask = do+  kernelPoints <- traverse (first RosePointInvalid . exactPointFromPoint) minkowskiKernel+  kernel <- first RoseMinkowskiFailed (convexPolygon kernelPoints >>= structuringElement)+  authoredRegions <- traverse authoredRegion roseMaskLoops+  offsetRegions <-+    traverse+      (fmap fst . first RoseMinkowskiFailed . polygonOffset kernel)+      authoredRegions+  unioned <-+    case NonEmpty.nonEmpty offsetRegions of+      Nothing -> Left RoseNoMaskRegions+      Just (firstRegion :| remainingRegions) -> foldM exactRegionUnion firstRegion remainingRegions+  traverse projectMaskComponent (planarRegionComponents unioned)++authoredRegion :: NonEmpty Point -> Either PersistenceRoseError PlanarRegion+authoredRegion points = do+  exactPoints <- traverse (first RosePointInvalid . exactPointFromPoint) points+  loop <- first RoseRegionInvalid (exactLoop exactPoints)+  component <- first RoseRegionInvalid (polygonComponent loop [])+  first RoseRegionInvalid (planarRegion [component])++exactRegionUnion :: PlanarRegion -> PlanarRegion -> Either PersistenceRoseError PlanarRegion+exactRegionUnion leftRegion rightRegion = do+  leftLayer <- first RoseRegionInvalid (planarLayer False (Map.singleton True leftRegion))+  rightLayer <- first RoseRegionInvalid (planarLayer False (Map.singleton True rightRegion))+  overlaid <- first RoseOverlayFailed (overlayLayers leftLayer rightLayer)+  first RoseOverlayPublicationFailed (overlaySelectedRegion (uncurry (||)) overlaid)++projectMaskComponent :: PolygonComponent -> Either PersistenceRoseError MaskComponent+projectMaskComponent component =+  MaskComponent+    <$> projectExactLoop (polygonOuterLoop component)+    <*> traverse projectExactLoop (polygonHoleLoops component)++projectExactLoop :: ExactLoop -> Either PersistenceRoseError [Point]+projectExactLoop =+  traverse+    (fmap queryPointValue . first RosePointInvalid . exactPointToEmbeddingCandidate)+    . NonEmpty.toList+    . exactLoopPoints++roseSites :: [Point]+roseSites =+  concatMap petalSites [0 .. rosePetalCount - 1]+    <> centerSites++petalSites :: Int -> [Point]+petalSites petalIndex =+  fmap+    (petalPoint petalIndex 2.52 1.82 0.69)+    (sampleAngles 22 (0.021 * fromIntegral petalIndex))++centerSites :: [Point]+centerSites =+  Point 0 0+    : fmap+      (\angle -> Point (0.56 * cos angle) (0.56 * sin angle))+      (sampleAngles 14 0.037)++roseMaskLoops :: [NonEmpty Point]+roseMaskLoops =+  fmap+    (\petalIndex -> fmap (petalPoint petalIndex 2.42 2.12 0.9) (sampleAnglesNonEmpty 34 0))+    [0 .. rosePetalCount - 1]+    <> [fmap (\angle -> Point (1.08 * cos angle) (1.08 * sin angle)) (sampleAnglesNonEmpty 30 0)]++petalPoint :: Int -> Double -> Double -> Double -> Double -> Point+petalPoint petalIndex centerRadius radialRadius tangentialRadius localAngle =+  let orientation = twoPi * fromIntegral petalIndex / fromIntegral rosePetalCount - pi / 2+      radial = centerRadius + radialRadius * cos localAngle+      tangential = tangentialRadius * sin localAngle * (0.91 + 0.09 * cos (2 * localAngle))+      radialX = cos orientation+      radialY = sin orientation+      tangentX = -radialY+      tangentY = radialX+   in Point+        (radial * radialX + tangential * tangentX)+        (radial * radialY + tangential * tangentY)++sampleAngles :: Int -> Double -> [Double]+sampleAngles sampleCount phase =+  fmap+    (\sampleIndex -> twoPi * fromIntegral sampleIndex / fromIntegral sampleCount + phase)+    [0 .. sampleCount - 1]++sampleAnglesNonEmpty :: Int -> Double -> NonEmpty Double+sampleAnglesNonEmpty sampleCount phase =+  phase+    :| fmap+      (\sampleIndex -> twoPi * fromIntegral sampleIndex / fromIntegral sampleCount + phase)+      [1 .. max 1 sampleCount - 1]++minkowskiKernel :: NonEmpty Point+minkowskiKernel =+  Point 0.085 0+    :| [ Point 0.043 0.074,+         Point (-0.043) 0.074,+         Point (-0.085) 0,+         Point (-0.043) (-0.074),+         Point 0.043 (-0.074)+       ]++rosePetalCount :: Int+rosePetalCount = 7++-- | The package's canonical exact persistence witness. Its four hull edges+-- enter at squared radius one; the resident diagonal and two resident faces+-- enter at squared radius two. Homology therefore observes exactly one finite+-- degree-one interval @[1,2)@ over this fixed DCEL.+alphaEclipseSites :: [Point]+alphaEclipseSites =+  [ Point (-1) (-1),+    Point 1 (-1),+    Point 1 1,+    Point (-1) 1+  ]++renderPersistenceRosePoster :: PersistenceRoseScene -> String+renderPersistenceRosePoster scene =+  renderScene scene (criticalRank (sceneHeroState scene)) 1 True++renderAlphaEclipse :: AlphaEclipseScene -> String+renderAlphaEclipse scene =+  let receipt = eclipseReceipt scene+      birthLabel =+        renderExactRatio+          (eclipseHoleBirthNumerator receipt)+          (eclipseHoleBirthDenominator receipt)+      deathLabel =+        renderExactRatio+          (eclipseHoleDeathNumerator receipt)+          (eclipseHoleDeathDenominator receipt)+   in concat+        [ "<svg xmlns=\"http://www.w3.org/2000/svg\" viewBox=\"0 0 1440 620\" width=\"1440\" height=\"620\" role=\"img\" aria-labelledby=\"title description\">\n",+          "<title id=\"title\">Moonlight Triangulation alpha eclipse</title>\n",+          "<desc id=\"description\">One fixed four-site Delaunay DCEL at three exact alpha sublevels. Its resident boundary creates one hole at squared radius ",+          birthLabel,+          ", and its resident diagonal and faces kill that hole at squared radius ",+          deathLabel,+          ".</desc>\n",+          renderAlphaEclipseDefinitions,+          "<rect width=\"1440\" height=\"620\" fill=\"url(#eclipse-background)\"/>\n",+          "<circle cx=\"720\" cy=\"300\" r=\"246\" fill=\"#ff68bb\" opacity=\"0.035\" filter=\"url(#eclipse-soft-glow)\"/>\n",+          "<text x=\"58\" y=\"58\" fill=\"#84f3ff\" font-family=\"Inter,ui-sans-serif,system-ui,sans-serif\" font-size=\"17\" font-weight=\"600\" letter-spacing=\"6\">MOONLIGHT TRIANGULATION</text>\n",+          "<text x=\"58\" y=\"101\" fill=\"#f7f3ff\" font-family=\"Inter,ui-sans-serif,system-ui,sans-serif\" font-size=\"38\" font-weight=\"420\">ALPHA ECLIPSE</text>\n",+          "<text x=\"1382\" y=\"61\" text-anchor=\"end\" fill=\"#9baedb\" font-family=\"Inter,ui-sans-serif,system-ui,sans-serif\" font-size=\"14\" letter-spacing=\"1.5\">ONE FIXED DELAUNAY DCEL · EXACT CRITICAL BIRTHS</text>\n",+          renderAlphaEclipseStage+            scene+            245+            "BEFORE BIRTH"+            "four isolated sites"+            (eclipseBeforeState scene),+          renderAlphaEclipseStage+            scene+            720+            "LOOP BORN"+            "resident boundary closes"+            (eclipseBirthState scene),+          renderAlphaEclipseStage+            scene+            1195+            "CYCLE KILLED"+            "resident faces fill it"+            (eclipseDeathState scene),+          "<g font-family=\"Inter,ui-sans-serif,system-ui,sans-serif\">\n",+          "<text x=\"58\" y=\"516\" fill=\"#9badd8\" font-size=\"13\" letter-spacing=\"2.5\">ONE EXACT H₁ INTERVAL</text>\n",+          "<line x1=\"58\" y1=\"559\" x2=\"1382\" y2=\"559\" stroke=\"#344070\" stroke-width=\"3\"/>\n",+          "<line x1=\"535\" y1=\"559\" x2=\"1042\" y2=\"559\" stroke=\"#ff72c6\" stroke-width=\"9\" stroke-linecap=\"round\"/>\n",+          "<circle cx=\"535\" cy=\"559\" r=\"8\" fill=\"#fff6d6\" stroke=\"#ff72c6\" stroke-width=\"3\"/>\n",+          "<rect x=\"1034\" y=\"551\" width=\"16\" height=\"16\" fill=\"#fff6d6\" stroke=\"#66efff\" stroke-width=\"3\"/>\n",+          "<text x=\"58\" y=\"589\" fill=\"#7588ba\" font-size=\"12\">α² = 0</text>\n",+          "<text x=\"535\" y=\"589\" text-anchor=\"middle\" fill=\"#f7f3ff\" font-size=\"12\">birth α² = ",+          birthLabel,+          "</text>\n",+          "<text x=\"788\" y=\"548\" text-anchor=\"middle\" fill=\"#fff6d6\" font-size=\"14\">the eclipse hole persists</text>\n",+          "<text x=\"1042\" y=\"589\" text-anchor=\"middle\" fill=\"#f7f3ff\" font-size=\"12\">death α² = ",+          deathLabel,+          "</text>\n",+          "<text x=\"1382\" y=\"589\" text-anchor=\"end\" fill=\"#7588ba\" font-size=\"12\">exact α² increases →</text>\n",+          "</g>\n",+          "</svg>\n"+        ]++renderAlphaEclipseDefinitions :: String+renderAlphaEclipseDefinitions =+  concat+    [ "<defs>\n",+      "<radialGradient id=\"eclipse-background\" cx=\"50%\" cy=\"38%\" r=\"78%\"><stop offset=\"0\" stop-color=\"#111744\"/><stop offset=\"0.55\" stop-color=\"#070b25\"/><stop offset=\"1\" stop-color=\"#02040f\"/></radialGradient>\n",+      "<linearGradient id=\"eclipse-corona\" x1=\"0\" y1=\"0\" x2=\"1\" y2=\"1\"><stop offset=\"0\" stop-color=\"#66efff\"/><stop offset=\"0.48\" stop-color=\"#ff72c6\"/><stop offset=\"1\" stop-color=\"#ffd86b\"/></linearGradient>\n",+      "<linearGradient id=\"eclipse-face\" x1=\"0\" y1=\"0\" x2=\"1\" y2=\"1\"><stop offset=\"0\" stop-color=\"#7c4dff\"/><stop offset=\"0.5\" stop-color=\"#ff4fa3\"/><stop offset=\"1\" stop-color=\"#ffbf5b\"/></linearGradient>\n",+      "<filter id=\"eclipse-soft-glow\" x=\"-30%\" y=\"-30%\" width=\"160%\" height=\"160%\"><feGaussianBlur stdDeviation=\"7\" result=\"blur\"/><feMerge><feMergeNode in=\"blur\"/><feMergeNode in=\"SourceGraphic\"/></feMerge></filter>\n",+      "<filter id=\"eclipse-dot-glow\" x=\"-100%\" y=\"-100%\" width=\"300%\" height=\"300%\"><feGaussianBlur stdDeviation=\"3\" result=\"blur\"/><feMerge><feMergeNode in=\"blur\"/><feMergeNode in=\"SourceGraphic\"/></feMerge></filter>\n",+      "</defs>\n"+    ]++renderAlphaEclipseStage+  :: AlphaEclipseScene+  -> Double+  -> String+  -> String+  -> CriticalState+  -> String+renderAlphaEclipseStage scene centerX stageLabel explanation state =+  let rankValue = criticalRank state+      activeFaces = filter ((<= rankValue) . rankedTriangleBirthRank) (eclipseFaces scene)+      activeEdges = filter ((<= rankValue) . rankedSegmentBirthRank) (eclipseEdges scene)+      highlighted = criticalBettiOne state > 0+      frameStroke = if highlighted then "#ff6fbd" else "#344070"+      frameOpacity = if highlighted then "0.72" else "0.55"+   in concat+        [ "<g transform=\"translate(",+          formatDouble centerX,+          " 292)\">\n",+          "<rect x=\"-194\" y=\"-150\" width=\"388\" height=\"292\" rx=\"28\" fill=\"#090d26\" fill-opacity=\"0.72\" stroke=\"",+          frameStroke,+          "\" stroke-opacity=\"",+          frameOpacity,+          "\"/>\n",+          "<text x=\"-162\" y=\"-114\" fill=\"",+          if highlighted then "#ff89cb" else "#8fa4d6",+          "\" font-family=\"Inter,ui-sans-serif,system-ui,sans-serif\" font-size=\"13\" letter-spacing=\"2.4\">",+          stageLabel,+          "</text>\n",+          "<circle r=\"104\" fill=\"#01020a\" stroke=\"#7fefff\" stroke-opacity=\"0.18\" stroke-width=\"2\"/>\n",+          "<g fill=\"url(#eclipse-face)\" fill-opacity=\"0.58\" stroke=\"#ffd56d\" stroke-opacity=\"0.48\" stroke-width=\"1.2\">",+          concatMap renderAlphaEclipseTriangle activeFaces,+          "</g>\n",+          "<g fill=\"none\" stroke=\"url(#eclipse-corona)\" stroke-width=\"5\" stroke-linejoin=\"round\" stroke-linecap=\"round\" filter=\"url(#eclipse-soft-glow)\">",+          concatMap renderAlphaEclipseSegment activeEdges,+          "</g>\n",+          "<g fill=\"none\" stroke=\"#fff7da\" stroke-width=\"3.2\" stroke-linejoin=\"round\" opacity=\"0.86\">",+          concatMap renderAlphaEclipseHole (criticalHoles state),+          "</g>\n",+          "<g fill=\"#fff8df\" stroke=\"#ff75c5\" stroke-width=\"2\" filter=\"url(#eclipse-dot-glow)\">",+          concatMap renderAlphaEclipseSite (eclipseSites scene),+          "</g>\n",+          "<rect x=\"-126\" y=\"-18\" width=\"252\" height=\"36\" rx=\"18\" fill=\"#05071a\" fill-opacity=\"0.82\"/>\n",+          "<text y=\"5\" text-anchor=\"middle\" fill=\"#fff7da\" font-family=\"Inter,ui-sans-serif,system-ui,sans-serif\" font-size=\"14\" letter-spacing=\"1.2\">",+          explanation,+          "</text>\n",+          "<text x=\"-162\" y=\"121\" fill=\"#fff4cc\" font-family=\"Inter,ui-sans-serif,system-ui,sans-serif\" font-size=\"25\">β₁ = ",+          show (criticalBettiOne state),+          "</text>\n",+          "<text x=\"162\" y=\"121\" text-anchor=\"end\" fill=\"#8495c4\" font-family=\"Inter,ui-sans-serif,system-ui,sans-serif\" font-size=\"12\">α² = ",+          renderAlphaBirth (criticalBirth state),+          "</text>\n",+          "</g>\n"+        ]++renderAlphaEclipseTriangle :: RankedTriangle -> String+renderAlphaEclipseTriangle RankedTriangle{rankedTrianglePoints = (firstPoint, secondPoint, thirdPoint)} =+  "<polygon points=\""+    <> renderScreenPoints (fmap toAlphaEclipseLocal [firstPoint, secondPoint, thirdPoint])+    <> "\"/>\n"++renderAlphaEclipseSegment :: RankedSegment -> String+renderAlphaEclipseSegment RankedSegment{rankedSegmentGeometry = Segment firstPoint secondPoint} =+  let Point firstX firstY = toAlphaEclipseLocal firstPoint+      Point secondX secondY = toAlphaEclipseLocal secondPoint+   in "<line x1=\""+        <> formatDouble firstX+        <> "\" y1=\""+        <> formatDouble firstY+        <> "\" x2=\""+        <> formatDouble secondX+        <> "\" y2=\""+        <> formatDouble secondY+        <> "\"/>\n"++renderAlphaEclipseHole :: HoleComponent -> String+renderAlphaEclipseHole (HoleComponent loops) =+  concatMap+    (\points -> "<path d=\"" <> renderClosedPath (fmap toAlphaEclipseLocal points) <> "\"/>\n")+    loops++renderAlphaEclipseSite :: Point -> String+renderAlphaEclipseSite point =+  let Point x y = toAlphaEclipseLocal point+   in "<circle cx=\""+        <> formatDouble x+        <> "\" cy=\""+        <> formatDouble y+        <> "\" r=\"6\"/>\n"++toAlphaEclipseLocal :: Point -> Point+toAlphaEclipseLocal (Point x y) =+  let scale = 72+      inverseSquareRootTwo = sqrt 0.5+   in Point+        (scale * inverseSquareRootTwo * (x - y))+        (scale * inverseSquareRootTwo * (x + y))++renderAlphaBirth :: AlphaBirth -> String+renderAlphaBirth birth =+  renderExactRatio (alphaBirthNumerator birth) (alphaBirthDenominator birth)++renderExactRatio :: Integer -> Integer -> String+renderExactRatio numerator denominator+  | denominator == 1 = show numerator+  | otherwise = show numerator <> "/" <> show denominator++persistenceRoseFrameSpecs :: Int -> Either PersistenceRoseError [PersistenceRoseFrame]+persistenceRoseFrameSpecs frameCount+  | frameCount < 2 = Left (RoseFrameCountTooSmall frameCount)+  | otherwise =+      Right+        ( fmap+            (\frameIndex ->+               PersistenceRoseFrame+                 { frameProgress = frameProgressAt frameCount frameIndex+                 })+            [0 .. frameCount - 1]+        )++renderPersistenceRoseFrame :: PersistenceRoseScene -> PersistenceRoseFrame -> String+renderPersistenceRoseFrame scene frame =+  let finalRank = criticalRank (NonEmpty.last (sceneCriticalStates scene))+      selectedRank = clampInt 0 finalRank (floor (frameProgress frame * fromIntegral finalRank))+   in renderScene scene selectedRank (frameProgress frame) False++persistenceRoseAnimationReceipt+  :: PersistenceRoseScene+  -> Either PersistenceRoseError PersistenceRoseAnimationReceipt+persistenceRoseAnimationReceipt scene = do+  frames <- persistenceRoseFrameSpecs canonicalAnimationFrameCount+  let renderedFrames = fmap (renderPersistenceRoseFrame scene) frames+  pure+    PersistenceRoseAnimationReceipt+      { roseAnimationFrameCount = canonicalAnimationFrameCount,+        roseAnimationFramesPerSecond = canonicalAnimationFramesPerSecond,+        roseAnimationWidth = canonicalAnimationWidth,+        roseAnimationHeight = canonicalAnimationHeight,+        roseAnimationSourceFingerprint = fingerprintSections renderedFrames+      }++renderPersistenceRoseAnimationReceipt :: PersistenceRoseAnimationReceipt -> String+renderPersistenceRoseAnimationReceipt receipt =+  intercalate+    " "+    [ "MOONLIGHT_PERSISTENCE_ROSE",+      "frame-count=" <> show (roseAnimationFrameCount receipt),+      "fps=" <> show (roseAnimationFramesPerSecond receipt),+      "size=" <> show (roseAnimationWidth receipt) <> "x" <> show (roseAnimationHeight receipt),+      "source-fnv1a64=" <> renderWord64Hex (roseAnimationSourceFingerprint receipt)+    ]++stampPersistenceRoseGif+  :: PersistenceRoseScene+  -> ByteString+  -> Either PersistenceRoseError (PersistenceRoseAnimationReceipt, ByteString)+stampPersistenceRoseGif scene gifBytes = do+  receipt <- persistenceRoseAnimationReceipt scene+  summary <- inspectGif gifBytes+  validateGifSummary receipt summary+  let marker = ByteString.Char8.pack (renderPersistenceRoseAnimationReceipt receipt)+      markerLength = ByteString.length marker+  if markerLength > 255+    then Left (RoseGifMarkerTooLong markerLength)+    else+      if marker `ByteString.isInfixOf` gifBytes+        then Right (receipt, gifBytes)+        else+          if gifMarkerPrefix `ByteString.isInfixOf` gifBytes+            then Left RoseGifProvenanceMismatch+            else do+              insertionOffset <- gifDataStart gifBytes+              let (prefix, suffix) = ByteString.splitAt insertionOffset gifBytes+                  commentExtension =+                    ByteString.pack [0x21, 0xfe, fromIntegral markerLength]+                      <> marker+                      <> ByteString.singleton 0+              pure (receipt, prefix <> commentExtension <> suffix)++verifyPersistenceRoseGif+  :: PersistenceRoseScene+  -> ByteString+  -> Either PersistenceRoseError PersistenceRoseAnimationReceipt+verifyPersistenceRoseGif scene gifBytes = do+  receipt <- persistenceRoseAnimationReceipt scene+  summary <- inspectGif gifBytes+  validateGifSummary receipt summary+  let marker = ByteString.Char8.pack (renderPersistenceRoseAnimationReceipt receipt)+  if marker `ByteString.isInfixOf` gifBytes+    then Right receipt+    else Left RoseGifProvenanceMismatch++data GifSummary = GifSummary+  { gifSummaryWidth :: !Int,+    gifSummaryHeight :: !Int,+    gifSummaryFrameCount :: !Int,+    gifSummaryFrameDelayCount :: !Int,+    gifSummaryDurationCentiseconds :: !Int+  }++inspectGif :: ByteString -> Either PersistenceRoseError GifSummary+inspectGif gifBytes = do+  dataStart <- gifDataStart gifBytes+  width <- gifLittleEndianWord16 gifBytes 6+  height <- gifLittleEndianWord16 gifBytes 8+  (frameCount, frameDelayCount, durationCentiseconds) <-+    countGifFrames gifBytes dataStart 0 0 0+  pure+    GifSummary+      { gifSummaryWidth = width,+        gifSummaryHeight = height,+        gifSummaryFrameCount = frameCount,+        gifSummaryFrameDelayCount = frameDelayCount,+        gifSummaryDurationCentiseconds = durationCentiseconds+      }++gifDataStart :: ByteString -> Either PersistenceRoseError Int+gifDataStart gifBytes = do+  signature <- maybe (Left (RoseGifTruncated 0)) Right (gifSlice gifBytes 0 6)+  if signature == ByteString.Char8.pack "GIF87a" || signature == ByteString.Char8.pack "GIF89a"+    then pure ()+    else Left RoseGifInvalidSignature+  packed <- maybe (Left (RoseGifTruncated 10)) Right (gifByteAt gifBytes 10)+  let globalColourTableBytes =+        if packed .&. 0x80 == 0+          then 0+          else 3 * (2 ^ (fromIntegral (packed .&. 0x07) + 1 :: Int))+      dataStart = 13 + globalColourTableBytes+  maybe (Left (RoseGifTruncated dataStart)) (const (Right dataStart)) (gifSlice gifBytes 0 dataStart)++countGifFrames+  :: ByteString+  -> Int+  -> Int+  -> Int+  -> Int+  -> Either PersistenceRoseError (Int, Int, Int)+countGifFrames gifBytes offset frameCount frameDelayCount durationCentiseconds = do+  block <- maybe (Left (RoseGifTruncated offset)) Right (gifByteAt gifBytes offset)+  case block of+    0x3b -> Right (frameCount, frameDelayCount, durationCentiseconds)+    0x21 -> do+      extensionLabel <- maybe (Left (RoseGifTruncated (offset + 1))) Right (gifByteAt gifBytes (offset + 1))+      nextOffset <- skipGifSubBlocks gifBytes (offset + 2)+      if extensionLabel == 0xf9+        then do+          delay <- gifLittleEndianWord16 gifBytes (offset + 4)+          countGifFrames+            gifBytes+            nextOffset+            frameCount+            (frameDelayCount + 1)+            (durationCentiseconds + delay)+        else+          countGifFrames+            gifBytes+            nextOffset+            frameCount+            frameDelayCount+            durationCentiseconds+    0x2c -> do+      packed <- maybe (Left (RoseGifTruncated (offset + 9))) Right (gifByteAt gifBytes (offset + 9))+      let localColourTableBytes =+            if packed .&. 0x80 == 0+              then 0+              else 3 * (2 ^ (fromIntegral (packed .&. 0x07) + 1 :: Int))+          imageDataStart = offset + 11 + localColourTableBytes+      maybe (Left (RoseGifTruncated imageDataStart)) (const (Right ())) (gifByteAt gifBytes (imageDataStart - 1))+      skipGifSubBlocks gifBytes imageDataStart >>= \next ->+        countGifFrames+          gifBytes+          next+          (frameCount + 1)+          frameDelayCount+          durationCentiseconds+    0x00 ->+      countGifFrames+        gifBytes+        (offset + 1)+        frameCount+        frameDelayCount+        durationCentiseconds+    unexpected -> Left (RoseGifUnexpectedBlock offset unexpected)++skipGifSubBlocks :: ByteString -> Int -> Either PersistenceRoseError Int+skipGifSubBlocks gifBytes offset = do+  blockLength <- maybe (Left (RoseGifTruncated offset)) (Right . fromIntegral) (gifByteAt gifBytes offset)+  if blockLength == 0+    then Right (offset + 1)+    else do+      let nextOffset = offset + 1 + blockLength+      maybe (Left (RoseGifTruncated nextOffset)) (const (Right ())) (gifSlice gifBytes offset (1 + blockLength))+      skipGifSubBlocks gifBytes nextOffset++validateGifSummary+  :: PersistenceRoseAnimationReceipt+  -> GifSummary+  -> Either PersistenceRoseError ()+validateGifSummary receipt summary+  | actualWidth /= expectedWidth || actualHeight /= expectedHeight =+      Left (RoseGifDimensionMismatch expectedWidth expectedHeight actualWidth actualHeight)+  | actualFrameCount /= expectedFrameCount =+      Left (RoseGifFrameCountMismatch expectedFrameCount actualFrameCount)+  | actualFrameDelayCount /= expectedFrameCount =+      Left (RoseGifFrameDelayCountMismatch expectedFrameCount actualFrameDelayCount)+  | actualDurationCentiseconds /= canonicalAnimationDurationCentiseconds =+      Left+        ( RoseGifDurationMismatch+            canonicalAnimationDurationCentiseconds+            actualDurationCentiseconds+        )+  | otherwise = Right ()+ where+  expectedWidth = roseAnimationWidth receipt+  expectedHeight = roseAnimationHeight receipt+  actualWidth = gifSummaryWidth summary+  actualHeight = gifSummaryHeight summary+  expectedFrameCount = roseAnimationFrameCount receipt+  actualFrameCount = gifSummaryFrameCount summary+  actualFrameDelayCount = gifSummaryFrameDelayCount summary+  actualDurationCentiseconds = gifSummaryDurationCentiseconds summary++gifLittleEndianWord16 :: ByteString -> Int -> Either PersistenceRoseError Int+gifLittleEndianWord16 gifBytes offset = do+  low <- maybe (Left (RoseGifTruncated offset)) (Right . fromIntegral) (gifByteAt gifBytes offset)+  high <- maybe (Left (RoseGifTruncated (offset + 1))) (Right . fromIntegral) (gifByteAt gifBytes (offset + 1))+  pure (low + 256 * high)++gifByteAt :: ByteString -> Int -> Maybe Word8+gifByteAt gifBytes offset = fst <$> ByteString.uncons (ByteString.drop offset gifBytes)++gifSlice :: ByteString -> Int -> Int -> Maybe ByteString+gifSlice gifBytes offset width =+  let selected = ByteString.take width (ByteString.drop offset gifBytes)+   in if ByteString.length selected == width then Just selected else Nothing++fingerprintSections :: [String] -> Word64+fingerprintSections =+  foldl'+    (\fingerprint section -> fingerprintByte (fingerprintText fingerprint section) 0)+    fnvOffsetBasis++fingerprintText :: Word64 -> String -> Word64+fingerprintText fingerprint =+  ByteString.foldl' fingerprintByte fingerprint+    . Text.Encoding.encodeUtf8+    . Text.pack++fingerprintByte :: Word64 -> Word8 -> Word64+fingerprintByte fingerprint byte =+  (fingerprint `xor` fromIntegral byte) * fnvPrime++renderWord64Hex :: Word64 -> String+renderWord64Hex value =+  let rendered = showHex value ""+   in replicate (16 - length rendered) '0' <> rendered++gifMarkerPrefix :: ByteString+gifMarkerPrefix = ByteString.Char8.pack "MOONLIGHT_PERSISTENCE_ROSE "++canonicalAnimationFrameCount :: Int+canonicalAnimationFrameCount = 65++canonicalAnimationFramesPerSecond :: Int+canonicalAnimationFramesPerSecond = 8++canonicalAnimationWidth :: Int+canonicalAnimationWidth = 960++canonicalAnimationHeight :: Int+canonicalAnimationHeight = 540++canonicalAnimationDurationCentiseconds :: Int+canonicalAnimationDurationCentiseconds = 813++fnvOffsetBasis :: Word64+fnvOffsetBasis = 14695981039346656037++fnvPrime :: Word64+fnvPrime = 1099511628211++frameProgressAt :: Int -> Int -> Double+frameProgressAt frameCount frameIndex+  | frameIndex <= 0 || frameIndex >= frameCount - 1 = 0+  | otherwise =+      let phase = fromIntegral frameIndex / fromIntegral (frameCount - 1)+       in 0.5 - 0.5 * cos (twoPi * phase)++renderScene :: PersistenceRoseScene -> Int -> Double -> Bool -> String+renderScene scene selectedRank progress poster =+  let selectedState = criticalStateAt selectedRank (sceneCriticalStates scene)+      finalRank = max 1 (criticalRank (NonEmpty.last (sceneCriticalStates scene)))+      activation = if poster then fromIntegral selectedRank / fromIntegral finalRank else progress+   in concat+        [ "<svg xmlns=\"http://www.w3.org/2000/svg\" viewBox=\"0 0 1920 1080\" width=\"1920\" height=\"1080\" role=\"img\" aria-labelledby=\"title description\">\n",+          "<title id=\"title\">Moonlight Triangulation Persistence Rose</title>\n",+          "<desc id=\"description\">Exact Delaunay alpha filtration, persistent homology, Voronoi dual, Sibson interpolation, exact overlay, and Minkowski morphology composed into a seven-petal rose.</desc>\n",+          renderDefinitions (sceneMaskComponents scene),+          "<rect width=\"1920\" height=\"1080\" fill=\"url(#background)\"/>\n",+          renderAmbientOrbits activation,+          renderPersistenceHalo finalRank selectedRank (scenePersistenceArcs scene),+          "<g clip-path=\"url(#rose-clip)\">\n",+          "<path d=\"", renderMaskPath (sceneMaskComponents scene), "\" fill=\"url(#rose-wash)\" opacity=\"0.28\"/>\n",+          "<g filter=\"url(#field-soften)\">", concatMap renderFieldSample (sceneFieldSamples scene), "</g>\n",+          "<g opacity=\"0.58\">", concatMap renderVoronoiSegment (sceneVoronoiSegments scene), "</g>\n",+          concatMap (renderRankedTriangle finalRank activation) (sceneFaces scene),+          concatMap (renderRankedSegment finalRank activation) (sceneEdges scene),+          "<g filter=\"url(#hole-glow)\">", concatMap renderHoleComponent (criticalHoles selectedState), "</g>\n",+          concatMap (renderSite activation) (sceneSites scene),+          "</g>\n",+          "<path d=\"", renderMaskPath (sceneMaskComponents scene), "\" fill=\"none\" stroke=\"url(#mask-stroke)\" stroke-width=\"2.2\" opacity=\"0.92\" filter=\"url(#edge-glow)\"/>\n",+          renderTitle selectedState,+          "</svg>\n"+        ]++criticalStateAt :: Int -> NonEmpty CriticalState -> CriticalState+criticalStateAt target (firstState :| remainingStates) =+  foldl'+    (\chosen candidate -> if criticalRank candidate <= target then candidate else chosen)+    firstState+    remainingStates++renderDefinitions :: [MaskComponent] -> String+renderDefinitions maskComponents =+  concat+    [ "<defs>\n",+      "<radialGradient id=\"background\" cx=\"52%\" cy=\"48%\" r=\"72%\"><stop offset=\"0\" stop-color=\"#10143d\"/><stop offset=\"0.48\" stop-color=\"#070b24\"/><stop offset=\"1\" stop-color=\"#02040e\"/></radialGradient>\n",+      "<radialGradient id=\"rose-wash\" cx=\"48%\" cy=\"42%\" r=\"63%\"><stop offset=\"0\" stop-color=\"#ffe7a3\"/><stop offset=\"0.38\" stop-color=\"#ff5fb7\"/><stop offset=\"0.72\" stop-color=\"#7c4dff\"/><stop offset=\"1\" stop-color=\"#00d9ff\"/></radialGradient>\n",+      "<linearGradient id=\"mask-stroke\" x1=\"0\" y1=\"0\" x2=\"1\" y2=\"1\"><stop offset=\"0\" stop-color=\"#ffd86b\"/><stop offset=\"0.48\" stop-color=\"#ff72c6\"/><stop offset=\"1\" stop-color=\"#66efff\"/></linearGradient>\n",+      "<linearGradient id=\"hole-stroke\" x1=\"0\" y1=\"0\" x2=\"1\" y2=\"1\"><stop offset=\"0\" stop-color=\"#fff9db\"/><stop offset=\"0.52\" stop-color=\"#ff9ad7\"/><stop offset=\"1\" stop-color=\"#9ff7ff\"/></linearGradient>\n",+      "<filter id=\"field-soften\" x=\"-20%\" y=\"-20%\" width=\"140%\" height=\"140%\"><feGaussianBlur stdDeviation=\"24\"/></filter>\n",+      "<filter id=\"hole-glow\" x=\"-30%\" y=\"-30%\" width=\"160%\" height=\"160%\"><feGaussianBlur stdDeviation=\"7\" result=\"b\"/><feMerge><feMergeNode in=\"b\"/><feMergeNode in=\"SourceGraphic\"/></feMerge></filter>\n",+      "<filter id=\"edge-glow\" x=\"-20%\" y=\"-20%\" width=\"140%\" height=\"140%\"><feGaussianBlur stdDeviation=\"3\" result=\"b\"/><feMerge><feMergeNode in=\"b\"/><feMergeNode in=\"SourceGraphic\"/></feMerge></filter>\n",+      "<clipPath id=\"rose-clip\"><path d=\"",+      renderMaskPath maskComponents,+      "\" fill-rule=\"evenodd\"/></clipPath>\n",+      "</defs>\n"+    ]++renderAmbientOrbits :: Double -> String+renderAmbientOrbits activation =+  concatMap+    ( \orbit ->+        let radius = 322 + fromIntegral orbit * 34+            opacity = 0.055 + activation * 0.025+         in "<circle cx=\"960\" cy=\"552\" r=\""+              <> formatDouble radius+              <> "\" fill=\"none\" stroke=\"#8ba5ff\" stroke-width=\"0.8\" stroke-dasharray=\"2 12\" opacity=\""+              <> formatDouble opacity+              <> "\"/>\n"+    )+    [0 .. 5 :: Int]++renderPersistenceHalo :: Int -> Int -> [PersistenceArc] -> String+renderPersistenceHalo finalRank selectedRank arcs =+  "<g fill=\"none\" stroke-linecap=\"round\">\n"+    <> concatMap renderArc (zip ([0 :: Int ..]) arcs)+    <> "</g>\n"+ where+  renderArc :: (Int, PersistenceArc) -> String+  renderArc (index, arc) =+    let active = persistenceArcBirthRank arc <= selectedRank && selectedRank < persistenceArcDeathRank arc+        radius = 414 + fromIntegral (index `mod` 7) * 7.5+        start = rankAngle finalRank (persistenceArcBirthRank arc)+        finish = rankAngle finalRank (persistenceArcDeathRank arc)+        points = arcPolyline radius start finish 42+        hue = 188 + (index * 17 `mod` 122)+        opacity = if active then 0.72 else 0.16+        width = if active then 2.6 else 1.1+     in "<polyline points=\""+          <> renderScreenPoints points+          <> "\" stroke=\"hsl("+          <> show hue+          <> " 92% 72%)\" stroke-width=\""+          <> formatDouble width+          <> "\" opacity=\""+          <> formatDouble opacity+          <> "\"/>\n"++rankAngle :: Int -> Int -> Double+rankAngle finalRank rankValue =+  -pi / 2 + twoPi * fromIntegral rankValue / fromIntegral (max 1 finalRank)++arcPolyline :: Double -> Double -> Double -> Int -> [Point]+arcPolyline radius start finish sampleCount =+  fmap+    ( \sampleIndex ->+        let fraction = fromIntegral sampleIndex / fromIntegral sampleCount+            angle = start + fraction * (finish - start)+         in screenPointFromPolar radius angle+    )+    [0 .. sampleCount]++screenPointFromPolar :: Double -> Double -> Point+screenPointFromPolar radius angle =+  Point (960 + radius * cos angle) (552 + radius * sin angle)++renderFieldSample :: FieldSample -> String+renderFieldSample FieldSample{fieldSamplePoint, fieldSampleValue, fieldSampleNeighborCount} =+  let Point x y = toScreen fieldSamplePoint+      hue = round (186 + 126 * fieldSampleValue) :: Int+      radius = 30 + min 5 (fromIntegral fieldSampleNeighborCount)+      opacity = 0.16 + 0.16 * fieldSampleValue+   in "<circle cx=\""+        <> formatDouble x+        <> "\" cy=\""+        <> formatDouble y+        <> "\" r=\""+        <> formatDouble radius+        <> "\" fill=\"hsl("+        <> show hue+        <> " 94% 61%)\" opacity=\""+        <> formatDouble opacity+        <> "\"/>\n"++renderVoronoiSegment :: Segment -> String+renderVoronoiSegment segment =+  renderLine segment "#61efff" 1.15 0.5 ""++renderRankedTriangle :: Int -> Double -> RankedTriangle -> String+renderRankedTriangle finalRank activation RankedTriangle{rankedTrianglePoints = (firstPoint, secondPoint, thirdPoint), rankedTriangleBirthRank} =+  let opacity = activationOpacity finalRank activation rankedTriangleBirthRank+      hue :: Int+      hue = 282 - round (94 * fromIntegral rankedTriangleBirthRank / fromIntegral (max 1 finalRank) :: Double)+   in if opacity <= 0.001+        then ""+        else+          "<polygon points=\""+            <> renderWorldPoints [firstPoint, secondPoint, thirdPoint]+            <> "\" fill=\"hsl("+            <> show hue+            <> " 88% 60%)\" opacity=\""+            <> formatDouble (0.06 + 0.17 * opacity)+            <> "\"/>\n"++renderRankedSegment :: Int -> Double -> RankedSegment -> String+renderRankedSegment finalRank activation RankedSegment{rankedSegmentGeometry, rankedSegmentBirthRank} =+  let opacity = activationOpacity finalRank activation rankedSegmentBirthRank+      width = 0.75 + 1.25 * opacity+      color = if opacity > 0.72 then "#ffd56a" else "#dd78ff"+   in renderLine rankedSegmentGeometry color width (0.06 + 0.82 * opacity) "filter=\"url(#edge-glow)\""++activationOpacity :: Int -> Double -> Int -> Double+activationOpacity finalRank activation birthRank =+  let level = activation * fromIntegral finalRank+      distance = level - fromIntegral birthRank+   in smoothstep (distance + 0.6)++smoothstep :: Double -> Double+smoothstep value =+  let bounded = clamp 0 1 value+   in bounded * bounded * (3 - 2 * bounded)++renderHoleComponent :: HoleComponent -> String+renderHoleComponent (HoleComponent loops) =+  concatMap+    ( \points ->+        "<path d=\""+          <> renderClosedWorldPath points+          <> "\" fill=\"none\" stroke=\"url(#hole-stroke)\" stroke-width=\"5.4\" stroke-linejoin=\"round\" opacity=\"0.98\"/>\n"+    )+    loops++renderSite :: Double -> Point -> String+renderSite activation point =+  let Point x y = toScreen point+      radius = 2.5 + 1.5 * activation+   in "<circle cx=\""+        <> formatDouble x+        <> "\" cy=\""+        <> formatDouble y+        <> "\" r=\""+        <> formatDouble radius+        <> "\" fill=\"#fff8d9\" stroke=\"#ff9ad7\" stroke-width=\"1.2\" opacity=\"0.95\"/>\n"++renderLine :: Segment -> String -> Double -> Double -> String -> String+renderLine (Segment fromPoint toPoint) color width opacity extraAttributes =+  let Point fromX fromY = toScreen fromPoint+      Point toX toY = toScreen toPoint+   in "<line x1=\""+        <> formatDouble fromX+        <> "\" y1=\""+        <> formatDouble fromY+        <> "\" x2=\""+        <> formatDouble toX+        <> "\" y2=\""+        <> formatDouble toY+        <> "\" stroke=\""+        <> color+        <> "\" stroke-width=\""+        <> formatDouble width+        <> "\" stroke-linecap=\"round\" opacity=\""+        <> formatDouble opacity+        <> "\" "+        <> extraAttributes+        <> "/>\n"++renderTitle :: CriticalState -> String+renderTitle state =+  let alphaFraction = exactFractionSummary (criticalBirth state)+      alphaDecimal = formatDouble (alphaBirthToDouble (criticalBirth state))+      bettiMeaning = bettiOneMeaning (criticalBettiOne state)+   in concat+        [ "<g font-family=\"Inter, Avenir Next, Helvetica, Arial, sans-serif\" fill=\"#f7f3ff\">\n",+          "<text x=\"72\" y=\"82\" font-size=\"24\" font-weight=\"600\" letter-spacing=\"8\" fill=\"#9ff7ff\">MOONLIGHT TRIANGULATION</text>\n",+          "<text x=\"70\" y=\"145\" font-size=\"58\" font-weight=\"780\" letter-spacing=\"-1.5\">PERSISTENCE ROSE</text>\n",+          "<g transform=\"translate(1500 790)\">\n",+          "<text x=\"0\" y=\"0\" font-size=\"18\" letter-spacing=\"2.4\" fill=\"#91a8d8\">TOPOLOGICAL HOLES AT THIS SCALE</text>\n",+          "<text x=\"0\" y=\"74\" font-size=\"78\" font-weight=\"720\" fill=\"#fff5cd\">β₁ = ",+          show (criticalBettiOne state),+          "</text>\n",+          "<text x=\"2\" y=\"116\" font-size=\"17\" fill=\"#c9d3ff\">",+          bettiMeaning,+          "</text>\n",+          "<text x=\"2\" y=\"144\" font-size=\"15\" fill=\"#9ba8d4\">in the exact alpha complex</text>\n",+          "<text x=\"2\" y=\"176\" font-size=\"14\" fill=\"#7682aa\">critical rank ",+          show (criticalRank state),+          " · α² = ",+          alphaDecimal,+          "</text>\n",+          "<text x=\"2\" y=\"200\" font-size=\"12\" fill=\"#596486\">",+          alphaFraction,+          "</text>\n",+          "</g>\n",+          "</g>\n"+        ]++bettiOneMeaning :: Int -> String+bettiOneMeaning holeCount =+  case holeCount of+    0 -> "no independent one-dimensional holes"+    1 -> "1 independent one-dimensional hole"+    _ -> show holeCount <> " independent one-dimensional holes"++exactFractionSummary :: AlphaBirth -> String+exactFractionSummary birth =+  let numeratorDigits = length (show (abs (alphaBirthNumerator birth)))+      denominatorDigits = length (show (alphaBirthDenominator birth))+   in "exact " <> show numeratorDigits <> "-digit / " <> show denominatorDigits <> "-digit rational"++renderMaskPath :: [MaskComponent] -> String+renderMaskPath =+  intercalate " "+    . concatMap+      (\MaskComponent{maskOuterLoop, maskHoleLoops} -> renderClosedScreenPath maskOuterLoop : fmap renderClosedScreenPath maskHoleLoops)++renderClosedWorldPath :: [Point] -> String+renderClosedWorldPath = renderClosedPath . fmap toScreen++renderClosedScreenPath :: [Point] -> String+renderClosedScreenPath = renderClosedPath . fmap toScreen++renderClosedPath :: [Point] -> String+renderClosedPath points =+  case points of+    [] -> ""+    firstPoint : remainingPoints ->+      "M " <> renderPoint firstPoint <> concatMap (" L " <>) (fmap renderPoint remainingPoints) <> " Z"++renderWorldPoints :: [Point] -> String+renderWorldPoints = renderScreenPoints . fmap toScreen++renderScreenPoints :: [Point] -> String+renderScreenPoints = unwords . fmap renderPoint++renderPoint :: Point -> String+renderPoint (Point x y) = formatDouble x <> "," <> formatDouble y++toScreen :: Point -> Point+toScreen (Point x y) = Point (960 + x * 101) (552 + y * 101)++formatDouble :: Double -> String+formatDouble value = showFFloat (Just 3) value ""++clamp :: Double -> Double -> Double -> Double+clamp lower upper = min upper . max lower++clampInt :: Int -> Int -> Int -> Int+clampInt lower upper = min upper . max lower++twoPi :: Double+twoPi = 2 * pi
+ docs/persistence-rose/README.md view
@@ -0,0 +1,110 @@+# Moonlight persistence rose++![Animated Moonlight persistence rose](./moonlight-triangulation-persistence-rose.gif)++[Browse all exhibits.](../README.md)+· [Open the animation directly.](./moonlight-triangulation-persistence-rose.gif)+· [Open the static vector poster.](./moonlight-triangulation-persistence-rose.svg)+· [Open the alpha eclipse.](./alpha-eclipse.md)+· [Read the package overview.](../../README.md#persistence-rose)++## Exact alpha filtration and persistent topology++The full alpha path is a different observation of the same resident Delaunay+DCEL. `alphaFiltration` computes exact squared-radius births once: vertices at+zero, Gabriel edges at one quarter of their squared length, other edges at their+least incident-face witness, and faces at their circumradius squared.+`filteredAlphaComplex` lowers that section to the one Homology persistence+owner. `AlphaBirth` is an opaque reduced rational; equality and ordering never+round through `Double`.++This is the planar alpha-complex shortcut to the Cech filtration: the Delaunay+subcomplex has the same homotopy type as the corresponding union of discs, but+has only the resident planar cells. One reduction therefore yields the barcode+for every critical radius. `persistentBettiAtCriticalValues` sweeps all of+those sublevels through dense complex-relative ranks without rebuilding+geometry, reducing another boundary matrix, or rescanning the barcode per+radius.++The external component path uses the main facade for Delaunay construction and+exact alpha births, then adds only the opt-in cell-complex lowering and+Homology.++```cabal+build-depends:+  base >= 4.22 && < 5,+  moonlight-triangulation >= 1.4 && < 1.5,+  moonlight-planar:cell-complex >= 1.0 && < 1.1,+  moonlight-homology >= 0.1 && < 0.2,+  vector >= 0.13 && < 0.14+```++```haskell+import Data.Foldable (traverse_)+import qualified Data.Vector as Vector+import Moonlight.Homology.Persistence+  ( filteredCriticalValues+  , mod2PersistentPairs+  , persistentBettiAtCriticalValues+  )+import Moonlight.Triangulation+  ( Point (..)+  , alphaFiltration+  , delaunayGeometry+  )+import Moonlight.Triangulation.CellComplex (filteredAlphaComplex)++main :: IO ()+main = do+  mesh <- requireRight (delaunayGeometry (Vector.fromList [Point (-1) (-1), Point 1 (-1), Point 1 1, Point (-1) 1]))+  filtration <- requireRight (alphaFiltration mesh)+  filtered <- requireRight (filteredAlphaComplex filtration)+  pairs <- requireRight (mod2PersistentPairs filtered)+  profiles <- requireRight (persistentBettiAtCriticalValues filtered pairs)+  traverse_ print (zip (filteredCriticalValues filtered) profiles)++requireRight :: Show failure => Either failure value -> IO value+requireRight = either (fail . show) pure+```++The focused `moonlight-triangulation-alpha-bench` measures exact preparation,+one persistence reduction plus all critical-radius queries, and repeated+threshold homology as separate lanes over the same prebuilt Delaunay mesh.++## Source SVG generation++On GHC 9.14, the package-owned generator reproduces the poster or the canonical+65-frame seamless SVG sweep:++```console+cabal run moonlight-triangulation-persistence-rose -- poster persistence-rose.svg+cabal run moonlight-triangulation-persistence-rose -- frames 65 persistence-rose-frames+```++## Retained GIF reproduction++The retained GIF is the 960×540, 8 fps projection of those 65 source frames.+Its exact encoding boundary is deliberately outside geometry and Homology:+rasterize the SVG section, encode it, then let the exhibit owner stamp the GIF+with the deterministic source-frame fingerprint it computed itself.++```console+mkdir -p persistence-rose-png+sips -s format png persistence-rose-frames/frame-*.svg --out persistence-rose-png+ffmpeg -framerate 8 -start_number 0 -i persistence-rose-png/frame-%04d.png \+  -vf "scale=960:-2:flags=lanczos,palettegen=max_colors=96:stats_mode=diff" \+  -y persistence-rose-palette.png+ffmpeg -framerate 8 -start_number 0 -i persistence-rose-png/frame-%04d.png \+  -i persistence-rose-palette.png \+  -lavfi "[0:v]scale=960:-2:flags=lanczos[x];[x][1:v]paletteuse=dither=bayer:bayer_scale=4:diff_mode=rectangle" \+  -loop 0 -y persistence-rose-raw.gif+cabal run moonlight-triangulation-persistence-rose -- \+  stamp-gif persistence-rose-raw.gif docs/persistence-rose/moonlight-triangulation-persistence-rose.gif+cabal run moonlight-triangulation-persistence-rose -- verify-artifacts .+```++`verify-artifacts` compares both retained SVGs byte-for-byte with their pure+renderers, checks the GIF dimensions, timing, and image-frame inventory, and+requires the GIF's embedded source fingerprint to equal the freshly rendered+canonical frame section. A plausible binary can no longer wander in wearing a+nice hat.
+ docs/persistence-rose/alpha-eclipse.md view
@@ -0,0 +1,23 @@+# Moonlight alpha eclipse++![Alpha eclipse: a fixed Delaunay site set closes one hole and later fills it across exact critical radii](./moonlight-triangulation-alpha-eclipse.svg)++[Open the full-size vector.](./moonlight-triangulation-alpha-eclipse.svg)+· [Browse all exhibits.](../README.md)+· [Read the exact-filtration API semantics.](./README.md#exact-alpha-filtration-and-persistent-topology)++The eclipse uses the package's canonical four-site square witness and isolates+its one finite `H₁` interval. The four sites, five resident Delaunay edges, and+two resident faces remain fixed: the four hull edges close one hole at exact+`α² = 1`; the resident diagonal and both resident faces enter at exact+`α² = 2`, making that cycle a boundary. Only the alpha sublevel changes. Every+visible cell is projected from the resident DCEL, and the `β₁ = 0 → 1 → 0`+profile comes from Moonlight Homology rather than a hand-authored diagram.++## Reproduce++On GHC 9.14, the package-owned generator reproduces the retained vector:++```console+cabal run moonlight-triangulation-persistence-rose -- eclipse alpha-eclipse.svg+```
+ docs/persistence-rose/moonlight-triangulation-alpha-eclipse.svg view
@@ -0,0 +1,91 @@+<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 1440 620" width="1440" height="620" role="img" aria-labelledby="title description">+<title id="title">Moonlight Triangulation alpha eclipse</title>+<desc id="description">One fixed four-site Delaunay DCEL at three exact alpha sublevels. Its resident boundary creates one hole at squared radius 1, and its resident diagonal and faces kill that hole at squared radius 2.</desc>+<defs>+<radialGradient id="eclipse-background" cx="50%" cy="38%" r="78%"><stop offset="0" stop-color="#111744"/><stop offset="0.55" stop-color="#070b25"/><stop offset="1" stop-color="#02040f"/></radialGradient>+<linearGradient id="eclipse-corona" x1="0" y1="0" x2="1" y2="1"><stop offset="0" stop-color="#66efff"/><stop offset="0.48" stop-color="#ff72c6"/><stop offset="1" stop-color="#ffd86b"/></linearGradient>+<linearGradient id="eclipse-face" x1="0" y1="0" x2="1" y2="1"><stop offset="0" stop-color="#7c4dff"/><stop offset="0.5" stop-color="#ff4fa3"/><stop offset="1" stop-color="#ffbf5b"/></linearGradient>+<filter id="eclipse-soft-glow" x="-30%" y="-30%" width="160%" height="160%"><feGaussianBlur stdDeviation="7" result="blur"/><feMerge><feMergeNode in="blur"/><feMergeNode in="SourceGraphic"/></feMerge></filter>+<filter id="eclipse-dot-glow" x="-100%" y="-100%" width="300%" height="300%"><feGaussianBlur stdDeviation="3" result="blur"/><feMerge><feMergeNode in="blur"/><feMergeNode in="SourceGraphic"/></feMerge></filter>+</defs>+<rect width="1440" height="620" fill="url(#eclipse-background)"/>+<circle cx="720" cy="300" r="246" fill="#ff68bb" opacity="0.035" filter="url(#eclipse-soft-glow)"/>+<text x="58" y="58" fill="#84f3ff" font-family="Inter,ui-sans-serif,system-ui,sans-serif" font-size="17" font-weight="600" letter-spacing="6">MOONLIGHT TRIANGULATION</text>+<text x="58" y="101" fill="#f7f3ff" font-family="Inter,ui-sans-serif,system-ui,sans-serif" font-size="38" font-weight="420">ALPHA ECLIPSE</text>+<text x="1382" y="61" text-anchor="end" fill="#9baedb" font-family="Inter,ui-sans-serif,system-ui,sans-serif" font-size="14" letter-spacing="1.5">ONE FIXED DELAUNAY DCEL · EXACT CRITICAL BIRTHS</text>+<g transform="translate(245.000 292)">+<rect x="-194" y="-150" width="388" height="292" rx="28" fill="#090d26" fill-opacity="0.72" stroke="#344070" stroke-opacity="0.55"/>+<text x="-162" y="-114" fill="#8fa4d6" font-family="Inter,ui-sans-serif,system-ui,sans-serif" font-size="13" letter-spacing="2.4">BEFORE BIRTH</text>+<circle r="104" fill="#01020a" stroke="#7fefff" stroke-opacity="0.18" stroke-width="2"/>+<g fill="url(#eclipse-face)" fill-opacity="0.58" stroke="#ffd56d" stroke-opacity="0.48" stroke-width="1.2"></g>+<g fill="none" stroke="url(#eclipse-corona)" stroke-width="5" stroke-linejoin="round" stroke-linecap="round" filter="url(#eclipse-soft-glow)"></g>+<g fill="none" stroke="#fff7da" stroke-width="3.2" stroke-linejoin="round" opacity="0.86"></g>+<g fill="#fff8df" stroke="#ff75c5" stroke-width="2" filter="url(#eclipse-dot-glow)"><circle cx="0.000" cy="-101.823" r="6"/>+<circle cx="-101.823" cy="0.000" r="6"/>+<circle cx="101.823" cy="0.000" r="6"/>+<circle cx="0.000" cy="101.823" r="6"/>+</g>+<rect x="-126" y="-18" width="252" height="36" rx="18" fill="#05071a" fill-opacity="0.82"/>+<text y="5" text-anchor="middle" fill="#fff7da" font-family="Inter,ui-sans-serif,system-ui,sans-serif" font-size="14" letter-spacing="1.2">four isolated sites</text>+<text x="-162" y="121" fill="#fff4cc" font-family="Inter,ui-sans-serif,system-ui,sans-serif" font-size="25">β₁ = 0</text>+<text x="162" y="121" text-anchor="end" fill="#8495c4" font-family="Inter,ui-sans-serif,system-ui,sans-serif" font-size="12">α² = 0</text>+</g>+<g transform="translate(720.000 292)">+<rect x="-194" y="-150" width="388" height="292" rx="28" fill="#090d26" fill-opacity="0.72" stroke="#ff6fbd" stroke-opacity="0.72"/>+<text x="-162" y="-114" fill="#ff89cb" font-family="Inter,ui-sans-serif,system-ui,sans-serif" font-size="13" letter-spacing="2.4">LOOP BORN</text>+<circle r="104" fill="#01020a" stroke="#7fefff" stroke-opacity="0.18" stroke-width="2"/>+<g fill="url(#eclipse-face)" fill-opacity="0.58" stroke="#ffd56d" stroke-opacity="0.48" stroke-width="1.2"></g>+<g fill="none" stroke="url(#eclipse-corona)" stroke-width="5" stroke-linejoin="round" stroke-linecap="round" filter="url(#eclipse-soft-glow)"><line x1="0.000" y1="-101.823" x2="-101.823" y2="0.000"/>+<line x1="0.000" y1="-101.823" x2="101.823" y2="0.000"/>+<line x1="-101.823" y1="0.000" x2="0.000" y2="101.823"/>+<line x1="101.823" y1="0.000" x2="0.000" y2="101.823"/>+</g>+<g fill="none" stroke="#fff7da" stroke-width="3.2" stroke-linejoin="round" opacity="0.86"><path d="M -101.823,0.000 L 0.000,-101.823 L 101.823,0.000 L 0.000,101.823 Z"/>+</g>+<g fill="#fff8df" stroke="#ff75c5" stroke-width="2" filter="url(#eclipse-dot-glow)"><circle cx="0.000" cy="-101.823" r="6"/>+<circle cx="-101.823" cy="0.000" r="6"/>+<circle cx="101.823" cy="0.000" r="6"/>+<circle cx="0.000" cy="101.823" r="6"/>+</g>+<rect x="-126" y="-18" width="252" height="36" rx="18" fill="#05071a" fill-opacity="0.82"/>+<text y="5" text-anchor="middle" fill="#fff7da" font-family="Inter,ui-sans-serif,system-ui,sans-serif" font-size="14" letter-spacing="1.2">resident boundary closes</text>+<text x="-162" y="121" fill="#fff4cc" font-family="Inter,ui-sans-serif,system-ui,sans-serif" font-size="25">β₁ = 1</text>+<text x="162" y="121" text-anchor="end" fill="#8495c4" font-family="Inter,ui-sans-serif,system-ui,sans-serif" font-size="12">α² = 1</text>+</g>+<g transform="translate(1195.000 292)">+<rect x="-194" y="-150" width="388" height="292" rx="28" fill="#090d26" fill-opacity="0.72" stroke="#344070" stroke-opacity="0.55"/>+<text x="-162" y="-114" fill="#8fa4d6" font-family="Inter,ui-sans-serif,system-ui,sans-serif" font-size="13" letter-spacing="2.4">CYCLE KILLED</text>+<circle r="104" fill="#01020a" stroke="#7fefff" stroke-opacity="0.18" stroke-width="2"/>+<g fill="url(#eclipse-face)" fill-opacity="0.58" stroke="#ffd56d" stroke-opacity="0.48" stroke-width="1.2"><polygon points="0.000,-101.823 0.000,101.823 -101.823,0.000"/>+<polygon points="0.000,101.823 0.000,-101.823 101.823,0.000"/>+</g>+<g fill="none" stroke="url(#eclipse-corona)" stroke-width="5" stroke-linejoin="round" stroke-linecap="round" filter="url(#eclipse-soft-glow)"><line x1="0.000" y1="-101.823" x2="-101.823" y2="0.000"/>+<line x1="0.000" y1="101.823" x2="0.000" y2="-101.823"/>+<line x1="0.000" y1="-101.823" x2="101.823" y2="0.000"/>+<line x1="-101.823" y1="0.000" x2="0.000" y2="101.823"/>+<line x1="101.823" y1="0.000" x2="0.000" y2="101.823"/>+</g>+<g fill="none" stroke="#fff7da" stroke-width="3.2" stroke-linejoin="round" opacity="0.86"></g>+<g fill="#fff8df" stroke="#ff75c5" stroke-width="2" filter="url(#eclipse-dot-glow)"><circle cx="0.000" cy="-101.823" r="6"/>+<circle cx="-101.823" cy="0.000" r="6"/>+<circle cx="101.823" cy="0.000" r="6"/>+<circle cx="0.000" cy="101.823" r="6"/>+</g>+<rect x="-126" y="-18" width="252" height="36" rx="18" fill="#05071a" fill-opacity="0.82"/>+<text y="5" text-anchor="middle" fill="#fff7da" font-family="Inter,ui-sans-serif,system-ui,sans-serif" font-size="14" letter-spacing="1.2">resident faces fill it</text>+<text x="-162" y="121" fill="#fff4cc" font-family="Inter,ui-sans-serif,system-ui,sans-serif" font-size="25">β₁ = 0</text>+<text x="162" y="121" text-anchor="end" fill="#8495c4" font-family="Inter,ui-sans-serif,system-ui,sans-serif" font-size="12">α² = 2</text>+</g>+<g font-family="Inter,ui-sans-serif,system-ui,sans-serif">+<text x="58" y="516" fill="#9badd8" font-size="13" letter-spacing="2.5">ONE EXACT H₁ INTERVAL</text>+<line x1="58" y1="559" x2="1382" y2="559" stroke="#344070" stroke-width="3"/>+<line x1="535" y1="559" x2="1042" y2="559" stroke="#ff72c6" stroke-width="9" stroke-linecap="round"/>+<circle cx="535" cy="559" r="8" fill="#fff6d6" stroke="#ff72c6" stroke-width="3"/>+<rect x="1034" y="551" width="16" height="16" fill="#fff6d6" stroke="#66efff" stroke-width="3"/>+<text x="58" y="589" fill="#7588ba" font-size="12">α² = 0</text>+<text x="535" y="589" text-anchor="middle" fill="#f7f3ff" font-size="12">birth α² = 1</text>+<text x="788" y="548" text-anchor="middle" fill="#fff6d6" font-size="14">the eclipse hole persists</text>+<text x="1042" y="589" text-anchor="middle" fill="#f7f3ff" font-size="12">death α² = 2</text>+<text x="1382" y="589" text-anchor="end" fill="#7588ba" font-size="12">exact α² increases →</text>+</g>+</svg>
+ docs/persistence-rose/moonlight-triangulation-persistence-rose.gif view

binary file changed (absent → 661966 bytes)

+ docs/persistence-rose/moonlight-triangulation-persistence-rose.svg view
@@ -0,0 +1,1895 @@+<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 1920 1080" width="1920" height="1080" role="img" aria-labelledby="title description">+<title id="title">Moonlight Triangulation Persistence Rose</title>+<desc id="description">Exact Delaunay alpha filtration, persistent homology, Voronoi dual, Sibson interpolation, exact overlay, and Minkowski morphology composed into a seven-petal rose.</desc>+<defs>+<radialGradient id="background" cx="52%" cy="48%" r="72%"><stop offset="0" stop-color="#10143d"/><stop offset="0.48" stop-color="#070b24"/><stop offset="1" stop-color="#02040e"/></radialGradient>+<radialGradient id="rose-wash" cx="48%" cy="42%" r="63%"><stop offset="0" stop-color="#ffe7a3"/><stop offset="0.38" stop-color="#ff5fb7"/><stop offset="0.72" stop-color="#7c4dff"/><stop offset="1" stop-color="#00d9ff"/></radialGradient>+<linearGradient id="mask-stroke" x1="0" y1="0" x2="1" y2="1"><stop offset="0" stop-color="#ffd86b"/><stop offset="0.48" stop-color="#ff72c6"/><stop offset="1" stop-color="#66efff"/></linearGradient>+<linearGradient id="hole-stroke" x1="0" y1="0" x2="1" y2="1"><stop offset="0" stop-color="#fff9db"/><stop offset="0.52" stop-color="#ff9ad7"/><stop offset="1" stop-color="#9ff7ff"/></linearGradient>+<filter id="field-soften" x="-20%" y="-20%" width="140%" height="140%"><feGaussianBlur stdDeviation="24"/></filter>+<filter id="hole-glow" x="-30%" y="-30%" width="160%" height="160%"><feGaussianBlur stdDeviation="7" result="b"/><feMerge><feMergeNode in="b"/><feMergeNode in="SourceGraphic"/></feMerge></filter>+<filter id="edge-glow" x="-20%" y="-20%" width="140%" height="140%"><feGaussianBlur stdDeviation="3" result="b"/><feMerge><feMergeNode in="b"/><feMergeNode in="SourceGraphic"/></feMerge></filter>+<clipPath id="rose-clip"><path d="M 504.232,637.038 L 511.333,619.556 L 515.575,612.082 L 529.764,595.098 L 550.582,579.300 L 577.273,565.013 L 608.822,552.264 L 644.022,540.909 L 681.558,530.816 L 720.080,522.024 L 758.277,514.831 L 781.582,511.624 L 764.940,500.588 L 733.646,477.535 L 702.754,452.899 L 673.315,427.519 L 646.527,402.016 L 623.634,376.841 L 605.785,352.389 L 601.543,344.915 L 589.641,321.648 L 584.226,300.190 L 585.414,281.358 L 592.914,266.105 L 597.156,258.631 L 610.357,247.925 L 628.453,242.576 L 637.139,242.576 L 659.264,243.081 L 684.596,249.507 L 712.407,261.467 L 742.044,278.184 L 772.869,298.625 L 804.163,321.679 L 835.056,346.315 L 864.495,371.694 L 880.355,386.794 L 878.544,366.177 L 877.056,327.337 L 877.056,287.823 L 878.544,248.983 L 881.781,212.139 L 887.190,178.544 L 895.179,149.343 L 905.949,125.532 L 910.191,118.058 L 923.591,100.445 L 939.056,89.632 L 955.657,85.986 L 964.343,85.986 L 980.944,89.632 L 996.409,100.445 L 1009.809,118.058 L 1014.051,125.532 L 1024.821,149.343 L 1032.810,178.544 L 1038.219,212.139 L 1041.456,248.983 L 1042.944,287.823 L 1042.944,327.337 L 1041.456,366.177 L 1039.645,386.794 L 1055.505,371.694 L 1084.944,346.315 L 1115.837,321.679 L 1147.131,298.625 L 1177.956,278.184 L 1207.593,261.467 L 1235.404,249.507 L 1260.736,243.081 L 1282.861,242.576 L 1291.547,242.576 L 1309.643,247.925 L 1322.844,258.631 L 1327.086,266.105 L 1334.586,281.358 L 1335.774,300.190 L 1330.359,321.648 L 1318.457,344.915 L 1314.215,352.389 L 1296.366,376.841 L 1273.473,402.016 L 1246.685,427.519 L 1217.246,452.899 L 1186.354,477.535 L 1155.060,500.588 L 1138.418,511.624 L 1161.723,514.831 L 1199.920,522.024 L 1238.442,530.816 L 1275.978,540.909 L 1311.178,552.264 L 1342.727,565.013 L 1369.418,579.300 L 1390.236,595.098 L 1404.425,612.082 L 1408.667,619.556 L 1415.768,637.038 L 1415.628,654.035 L 1408.380,669.409 L 1404.138,676.883 L 1390.155,689.553 L 1370.002,698.698 L 1344.390,703.900 L 1314.144,705.190 L 1305.458,705.190 L 1271.502,702.988 L 1234.861,697.946 L 1196.664,690.753 L 1158.141,681.961 L 1120.606,671.868 L 1102.029,665.875 L 1110.623,680.329 L 1114.865,687.803 L 1133.058,722.152 L 1150.202,757.752 L 1165.714,793.391 L 1178.783,827.992 L 1188.486,860.606 L 1193.958,890.381 L 1194.586,916.508 L 1190.155,938.190 L 1180.913,954.642 L 1176.671,962.116 L 1163.296,972.604 L 1146.757,976.523 L 1138.071,976.523 L 1119.446,973.490 L 1099.732,963.436 L 1079.696,946.655 L 1059.829,923.812 L 1040.380,895.892 L 1021.476,864.100 L 1017.234,856.626 L 999.042,822.278 L 981.898,786.678 L 966.386,751.039 L 960.000,734.132 L 953.614,751.039 L 938.102,786.678 L 920.958,822.278 L 902.766,856.626 L 898.524,864.100 L 879.620,895.892 L 860.171,923.812 L 840.304,946.655 L 820.268,963.436 L 800.554,973.490 L 781.929,976.523 L 773.243,976.523 L 756.704,972.604 L 743.329,962.116 L 739.087,954.642 L 729.845,938.190 L 725.414,916.508 L 726.042,890.381 L 731.514,860.606 L 741.217,827.992 L 754.286,793.391 L 769.798,757.752 L 786.942,722.152 L 805.135,687.803 L 809.377,680.329 L 817.971,665.875 L 799.394,671.868 L 761.859,681.961 L 723.336,690.753 L 685.139,697.946 L 648.498,702.988 L 614.542,705.190 L 605.856,705.190 L 575.610,703.900 L 549.998,698.698 L 529.845,689.553 L 515.862,676.883 L 511.620,669.409 L 504.372,654.035 Z" fill-rule="evenodd"/></clipPath>+</defs>+<rect width="1920" height="1080" fill="url(#background)"/>+<circle cx="960" cy="552" r="322.000" fill="none" stroke="#8ba5ff" stroke-width="0.8" stroke-dasharray="2 12" opacity="0.077"/>+<circle cx="960" cy="552" r="356.000" fill="none" stroke="#8ba5ff" stroke-width="0.8" stroke-dasharray="2 12" opacity="0.077"/>+<circle cx="960" cy="552" r="390.000" fill="none" stroke="#8ba5ff" stroke-width="0.8" stroke-dasharray="2 12" opacity="0.077"/>+<circle cx="960" cy="552" r="424.000" fill="none" stroke="#8ba5ff" stroke-width="0.8" stroke-dasharray="2 12" opacity="0.077"/>+<circle cx="960" cy="552" r="458.000" fill="none" stroke="#8ba5ff" stroke-width="0.8" stroke-dasharray="2 12" opacity="0.077"/>+<circle cx="960" cy="552" r="492.000" fill="none" stroke="#8ba5ff" stroke-width="0.8" stroke-dasharray="2 12" opacity="0.077"/>+<g fill="none" stroke-linecap="round">+<polyline points="1077.000,949.123 1051.592,955.741 1025.816,960.735 999.775,964.085 973.574,965.777 947.318,965.806 921.113,964.170 895.065,960.876 869.278,955.937 843.856,949.374 818.900,941.213 794.513,931.486 770.791,920.233 747.830,907.499 725.722,893.336 704.557,877.799 684.419,860.952 665.389,842.862 647.545,823.602 630.957,803.250 615.692,781.888 601.813,759.600 589.374,736.478 578.426,712.614 569.012,688.104 561.171,663.046 554.934,637.542 550.326,611.694 547.366,585.606 546.066,559.382 546.430,533.129 548.458,506.952 552.141,480.956 557.465,455.245 564.407,429.924 572.941,405.094 583.032,380.854 594.638,357.303 607.714,334.536 622.207,312.642 638.059,291.712 655.206,271.828 673.578,253.071" stroke="hsl(188 92% 72%)" stroke-width="2.600" opacity="0.720"/>+<polyline points="1232.734,230.630 1252.266,248.285 1270.657,267.124 1287.837,287.075 1303.737,308.059 1318.296,329.995 1331.457,352.798 1343.169,376.377 1353.387,400.642 1362.069,425.497 1369.182,450.846 1374.699,476.589 1378.598,502.627 1380.864,528.857 1381.488,555.178 1380.467,581.486 1377.806,607.679 1373.515,633.655 1367.610,659.313 1360.115,684.551 1351.059,709.273 1340.478,733.381 1328.411,756.781 1314.908,779.382 1300.020,801.096 1283.805,821.839 1266.326,841.528 1247.653,860.088 1227.857,877.446 1207.016,893.534 1185.212,908.289 1162.529,921.655 1139.055,933.578 1114.883,944.012 1090.107,952.917 1064.823,960.258 1039.130,966.006 1013.128,970.138 986.919,972.640 960.605,973.500 934.289,972.715 908.073,970.289 882.060,966.231" stroke="hsl(205 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1035.085,974.378 1008.772,978.219 982.273,980.421 955.687,980.978 929.118,979.887 902.668,977.152 876.438,972.783 850.530,966.798 825.041,959.219 800.072,950.075 775.716,939.402 752.069,927.241 729.221,913.638 707.259,898.645 686.268,882.321 666.329,864.728 647.519,845.933 629.908,826.008 613.567,805.031 598.556,783.082 584.933,760.245 572.752,736.608 562.059,712.262 552.894,687.300 545.294,661.818 539.287,635.914 534.896,609.688 532.139,583.240 531.025,556.672 531.560,530.086 533.741,503.585 537.559,477.269 543.001,451.240 550.044,425.599 558.663,400.443 568.823,375.870 580.487,351.973 593.608,328.845 608.138,306.574 624.019,285.246 641.191,264.943 659.588,245.743 679.139,227.719" stroke="hsl(222 92% 72%)" stroke-width="2.600" opacity="0.720"/>+<polyline points="1040.714,980.973 1014.190,985.123 987.460,987.635 960.627,988.500 933.791,987.712 907.055,985.277 880.518,981.203 854.283,975.505 828.447,968.204 803.109,959.330 778.365,948.914 754.307,936.997 731.028,923.624 708.615,908.844 687.153,892.715 666.723,875.297 647.403,856.656 629.265,836.862 612.378,815.991 596.806,794.121 582.608,771.335 569.838,747.719 558.544,723.363 548.769,698.359 540.549,672.801 533.916,646.786 528.894,620.413 525.504,593.780 523.757,566.990 523.661,540.143 525.215,513.341 528.414,486.685 533.246,460.276 539.692,434.214 547.728,408.598 557.324,383.524 568.443,359.087 581.043,335.381 595.077,312.493 610.491,290.512 627.228,269.520 645.223,249.597 664.409,230.817" stroke="hsl(239 92% 72%)" stroke-width="2.600" opacity="0.720"/>+<polyline points="1076.891,980.337 1050.961,986.583 1024.703,991.260 998.212,994.353 971.583,995.849 944.912,995.744 918.295,994.037 891.829,990.735 865.609,985.851 839.730,979.400 814.284,971.408 789.365,961.902 765.061,950.917 741.460,938.492 718.648,924.673 696.707,909.509 675.716,893.056 655.751,875.371 636.884,856.519 619.183,836.569 602.711,815.592 587.529,793.664 573.691,770.863 561.247,747.273 550.241,722.979 540.714,698.067 532.701,672.628 526.229,646.754 521.322,620.538 517.998,594.075 516.269,567.460 516.142,540.789 517.616,514.159 520.686,487.665 525.341,461.403 531.565,435.468 539.335,409.954 548.623,384.952 559.395,360.553 571.613,336.845 585.232,313.913 600.204,291.841 616.474,270.707" stroke="hsl(256 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1052.392,993.946 1026.117,998.633 999.611,1001.759 972.967,1003.314 946.277,1003.291 919.635,1001.692 893.135,998.521 866.868,993.790 840.926,987.515 815.401,979.719 790.381,970.428 765.954,959.674 742.204,947.496 719.216,933.936 697.069,919.042 675.841,902.864 655.606,885.461 636.434,866.893 618.393,847.224 601.546,826.523 585.952,804.864 571.664,782.320 558.734,758.972 547.205,734.901 537.119,710.190 528.511,684.927 521.411,659.199 515.843,633.097 511.827,606.711 509.377,580.134 508.502,553.459 509.205,526.779 511.483,500.186 515.328,473.775 520.727,447.637 527.661,421.864 536.106,396.546 546.032,371.771 557.404,347.625 570.184,324.194 584.325,301.559 599.780,279.799 616.493,258.990" stroke="hsl(273 92% 72%)" stroke-width="2.600" opacity="0.720"/>+<polyline points="1071.913,997.148 1045.954,1002.880 1019.707,1007.100 993.260,1009.793 966.702,1010.951 940.120,1010.569 913.606,1008.649 887.247,1005.198 861.132,1000.226 835.349,993.750 809.984,985.793 785.123,976.381 760.847,965.545 737.240,953.322 714.380,939.752 692.344,924.883 671.206,908.762 651.036,891.444 631.903,872.988 613.871,853.456 596.999,832.912 581.345,811.426 566.962,789.069 553.896,765.918 542.193,742.048 531.891,717.542 523.026,692.480 515.626,666.947 509.717,641.028 505.318,614.810 502.444,588.382 501.105,561.832 501.306,535.249 503.045,508.722 506.317,482.341 511.110,456.192 517.410,430.366 525.194,404.947 534.436,380.022 545.106,355.673 557.168,331.983 570.581,309.031 585.300,286.894" stroke="hsl(290 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1052.848,955.454 1029.335,960.153 1005.590,963.482 981.692,965.431 957.721,965.994 933.757,965.167 909.882,962.955 886.175,959.365 862.715,954.407 839.582,948.100 816.853,940.465 794.604,931.526 772.909,921.314 751.843,909.864 731.474,897.213 711.872,883.404 693.102,868.483 675.228,852.501 658.309,835.511 642.402,817.570 627.560,798.738 613.833,779.078 601.267,758.657 589.905,737.542 579.784,715.805 570.939,693.519 563.399,670.758 557.189,647.598 552.330,624.118 548.838,600.396 546.726,576.512 546.000,552.545 546.663,528.577 548.712,504.687 552.141,480.956 556.938,457.463 563.087,434.287 570.568,411.506 579.354,389.197 589.418,367.433 600.725,346.289 613.236,325.834 626.911,306.139" stroke="hsl(307 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1245.433,241.855 1255.448,251.380 1265.146,261.228 1274.515,271.389 1283.546,281.852 1292.229,292.605 1300.555,303.637 1308.515,314.936 1316.100,326.490 1323.303,338.286 1330.114,350.313 1336.528,362.556 1342.536,375.003 1348.134,387.640 1353.314,400.454 1358.071,413.430 1362.400,426.556 1366.297,439.817 1369.757,453.198 1372.776,466.686 1375.351,480.265 1377.479,493.921 1379.159,507.640 1380.388,521.407 1381.165,535.206 1381.489,549.024 1381.360,562.844 1380.778,576.654 1379.744,590.436 1378.258,604.177 1376.322,617.862 1373.939,631.477 1371.111,645.006 1367.841,658.434 1364.132,671.749 1359.988,684.934 1355.415,697.977 1350.416,710.863 1344.998,723.578 1339.165,736.108 1332.925,748.441 1326.284,760.562 1319.249,772.459" stroke="hsl(202 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1302.579,293.774 1309.377,303.049 1315.925,312.504 1322.217,322.130 1328.248,331.922 1334.015,341.872 1339.513,351.973 1344.739,362.218 1349.687,372.599 1354.356,383.109 1358.742,393.740 1362.841,404.486 1366.650,415.337 1370.167,426.286 1373.389,437.326 1376.315,448.448 1378.941,459.645 1381.266,470.907 1383.288,482.229 1385.006,493.600 1386.419,505.013 1387.525,516.460 1388.324,527.933 1388.816,539.423 1388.999,550.922 1388.873,562.422 1388.440,573.914 1387.699,585.390 1386.650,596.843 1385.295,608.263 1383.634,619.643 1381.668,630.974 1379.400,642.248 1376.830,653.458 1373.961,664.595 1370.794,675.651 1367.332,686.617 1363.577,697.488 1359.532,708.253 1355.200,718.907 1350.584,729.440 1345.688,739.846 1340.514,750.117" stroke="hsl(219 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1313.780,296.320 1320.034,305.205 1326.065,314.243 1331.870,323.428 1337.444,332.755 1342.784,342.218 1347.887,351.811 1352.750,361.528 1357.369,371.363 1361.743,381.310 1365.867,391.362 1369.739,401.514 1373.358,411.760 1376.721,422.092 1379.825,432.505 1382.669,442.992 1385.252,453.546 1387.571,464.161 1389.624,474.831 1391.412,485.549 1392.933,496.307 1394.185,507.101 1395.168,517.922 1395.881,528.764 1396.324,539.621 1396.497,550.485 1396.400,561.350 1396.032,572.210 1395.394,583.057 1394.486,593.884 1393.309,604.686 1391.863,615.455 1390.150,626.185 1388.170,636.869 1385.925,647.500 1383.416,658.072 1380.644,668.578 1377.612,679.012 1374.322,689.368 1370.774,699.638 1366.972,709.817 1362.918,719.898 1358.614,729.875" stroke="hsl(236 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1356.866,352.918 1360.834,361.033 1364.636,369.227 1368.270,377.497 1371.736,385.839 1375.031,394.250 1378.155,402.726 1381.105,411.264 1383.881,419.860 1386.481,428.511 1388.905,437.213 1391.152,445.962 1393.220,454.756 1395.109,463.589 1396.817,472.459 1398.345,481.362 1399.691,490.295 1400.856,499.253 1401.838,508.233 1402.637,517.230 1403.252,526.243 1403.685,535.266 1403.933,544.295 1403.998,553.328 1403.879,562.361 1403.576,571.389 1403.090,580.409 1402.421,589.418 1401.568,598.411 1400.532,607.384 1399.314,616.335 1397.914,625.259 1396.333,634.153 1394.572,643.013 1392.630,651.835 1390.510,660.616 1388.211,669.352 1385.735,678.039 1383.083,686.674 1380.255,695.254 1377.254,703.774 1374.080,712.231 1370.734,720.622" stroke="hsl(253 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1343.627,313.919 1348.226,321.494 1352.675,329.158 1356.973,336.907 1361.118,344.740 1365.108,352.652 1368.943,360.641 1372.619,368.704 1376.137,376.837 1379.495,385.038 1382.691,393.304 1385.724,401.630 1388.593,410.014 1391.298,418.453 1393.835,426.944 1396.206,435.482 1398.409,444.066 1400.443,452.691 1402.307,461.354 1404.001,470.053 1405.524,478.783 1406.875,487.541 1408.054,496.324 1409.060,505.128 1409.894,513.950 1410.554,522.787 1411.041,531.636 1411.353,540.492 1411.492,549.352 1411.457,558.214 1411.248,567.073 1410.866,575.926 1410.309,584.771 1409.579,593.602 1408.676,602.418 1407.600,611.214 1406.352,619.987 1404.932,628.734 1403.340,637.452 1401.577,646.136 1399.645,654.785 1397.543,663.394 1395.272,671.959" stroke="hsl(270 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1374.328,354.482 1377.670,361.652 1380.889,368.878 1383.982,376.158 1386.949,383.491 1389.790,390.873 1392.503,398.304 1395.087,405.780 1397.542,413.299 1399.867,420.860 1402.062,428.460 1404.125,436.096 1406.057,443.767 1407.856,451.470 1409.522,459.203 1411.054,466.963 1412.453,474.749 1413.717,482.558 1414.846,490.387 1415.840,498.234 1416.699,506.098 1417.422,513.975 1418.010,521.863 1418.461,529.761 1418.776,537.665 1418.955,545.573 1418.998,553.483 1418.904,561.393 1418.674,569.300 1418.308,577.202 1417.805,585.096 1417.167,592.980 1416.393,600.853 1415.483,608.710 1414.438,616.551 1413.258,624.373 1411.944,632.173 1410.495,639.950 1408.913,647.700 1407.197,655.422 1405.348,663.113 1403.367,670.771 1401.254,678.394" stroke="hsl(287 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1324.284,355.295 1327.575,361.514 1330.759,367.788 1333.835,374.115 1336.804,380.494 1339.665,386.922 1342.415,393.397 1345.055,399.919 1347.584,406.484 1350.001,413.092 1352.305,419.740 1354.496,426.425 1356.573,433.147 1358.535,439.904 1360.383,446.693 1362.115,453.512 1363.730,460.359 1365.229,467.234 1366.611,474.132 1367.876,481.053 1369.022,487.995 1370.051,494.955 1370.961,501.931 1371.753,508.922 1372.425,515.926 1372.979,522.940 1373.413,529.962 1373.728,536.990 1373.923,544.023 1373.999,551.059 1373.955,558.094 1373.792,565.128 1373.509,572.158 1373.107,579.182 1372.585,586.198 1371.944,593.205 1371.185,600.199 1370.306,607.180 1369.309,614.144 1368.194,621.091 1366.961,628.018 1365.610,634.923 1364.143,641.804" stroke="hsl(304 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="546.368,470.939 547.596,464.908 548.911,458.896 550.314,452.904 551.805,446.933 553.383,440.984 555.047,435.059 556.797,429.159 558.634,423.286 560.556,417.439 562.563,411.621 564.655,405.834 566.831,400.077 569.091,394.353 571.435,388.662 573.861,383.006 576.369,377.387 578.960,371.804 581.631,366.260 584.384,360.755 587.216,355.292 590.128,349.870 593.118,344.491 596.187,339.157 599.333,333.867 602.557,328.625 605.856,323.430 609.231,318.283 612.681,313.187 616.205,308.141 619.802,303.148 623.471,298.207 627.213,293.321 631.025,288.490 634.907,283.715 638.859,278.997 642.879,274.337 646.967,269.737 651.122,265.196 655.342,260.717 659.627,256.300 663.977,251.946 668.389,247.656" stroke="hsl(199 92% 72%)" stroke-width="2.600" opacity="0.720"/>+<polyline points="536.712,482.229 537.739,476.258 538.851,470.303 540.047,464.363 541.326,458.442 542.689,452.539 544.135,446.655 545.664,440.793 547.276,434.953 548.970,429.136 550.746,423.344 552.604,417.578 554.543,411.838 556.563,406.126 558.663,400.443 560.843,394.791 563.103,389.170 565.442,383.581 567.860,378.026 570.356,372.506 572.929,367.021 575.580,361.573 578.307,356.164 581.111,350.793 583.990,345.463 586.944,340.173 589.973,334.926 593.075,329.722 596.251,324.563 599.499,319.449 602.819,314.381 606.210,309.361 609.672,304.389 613.204,299.466 616.804,294.594 620.474,289.773 624.211,285.005 628.014,280.290 631.885,275.628 635.820,271.022 639.820,266.472 643.884,261.979 648.012,257.544" stroke="hsl(216 92% 72%)" stroke-width="2.600" opacity="0.720"/>+<polyline points="1391.710,616.489 1390.790,622.373 1389.790,628.243 1388.710,634.100 1387.550,639.941 1386.310,645.766 1384.991,651.573 1383.593,657.362 1382.116,663.132 1380.561,668.880 1378.927,674.607 1377.215,680.311 1375.426,685.991 1373.559,691.647 1371.615,697.276 1369.595,702.878 1367.498,708.452 1365.326,713.997 1363.078,719.512 1360.755,724.995 1358.358,730.447 1355.886,735.865 1353.341,741.249 1350.722,746.598 1348.031,751.910 1345.268,757.186 1342.432,762.423 1339.526,767.621 1336.549,772.779 1333.502,777.895 1330.385,782.970 1327.199,788.002 1323.946,792.989 1320.624,797.932 1317.235,802.829 1313.780,807.680 1310.258,812.483 1306.672,817.237 1303.021,821.942 1299.306,826.597 1295.528,831.200 1291.688,835.752 1287.786,840.251" stroke="hsl(233 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="521.911,479.789 522.937,473.819 524.045,467.863 525.233,461.923 526.503,456.000 527.853,450.095 529.283,444.209 530.794,438.342 532.384,432.497 534.055,426.674 535.804,420.875 537.632,415.100 539.540,409.350 541.525,403.627 543.588,397.931 545.729,392.265 547.947,386.628 550.241,381.021 552.612,375.447 555.059,369.905 557.581,364.398 560.178,358.925 562.849,353.488 565.594,348.088 568.413,342.726 571.304,337.403 574.268,332.120 577.304,326.878 580.411,321.678 583.589,316.521 586.836,311.407 590.154,306.338 593.540,301.315 596.994,296.339 600.516,291.410 604.104,286.530 607.759,281.699 611.480,276.919 615.265,272.190 619.115,267.512 623.028,262.888 627.003,258.318 631.041,253.802" stroke="hsl(250 92% 72%)" stroke-width="2.600" opacity="0.720"/>+<polyline points="1394.664,429.854 1396.010,434.752 1397.302,439.664 1398.538,444.591 1399.718,449.531 1400.843,454.484 1401.913,459.450 1402.926,464.427 1403.883,469.415 1404.784,474.414 1405.628,479.423 1406.417,484.440 1407.149,489.467 1407.824,494.501 1408.442,499.542 1409.004,504.590 1409.509,509.645 1409.957,514.704 1410.348,519.768 1410.682,524.837 1410.959,529.908 1411.179,534.983 1411.342,540.060 1411.448,545.138 1411.496,550.217 1411.488,555.296 1411.422,560.375 1411.300,565.453 1411.120,570.529 1410.883,575.603 1410.589,580.673 1410.238,585.741 1409.829,590.804 1409.364,595.861 1408.843,600.914 1408.264,605.960 1407.629,611.000 1406.936,616.031 1406.188,621.055 1405.383,626.070 1404.521,631.076 1403.604,636.072 1402.630,641.057" stroke="hsl(267 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1231.657,182.022 1235.714,185.035 1239.737,188.093 1243.727,191.195 1247.682,194.341 1251.603,197.530 1255.488,200.763 1259.337,204.037 1263.150,207.354 1266.927,210.713 1270.666,214.113 1274.367,217.554 1278.031,221.035 1281.655,224.557 1285.241,228.118 1288.787,231.719 1292.294,235.359 1295.760,239.036 1299.185,242.752 1302.570,246.505 1305.913,250.296 1309.214,254.123 1312.472,257.986 1315.688,261.884 1318.861,265.818 1321.990,269.787 1325.075,273.789 1328.116,277.826 1331.113,281.896 1334.064,285.998 1336.970,290.133 1339.831,294.299 1342.645,298.497 1345.413,302.725 1348.134,306.984 1350.808,311.272 1353.435,315.590 1356.014,319.936 1358.545,324.310 1361.028,328.712 1363.462,333.141 1365.847,337.597 1368.184,342.078" stroke="hsl(284 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1265.330,831.588 1262.369,834.788 1259.374,837.957 1256.346,841.094 1253.285,844.199 1250.191,847.271 1247.065,850.311 1243.908,853.318 1240.719,856.291 1237.498,859.231 1234.247,862.136 1230.966,865.007 1227.654,867.843 1224.313,870.645 1220.943,873.411 1217.543,876.141 1214.115,878.835 1210.659,881.494 1207.175,884.115 1203.664,886.700 1200.125,889.248 1196.560,891.758 1192.969,894.230 1189.352,896.665 1185.709,899.061 1182.041,901.419 1178.349,903.738 1174.633,906.018 1170.892,908.259 1167.129,910.460 1163.342,912.622 1159.533,914.743 1155.702,916.825 1151.848,918.865 1147.974,920.865 1144.079,922.825 1140.163,924.743 1136.228,926.619 1132.273,928.455 1128.298,930.248 1124.306,932.000 1120.294,933.709 1116.266,935.376" stroke="hsl(301 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1369.037,450.258 1370.062,454.474 1371.044,458.699 1371.983,462.935 1372.877,467.180 1373.729,471.434 1374.536,475.696 1375.299,479.967 1376.019,484.245 1376.694,488.530 1377.325,492.822 1377.912,497.121 1378.455,501.425 1378.953,505.734 1379.407,510.049 1379.817,514.368 1380.182,518.691 1380.502,523.017 1380.778,527.346 1381.010,531.679 1381.197,536.013 1381.339,540.349 1381.437,544.686 1381.489,549.024 1381.498,553.362 1381.461,557.700 1381.380,562.038 1381.255,566.374 1381.085,570.709 1380.870,575.042 1380.610,579.372 1380.306,583.700 1379.958,588.024 1379.565,592.345 1379.127,596.661 1378.645,600.972 1378.119,605.278 1377.549,609.579 1376.934,613.873 1376.275,618.161 1375.572,622.442 1374.825,626.716 1374.034,630.981" stroke="hsl(196 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="543.685,448.448 544.773,444.169 545.905,439.901 547.081,435.645 548.300,431.401 549.563,427.170 550.870,422.952 552.219,418.748 553.613,414.558 555.049,410.383 556.528,406.223 558.049,402.078 559.614,397.949 561.220,393.836 562.869,389.740 564.561,385.661 566.293,381.600 568.068,377.557 569.884,373.532 571.742,369.527 573.640,365.540 575.580,361.573 577.560,357.627 579.581,353.701 581.642,349.796 583.743,345.913 585.884,342.051 588.065,338.212 590.285,334.395 592.544,330.601 594.842,326.831 597.179,323.085 599.555,319.363 601.968,315.665 604.419,311.993 606.909,308.346 609.435,304.725 611.999,301.130 614.599,297.561 617.236,294.020 619.909,290.505 622.619,287.019 625.364,283.561" stroke="hsl(213 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1221.864,202.773 1225.279,205.360 1228.668,207.980 1232.031,210.633 1235.368,213.319 1238.678,216.038 1241.962,218.789 1245.218,221.572 1248.447,224.387 1251.648,227.233 1254.821,230.111 1257.966,233.020 1261.082,235.959 1264.169,238.929 1267.227,241.929 1270.255,244.959 1273.253,248.018 1276.221,251.107 1279.159,254.225 1282.066,257.371 1284.941,260.546 1287.786,263.749 1290.599,266.980 1293.380,270.238 1296.129,273.523 1298.846,276.835 1301.530,280.174 1304.181,283.538 1306.799,286.929 1309.384,290.345 1311.935,293.786 1314.452,297.252 1316.935,300.743 1319.383,304.258 1321.797,307.797 1324.176,311.359 1326.520,314.945 1328.829,318.553 1331.102,322.184 1333.339,325.837 1335.541,329.511 1337.706,333.207 1339.835,336.925" stroke="hsl(230 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="522.660,475.389 523.432,471.100 524.247,466.820 525.104,462.548 526.003,458.284 526.944,454.030 527.926,449.785 528.950,445.549 530.015,441.324 531.122,437.110 532.270,432.907 533.460,428.715 534.690,424.535 535.961,420.367 537.274,416.212 538.626,412.070 540.020,407.942 541.454,403.827 542.928,399.727 544.443,395.641 545.997,391.571 547.591,387.516 549.225,383.476 550.899,379.453 552.612,375.447 554.364,371.457 556.156,367.485 557.986,363.531 559.855,359.595 561.762,355.677 563.708,351.779 565.692,347.899 567.714,344.040 569.774,340.200 571.871,336.381 574.006,332.582 576.177,328.805 578.386,325.049 580.632,321.315 582.914,317.603 585.232,313.913 587.587,310.247 589.977,306.604" stroke="hsl(247 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="516.078,469.628 516.907,465.275 517.780,460.931 518.695,456.596 519.652,452.269 520.652,447.953 521.694,443.646 522.779,439.350 523.905,435.065 525.074,430.791 526.284,426.529 527.537,422.278 528.831,418.041 530.166,413.816 531.543,409.604 532.961,405.406 534.420,401.223 535.920,397.053 537.461,392.899 539.043,388.760 540.665,384.637 542.328,380.530 544.030,376.439 545.773,372.365 547.556,368.309 549.379,364.270 551.241,360.250 553.142,356.248 555.083,352.264 557.062,348.300 559.081,344.356 561.138,340.431 563.233,336.527 565.367,332.644 567.539,328.782 569.748,324.941 571.995,321.122 574.280,317.326 576.601,313.552 578.960,309.801 581.355,306.073 583.787,302.369 586.255,298.689" stroke="hsl(264 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1403.110,432.274 1404.208,436.415 1405.268,440.567 1406.289,444.728 1407.271,448.899 1408.214,453.079 1409.118,457.267 1409.982,461.464 1410.808,465.668 1411.594,469.880 1412.341,474.099 1413.049,478.325 1413.717,482.558 1414.345,486.796 1414.934,491.040 1415.483,495.290 1415.993,499.544 1416.463,503.803 1416.893,508.066 1417.283,512.333 1417.633,516.603 1417.944,520.877 1418.214,525.153 1418.445,529.432 1418.636,533.712 1418.786,537.994 1418.897,542.278 1418.968,546.562 1418.999,550.846 1418.989,555.131 1418.940,559.416 1418.851,563.699 1418.722,567.982 1418.552,572.264 1418.343,576.543 1418.094,580.821 1417.805,585.096 1417.476,589.368 1417.108,593.637 1416.699,597.902 1416.251,602.163 1415.762,606.420 1415.235,610.672" stroke="hsl(281 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1362.256,649.911 1361.324,653.661 1360.358,657.403 1359.356,661.136 1358.320,664.859 1357.249,668.572 1356.144,672.276 1355.004,675.968 1353.829,679.650 1352.620,683.321 1351.377,686.980 1350.100,690.628 1348.789,694.263 1347.444,697.887 1346.066,701.497 1344.653,705.094 1343.207,708.678 1341.728,712.249 1340.216,715.805 1338.670,719.347 1337.091,722.875 1335.480,726.387 1333.835,729.885 1332.159,733.367 1330.449,736.833 1328.708,740.283 1326.934,743.717 1325.129,747.134 1323.291,750.534 1321.422,753.916 1319.521,757.281 1317.589,760.628 1315.626,763.957 1313.632,767.268 1311.607,770.560 1309.552,773.832 1307.466,777.086 1305.349,780.319 1303.203,783.533 1301.027,786.727 1298.821,789.900 1296.585,793.053 1294.320,796.184" stroke="hsl(298 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1216.243,217.333 1218.878,219.367 1221.497,221.423 1224.100,223.499 1226.687,225.595 1229.257,227.712 1231.810,229.848 1234.346,232.005 1236.865,234.182 1239.367,236.379 1241.851,238.596 1244.318,240.832 1246.767,243.087 1249.198,245.362 1251.611,247.656 1254.006,249.969 1256.382,252.300 1258.740,254.651 1261.080,257.020 1263.400,259.407 1265.702,261.813 1267.984,264.237 1270.248,266.678 1272.492,269.138 1274.716,271.615 1276.921,274.109 1279.106,276.621 1281.272,279.151 1283.417,281.697 1285.542,284.260 1287.646,286.839 1289.731,289.436 1291.794,292.048 1293.837,294.677 1295.859,297.322 1297.860,299.983 1299.841,302.660 1301.799,305.352 1303.737,308.059 1305.653,310.782 1307.548,313.520 1309.421,316.272 1311.272,319.040" stroke="hsl(193 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1199.794,196.276 1202.512,198.123 1205.215,199.991 1207.904,201.879 1210.579,203.789 1213.239,205.718 1215.884,207.668 1218.513,209.638 1221.128,211.628 1223.727,213.638 1226.311,215.668 1228.880,217.718 1231.432,219.787 1233.969,221.876 1236.489,223.984 1238.994,226.111 1241.482,228.258 1243.953,230.423 1246.408,232.607 1248.846,234.811 1251.267,237.032 1253.671,239.272 1256.057,241.531 1258.427,243.808 1260.779,246.103 1263.113,248.415 1265.429,250.746 1267.728,253.094 1270.008,255.460 1272.270,257.843 1274.514,260.244 1276.740,262.661 1278.947,265.096 1281.135,267.547 1283.304,270.015 1285.454,272.500 1287.586,275.001 1289.698,277.518 1291.790,280.051 1293.864,282.601 1295.917,285.166 1297.951,287.746 1299.965,290.343" stroke="hsl(210 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1138.876,153.835 1141.825,155.173 1144.765,156.533 1147.694,157.915 1150.613,159.318 1153.522,160.743 1156.419,162.190 1159.306,163.658 1162.182,165.148 1165.047,166.659 1167.901,168.191 1170.743,169.744 1173.574,171.318 1176.392,172.914 1179.199,174.530 1181.994,176.166 1184.777,177.824 1187.547,179.502 1190.305,181.201 1193.050,182.920 1195.782,184.659 1198.501,186.419 1201.207,188.199 1203.900,189.999 1206.579,191.818 1209.245,193.658 1211.897,195.517 1214.535,197.396 1217.160,199.294 1219.770,201.212 1222.365,203.149 1224.947,205.106 1227.513,207.081 1230.065,209.076 1232.602,211.089 1235.124,213.121 1237.631,215.172 1240.123,217.241 1242.599,219.329 1245.060,221.435 1247.505,223.559 1249.934,225.702 1252.347,227.862" stroke="hsl(227 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="516.618,528.577 516.804,525.288 517.015,522.000 517.249,518.714 517.509,515.430 517.792,512.147 518.100,508.867 518.432,505.589 518.789,502.314 519.170,499.042 519.575,495.772 520.004,492.506 520.458,489.243 520.935,485.983 521.437,482.727 521.963,479.475 522.514,476.226 523.088,472.982 523.686,469.742 524.309,466.507 524.955,463.277 525.625,460.051 526.320,456.831 527.038,453.615 527.780,450.405 528.545,447.201 529.335,444.002 530.148,440.810 530.985,437.623 531.845,434.443 532.729,431.269 533.637,428.102 534.568,424.942 535.523,421.789 536.500,418.643 537.502,415.504 538.526,412.373 539.574,409.249 540.644,406.134 541.738,403.026 542.855,399.927 543.995,396.836 545.158,393.753" stroke="hsl(244 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="509.391,523.650 509.614,520.307 509.861,516.966 510.134,513.627 510.431,510.290 510.753,506.956 511.099,503.623 511.470,500.294 511.867,496.967 512.287,493.643 512.733,490.323 513.202,487.006 513.697,483.692 514.216,480.383 514.760,477.077 515.328,473.775 515.921,470.478 516.538,467.185 517.179,463.897 517.845,460.614 518.536,457.335 519.250,454.062 519.989,450.794 520.752,447.532 521.539,444.276 522.351,441.025 523.186,437.781 524.046,434.543 524.929,431.311 525.837,428.087 526.768,424.868 527.723,421.657 528.702,418.453 529.705,415.257 530.732,412.068 531.782,408.886 532.856,405.713 533.953,402.548 535.073,399.390 536.218,396.242 537.385,393.101 538.576,389.970 539.790,386.847" stroke="hsl(261 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1418.477,573.910 1418.314,577.092 1418.128,580.273 1417.921,583.452 1417.692,586.630 1417.440,589.806 1417.167,592.980 1416.871,596.153 1416.554,599.323 1416.214,602.491 1415.853,605.656 1415.470,608.819 1415.064,611.980 1414.637,615.137 1414.188,618.291 1413.717,621.442 1413.224,624.590 1412.709,627.734 1412.172,630.875 1411.614,634.012 1411.034,637.145 1410.432,640.273 1409.808,643.398 1409.163,646.518 1408.496,649.633 1407.808,652.744 1407.097,655.850 1406.366,658.951 1405.613,662.047 1404.838,665.137 1404.042,668.222 1403.225,671.302 1402.386,674.376 1401.526,677.443 1400.644,680.505 1399.742,683.561 1398.818,686.610 1397.873,689.653 1396.907,692.689 1395.920,695.718 1394.912,698.741 1393.883,701.756 1392.833,704.764" stroke="hsl(278 92% 72%)" stroke-width="1.100" opacity="0.160"/>+<polyline points="1238.820,858.032 1236.689,859.960 1234.544,861.873 1232.387,863.772 1230.216,865.655 1228.032,867.523 1225.836,869.376 1223.626,871.213 1221.404,873.036 1219.169,874.842 1216.922,876.634 1214.663,878.409 1212.391,880.169 1210.107,881.913 1207.811,883.641 1205.503,885.353 1203.183,887.049 1200.851,888.729 1198.508,890.393 1196.153,892.041 1193.787,893.672 1191.410,895.286 1189.022,896.884 1186.622,898.466 1184.212,900.030 1181.790,901.578 1179.359,903.109 1176.916,904.624 1174.463,906.121 1172.000,907.601 1169.526,909.064 1167.043,910.510 1164.549,911.938 1162.046,913.349 1159.533,914.743 1157.010,916.120 1154.478,917.478 1151.936,918.819 1149.385,920.143 1146.825,921.449 1144.256,922.737 1141.679,924.007 1139.092,925.259" stroke="hsl(295 92% 72%)" stroke-width="1.100" opacity="0.160"/>+</g>+<g clip-path="url(#rose-clip)">+<path d="M 504.232,637.038 L 511.333,619.556 L 515.575,612.082 L 529.764,595.098 L 550.582,579.300 L 577.273,565.013 L 608.822,552.264 L 644.022,540.909 L 681.558,530.816 L 720.080,522.024 L 758.277,514.831 L 781.582,511.624 L 764.940,500.588 L 733.646,477.535 L 702.754,452.899 L 673.315,427.519 L 646.527,402.016 L 623.634,376.841 L 605.785,352.389 L 601.543,344.915 L 589.641,321.648 L 584.226,300.190 L 585.414,281.358 L 592.914,266.105 L 597.156,258.631 L 610.357,247.925 L 628.453,242.576 L 637.139,242.576 L 659.264,243.081 L 684.596,249.507 L 712.407,261.467 L 742.044,278.184 L 772.869,298.625 L 804.163,321.679 L 835.056,346.315 L 864.495,371.694 L 880.355,386.794 L 878.544,366.177 L 877.056,327.337 L 877.056,287.823 L 878.544,248.983 L 881.781,212.139 L 887.190,178.544 L 895.179,149.343 L 905.949,125.532 L 910.191,118.058 L 923.591,100.445 L 939.056,89.632 L 955.657,85.986 L 964.343,85.986 L 980.944,89.632 L 996.409,100.445 L 1009.809,118.058 L 1014.051,125.532 L 1024.821,149.343 L 1032.810,178.544 L 1038.219,212.139 L 1041.456,248.983 L 1042.944,287.823 L 1042.944,327.337 L 1041.456,366.177 L 1039.645,386.794 L 1055.505,371.694 L 1084.944,346.315 L 1115.837,321.679 L 1147.131,298.625 L 1177.956,278.184 L 1207.593,261.467 L 1235.404,249.507 L 1260.736,243.081 L 1282.861,242.576 L 1291.547,242.576 L 1309.643,247.925 L 1322.844,258.631 L 1327.086,266.105 L 1334.586,281.358 L 1335.774,300.190 L 1330.359,321.648 L 1318.457,344.915 L 1314.215,352.389 L 1296.366,376.841 L 1273.473,402.016 L 1246.685,427.519 L 1217.246,452.899 L 1186.354,477.535 L 1155.060,500.588 L 1138.418,511.624 L 1161.723,514.831 L 1199.920,522.024 L 1238.442,530.816 L 1275.978,540.909 L 1311.178,552.264 L 1342.727,565.013 L 1369.418,579.300 L 1390.236,595.098 L 1404.425,612.082 L 1408.667,619.556 L 1415.768,637.038 L 1415.628,654.035 L 1408.380,669.409 L 1404.138,676.883 L 1390.155,689.553 L 1370.002,698.698 L 1344.390,703.900 L 1314.144,705.190 L 1305.458,705.190 L 1271.502,702.988 L 1234.861,697.946 L 1196.664,690.753 L 1158.141,681.961 L 1120.606,671.868 L 1102.029,665.875 L 1110.623,680.329 L 1114.865,687.803 L 1133.058,722.152 L 1150.202,757.752 L 1165.714,793.391 L 1178.783,827.992 L 1188.486,860.606 L 1193.958,890.381 L 1194.586,916.508 L 1190.155,938.190 L 1180.913,954.642 L 1176.671,962.116 L 1163.296,972.604 L 1146.757,976.523 L 1138.071,976.523 L 1119.446,973.490 L 1099.732,963.436 L 1079.696,946.655 L 1059.829,923.812 L 1040.380,895.892 L 1021.476,864.100 L 1017.234,856.626 L 999.042,822.278 L 981.898,786.678 L 966.386,751.039 L 960.000,734.132 L 953.614,751.039 L 938.102,786.678 L 920.958,822.278 L 902.766,856.626 L 898.524,864.100 L 879.620,895.892 L 860.171,923.812 L 840.304,946.655 L 820.268,963.436 L 800.554,973.490 L 781.929,976.523 L 773.243,976.523 L 756.704,972.604 L 743.329,962.116 L 739.087,954.642 L 729.845,938.190 L 725.414,916.508 L 726.042,890.381 L 731.514,860.606 L 741.217,827.992 L 754.286,793.391 L 769.798,757.752 L 786.942,722.152 L 805.135,687.803 L 809.377,680.329 L 817.971,665.875 L 799.394,671.868 L 761.859,681.961 L 723.336,690.753 L 685.139,697.946 L 648.498,702.988 L 614.542,705.190 L 605.856,705.190 L 575.610,703.900 L 549.998,698.698 L 529.845,689.553 L 515.862,676.883 L 511.620,669.409 L 504.372,654.035 Z" fill="url(#rose-wash)" opacity="0.28"/>+<g filter="url(#field-soften)"><circle cx="925.660" cy="139.920" r="35.000" fill="hsl(271 94% 61%)" opacity="0.268"/>+<circle cx="960.000" cy="139.920" r="35.000" fill="hsl(255 94% 61%)" opacity="0.247"/>+<circle cx="994.340" cy="139.920" r="35.000" fill="hsl(238 94% 61%)" opacity="0.226"/>+<circle cx="856.980" cy="174.260" r="35.000" fill="hsl(258 94% 61%)" opacity="0.251"/>+<circle cx="891.320" cy="174.260" r="35.000" fill="hsl(266 94% 61%)" opacity="0.262"/>+<circle cx="925.660" cy="174.260" r="35.000" fill="hsl(267 94% 61%)" opacity="0.263"/>+<circle cx="960.000" cy="174.260" r="35.000" fill="hsl(252 94% 61%)" opacity="0.244"/>+<circle cx="994.340" cy="174.260" r="35.000" fill="hsl(236 94% 61%)" opacity="0.224"/>+<circle cx="1028.680" cy="174.260" r="35.000" fill="hsl(234 94% 61%)" opacity="0.221"/>+<circle cx="1063.020" cy="174.260" r="35.000" fill="hsl(242 94% 61%)" opacity="0.231"/>+<circle cx="788.300" cy="208.600" r="35.000" fill="hsl(248 94% 61%)" opacity="0.239"/>+<circle cx="822.640" cy="208.600" r="35.000" fill="hsl(252 94% 61%)" opacity="0.243"/>+<circle cx="856.980" cy="208.600" r="35.000" fill="hsl(257 94% 61%)" opacity="0.250"/>+<circle cx="891.320" cy="208.600" r="35.000" fill="hsl(265 94% 61%)" opacity="0.260"/>+<circle cx="925.660" cy="208.600" r="35.000" fill="hsl(262 94% 61%)" opacity="0.257"/>+<circle cx="960.000" cy="208.600" r="35.000" fill="hsl(249 94% 61%)" opacity="0.241"/>+<circle cx="994.340" cy="208.600" r="35.000" fill="hsl(236 94% 61%)" opacity="0.224"/>+<circle cx="1028.680" cy="208.600" r="35.000" fill="hsl(229 94% 61%)" opacity="0.215"/>+<circle cx="1063.020" cy="208.600" r="35.000" fill="hsl(232 94% 61%)" opacity="0.218"/>+<circle cx="1097.360" cy="208.600" r="35.000" fill="hsl(236 94% 61%)" opacity="0.224"/>+<circle cx="1131.700" cy="208.600" r="35.000" fill="hsl(243 94% 61%)" opacity="0.233"/>+<circle cx="719.620" cy="242.940" r="35.000" fill="hsl(238 94% 61%)" opacity="0.225"/>+<circle cx="753.960" cy="242.940" r="35.000" fill="hsl(238 94% 61%)" opacity="0.227"/>+<circle cx="788.300" cy="242.940" r="35.000" fill="hsl(241 94% 61%)" opacity="0.230"/>+<circle cx="822.640" cy="242.940" r="35.000" fill="hsl(245 94% 61%)" opacity="0.235"/>+<circle cx="856.980" cy="242.940" r="35.000" fill="hsl(251 94% 61%)" opacity="0.243"/>+<circle cx="891.320" cy="242.940" r="35.000" fill="hsl(259 94% 61%)" opacity="0.253"/>+<circle cx="925.660" cy="242.940" r="35.000" fill="hsl(257 94% 61%)" opacity="0.251"/>+<circle cx="960.000" cy="242.940" r="35.000" fill="hsl(248 94% 61%)" opacity="0.239"/>+<circle cx="994.340" cy="242.940" r="35.000" fill="hsl(239 94% 61%)" opacity="0.227"/>+<circle cx="1028.680" cy="242.940" r="35.000" fill="hsl(231 94% 61%)" opacity="0.218"/>+<circle cx="1063.020" cy="242.940" r="35.000" fill="hsl(230 94% 61%)" opacity="0.216"/>+<circle cx="1097.360" cy="242.940" r="35.000" fill="hsl(230 94% 61%)" opacity="0.216"/>+<circle cx="1131.700" cy="242.940" r="35.000" fill="hsl(231 94% 61%)" opacity="0.218"/>+<circle cx="1166.040" cy="242.940" r="35.000" fill="hsl(235 94% 61%)" opacity="0.223"/>+<circle cx="1200.380" cy="242.940" r="35.000" fill="hsl(243 94% 61%)" opacity="0.232"/>+<circle cx="650.940" cy="277.280" r="35.000" fill="hsl(231 94% 61%)" opacity="0.217"/>+<circle cx="685.280" cy="277.280" r="35.000" fill="hsl(222 94% 61%)" opacity="0.206"/>+<circle cx="719.620" cy="277.280" r="35.000" fill="hsl(223 94% 61%)" opacity="0.207"/>+<circle cx="753.960" cy="277.280" r="35.000" fill="hsl(226 94% 61%)" opacity="0.210"/>+<circle cx="788.300" cy="277.280" r="35.000" fill="hsl(230 94% 61%)" opacity="0.216"/>+<circle cx="822.640" cy="277.280" r="35.000" fill="hsl(236 94% 61%)" opacity="0.224"/>+<circle cx="856.980" cy="277.280" r="35.000" fill="hsl(244 94% 61%)" opacity="0.234"/>+<circle cx="891.320" cy="277.280" r="35.000" fill="hsl(253 94% 61%)" opacity="0.245"/>+<circle cx="925.660" cy="277.280" r="35.000" fill="hsl(254 94% 61%)" opacity="0.246"/>+<circle cx="960.000" cy="277.280" r="35.000" fill="hsl(249 94% 61%)" opacity="0.240"/>+<circle cx="994.340" cy="277.280" r="35.000" fill="hsl(244 94% 61%)" opacity="0.233"/>+<circle cx="1028.680" cy="277.280" r="35.000" fill="hsl(238 94% 61%)" opacity="0.226"/>+<circle cx="1063.020" cy="277.280" r="35.000" fill="hsl(233 94% 61%)" opacity="0.220"/>+<circle cx="1097.360" cy="277.280" r="35.000" fill="hsl(230 94% 61%)" opacity="0.216"/>+<circle cx="1131.700" cy="277.280" r="35.000" fill="hsl(227 94% 61%)" opacity="0.212"/>+<circle cx="1166.040" cy="277.280" r="35.000" fill="hsl(226 94% 61%)" opacity="0.211"/>+<circle cx="1200.380" cy="277.280" r="35.000" fill="hsl(227 94% 61%)" opacity="0.212"/>+<circle cx="1234.720" cy="277.280" r="35.000" fill="hsl(230 94% 61%)" opacity="0.216"/>+<circle cx="1269.060" cy="277.280" r="35.000" fill="hsl(246 94% 61%)" opacity="0.236"/>+<circle cx="616.600" cy="311.620" r="35.000" fill="hsl(240 94% 61%)" opacity="0.229"/>+<circle cx="650.940" cy="311.620" r="35.000" fill="hsl(229 94% 61%)" opacity="0.214"/>+<circle cx="685.280" cy="311.620" r="35.000" fill="hsl(220 94% 61%)" opacity="0.203"/>+<circle cx="719.620" cy="311.620" r="35.000" fill="hsl(213 94% 61%)" opacity="0.195"/>+<circle cx="753.960" cy="311.620" r="35.000" fill="hsl(211 94% 61%)" opacity="0.192"/>+<circle cx="788.300" cy="311.620" r="35.000" fill="hsl(218 94% 61%)" opacity="0.201"/>+<circle cx="822.640" cy="311.620" r="35.000" fill="hsl(227 94% 61%)" opacity="0.212"/>+<circle cx="856.980" cy="311.620" r="35.000" fill="hsl(237 94% 61%)" opacity="0.224"/>+<circle cx="891.320" cy="311.620" r="34.000" fill="hsl(248 94% 61%)" opacity="0.239"/>+<circle cx="925.660" cy="311.620" r="35.000" fill="hsl(252 94% 61%)" opacity="0.244"/>+<circle cx="960.000" cy="311.620" r="35.000" fill="hsl(252 94% 61%)" opacity="0.244"/>+<circle cx="994.340" cy="311.620" r="35.000" fill="hsl(251 94% 61%)" opacity="0.243"/>+<circle cx="1028.680" cy="311.620" r="35.000" fill="hsl(249 94% 61%)" opacity="0.239"/>+<circle cx="1063.020" cy="311.620" r="35.000" fill="hsl(242 94% 61%)" opacity="0.231"/>+<circle cx="1097.360" cy="311.620" r="35.000" fill="hsl(236 94% 61%)" opacity="0.223"/>+<circle cx="1131.700" cy="311.620" r="35.000" fill="hsl(229 94% 61%)" opacity="0.215"/>+<circle cx="1166.040" cy="311.620" r="35.000" fill="hsl(224 94% 61%)" opacity="0.208"/>+<circle cx="1200.380" cy="311.620" r="35.000" fill="hsl(225 94% 61%)" opacity="0.209"/>+<circle cx="1234.720" cy="311.620" r="35.000" fill="hsl(233 94% 61%)" opacity="0.220"/>+<circle cx="1269.060" cy="311.620" r="35.000" fill="hsl(246 94% 61%)" opacity="0.237"/>+<circle cx="1303.400" cy="311.620" r="35.000" fill="hsl(263 94% 61%)" opacity="0.258"/>+<circle cx="616.600" cy="345.960" r="35.000" fill="hsl(239 94% 61%)" opacity="0.227"/>+<circle cx="650.940" cy="345.960" r="35.000" fill="hsl(225 94% 61%)" opacity="0.209"/>+<circle cx="685.280" cy="345.960" r="35.000" fill="hsl(217 94% 61%)" opacity="0.199"/>+<circle cx="719.620" cy="345.960" r="35.000" fill="hsl(211 94% 61%)" opacity="0.192"/>+<circle cx="753.960" cy="345.960" r="35.000" fill="hsl(209 94% 61%)" opacity="0.189"/>+<circle cx="788.300" cy="345.960" r="35.000" fill="hsl(208 94% 61%)" opacity="0.188"/>+<circle cx="822.640" cy="345.960" r="35.000" fill="hsl(218 94% 61%)" opacity="0.201"/>+<circle cx="856.980" cy="345.960" r="35.000" fill="hsl(231 94% 61%)" opacity="0.217"/>+<circle cx="891.320" cy="345.960" r="34.000" fill="hsl(244 94% 61%)" opacity="0.234"/>+<circle cx="925.660" cy="345.960" r="35.000" fill="hsl(252 94% 61%)" opacity="0.244"/>+<circle cx="960.000" cy="345.960" r="35.000" fill="hsl(256 94% 61%)" opacity="0.250"/>+<circle cx="994.340" cy="345.960" r="35.000" fill="hsl(260 94% 61%)" opacity="0.254"/>+<circle cx="1028.680" cy="345.960" r="34.000" fill="hsl(261 94% 61%)" opacity="0.255"/>+<circle cx="1063.020" cy="345.960" r="35.000" fill="hsl(254 94% 61%)" opacity="0.246"/>+<circle cx="1097.360" cy="345.960" r="35.000" fill="hsl(246 94% 61%)" opacity="0.237"/>+<circle cx="1131.700" cy="345.960" r="35.000" fill="hsl(238 94% 61%)" opacity="0.226"/>+<circle cx="1166.040" cy="345.960" r="35.000" fill="hsl(232 94% 61%)" opacity="0.219"/>+<circle cx="1200.380" cy="345.960" r="35.000" fill="hsl(232 94% 61%)" opacity="0.218"/>+<circle cx="1234.720" cy="345.960" r="35.000" fill="hsl(237 94% 61%)" opacity="0.224"/>+<circle cx="1269.060" cy="345.960" r="35.000" fill="hsl(247 94% 61%)" opacity="0.237"/>+<circle cx="1303.400" cy="345.960" r="35.000" fill="hsl(256 94% 61%)" opacity="0.249"/>+<circle cx="616.600" cy="380.300" r="35.000" fill="hsl(239 94% 61%)" opacity="0.227"/>+<circle cx="650.940" cy="380.300" r="35.000" fill="hsl(223 94% 61%)" opacity="0.206"/>+<circle cx="685.280" cy="380.300" r="35.000" fill="hsl(212 94% 61%)" opacity="0.193"/>+<circle cx="719.620" cy="380.300" r="35.000" fill="hsl(209 94% 61%)" opacity="0.189"/>+<circle cx="753.960" cy="380.300" r="35.000" fill="hsl(208 94% 61%)" opacity="0.188"/>+<circle cx="788.300" cy="380.300" r="35.000" fill="hsl(210 94% 61%)" opacity="0.190"/>+<circle cx="822.640" cy="380.300" r="35.000" fill="hsl(215 94% 61%)" opacity="0.196"/>+<circle cx="856.980" cy="380.300" r="35.000" fill="hsl(227 94% 61%)" opacity="0.212"/>+<circle cx="891.320" cy="380.300" r="35.000" fill="hsl(242 94% 61%)" opacity="0.232"/>+<circle cx="925.660" cy="380.300" r="35.000" fill="hsl(255 94% 61%)" opacity="0.247"/>+<circle cx="960.000" cy="380.300" r="35.000" fill="hsl(263 94% 61%)" opacity="0.257"/>+<circle cx="994.340" cy="380.300" r="35.000" fill="hsl(270 94% 61%)" opacity="0.267"/>+<circle cx="1028.680" cy="380.300" r="35.000" fill="hsl(274 94% 61%)" opacity="0.271"/>+<circle cx="1063.020" cy="380.300" r="35.000" fill="hsl(269 94% 61%)" opacity="0.265"/>+<circle cx="1097.360" cy="380.300" r="34.000" fill="hsl(260 94% 61%)" opacity="0.254"/>+<circle cx="1131.700" cy="380.300" r="35.000" fill="hsl(250 94% 61%)" opacity="0.241"/>+<circle cx="1166.040" cy="380.300" r="35.000" fill="hsl(243 94% 61%)" opacity="0.232"/>+<circle cx="1200.380" cy="380.300" r="35.000" fill="hsl(239 94% 61%)" opacity="0.227"/>+<circle cx="1234.720" cy="380.300" r="35.000" fill="hsl(240 94% 61%)" opacity="0.229"/>+<circle cx="1269.060" cy="380.300" r="34.000" fill="hsl(245 94% 61%)" opacity="0.235"/>+<circle cx="1303.400" cy="380.300" r="35.000" fill="hsl(248 94% 61%)" opacity="0.239"/>+<circle cx="616.600" cy="414.640" r="35.000" fill="hsl(241 94% 61%)" opacity="0.229"/>+<circle cx="650.940" cy="414.640" r="35.000" fill="hsl(228 94% 61%)" opacity="0.214"/>+<circle cx="685.280" cy="414.640" r="35.000" fill="hsl(213 94% 61%)" opacity="0.194"/>+<circle cx="719.620" cy="414.640" r="35.000" fill="hsl(206 94% 61%)" opacity="0.186"/>+<circle cx="753.960" cy="414.640" r="35.000" fill="hsl(207 94% 61%)" opacity="0.187"/>+<circle cx="788.300" cy="414.640" r="35.000" fill="hsl(211 94% 61%)" opacity="0.192"/>+<circle cx="822.640" cy="414.640" r="35.000" fill="hsl(218 94% 61%)" opacity="0.201"/>+<circle cx="856.980" cy="414.640" r="35.000" fill="hsl(227 94% 61%)" opacity="0.213"/>+<circle cx="891.320" cy="414.640" r="34.000" fill="hsl(243 94% 61%)" opacity="0.232"/>+<circle cx="925.660" cy="414.640" r="35.000" fill="hsl(258 94% 61%)" opacity="0.251"/>+<circle cx="960.000" cy="414.640" r="35.000" fill="hsl(269 94% 61%)" opacity="0.265"/>+<circle cx="994.340" cy="414.640" r="35.000" fill="hsl(280 94% 61%)" opacity="0.280"/>+<circle cx="1028.680" cy="414.640" r="34.000" fill="hsl(285 94% 61%)" opacity="0.286"/>+<circle cx="1063.020" cy="414.640" r="35.000" fill="hsl(281 94% 61%)" opacity="0.281"/>+<circle cx="1097.360" cy="414.640" r="35.000" fill="hsl(272 94% 61%)" opacity="0.269"/>+<circle cx="1131.700" cy="414.640" r="35.000" fill="hsl(261 94% 61%)" opacity="0.256"/>+<circle cx="1166.040" cy="414.640" r="35.000" fill="hsl(252 94% 61%)" opacity="0.244"/>+<circle cx="1200.380" cy="414.640" r="35.000" fill="hsl(246 94% 61%)" opacity="0.236"/>+<circle cx="1234.720" cy="414.640" r="34.000" fill="hsl(242 94% 61%)" opacity="0.231"/>+<circle cx="1269.060" cy="414.640" r="35.000" fill="hsl(240 94% 61%)" opacity="0.228"/>+<circle cx="1303.400" cy="414.640" r="35.000" fill="hsl(240 94% 61%)" opacity="0.229"/>+<circle cx="582.260" cy="448.980" r="35.000" fill="hsl(248 94% 61%)" opacity="0.238"/>+<circle cx="616.600" cy="448.980" r="35.000" fill="hsl(244 94% 61%)" opacity="0.233"/>+<circle cx="650.940" cy="448.980" r="35.000" fill="hsl(235 94% 61%)" opacity="0.222"/>+<circle cx="685.280" cy="448.980" r="35.000" fill="hsl(223 94% 61%)" opacity="0.207"/>+<circle cx="719.620" cy="448.980" r="35.000" fill="hsl(211 94% 61%)" opacity="0.192"/>+<circle cx="753.960" cy="448.980" r="34.000" fill="hsl(207 94% 61%)" opacity="0.187"/>+<circle cx="788.300" cy="448.980" r="35.000" fill="hsl(213 94% 61%)" opacity="0.194"/>+<circle cx="822.640" cy="448.980" r="35.000" fill="hsl(221 94% 61%)" opacity="0.204"/>+<circle cx="856.980" cy="448.980" r="35.000" fill="hsl(231 94% 61%)" opacity="0.217"/>+<circle cx="891.320" cy="448.980" r="35.000" fill="hsl(244 94% 61%)" opacity="0.234"/>+<circle cx="925.660" cy="448.980" r="35.000" fill="hsl(261 94% 61%)" opacity="0.256"/>+<circle cx="960.000" cy="448.980" r="35.000" fill="hsl(275 94% 61%)" opacity="0.273"/>+<circle cx="994.340" cy="448.980" r="35.000" fill="hsl(289 94% 61%)" opacity="0.291"/>+<circle cx="1028.680" cy="448.980" r="35.000" fill="hsl(294 94% 61%)" opacity="0.297"/>+<circle cx="1063.020" cy="448.980" r="35.000" fill="hsl(289 94% 61%)" opacity="0.291"/>+<circle cx="1097.360" cy="448.980" r="35.000" fill="hsl(282 94% 61%)" opacity="0.281"/>+<circle cx="1131.700" cy="448.980" r="35.000" fill="hsl(272 94% 61%)" opacity="0.269"/>+<circle cx="1166.040" cy="448.980" r="35.000" fill="hsl(262 94% 61%)" opacity="0.257"/>+<circle cx="1200.380" cy="448.980" r="34.000" fill="hsl(250 94% 61%)" opacity="0.242"/>+<circle cx="1234.720" cy="448.980" r="35.000" fill="hsl(240 94% 61%)" opacity="0.228"/>+<circle cx="1269.060" cy="448.980" r="35.000" fill="hsl(234 94% 61%)" opacity="0.221"/>+<circle cx="1303.400" cy="448.980" r="35.000" fill="hsl(233 94% 61%)" opacity="0.220"/>+<circle cx="1337.740" cy="448.980" r="35.000" fill="hsl(235 94% 61%)" opacity="0.223"/>+<circle cx="582.260" cy="483.320" r="35.000" fill="hsl(250 94% 61%)" opacity="0.241"/>+<circle cx="616.600" cy="483.320" r="35.000" fill="hsl(248 94% 61%)" opacity="0.239"/>+<circle cx="650.940" cy="483.320" r="35.000" fill="hsl(243 94% 61%)" opacity="0.232"/>+<circle cx="685.280" cy="483.320" r="35.000" fill="hsl(234 94% 61%)" opacity="0.221"/>+<circle cx="719.620" cy="483.320" r="35.000" fill="hsl(224 94% 61%)" opacity="0.209"/>+<circle cx="753.960" cy="483.320" r="35.000" fill="hsl(216 94% 61%)" opacity="0.199"/>+<circle cx="788.300" cy="483.320" r="35.000" fill="hsl(214 94% 61%)" opacity="0.196"/>+<circle cx="822.640" cy="483.320" r="35.000" fill="hsl(223 94% 61%)" opacity="0.207"/>+<circle cx="856.980" cy="483.320" r="35.000" fill="hsl(234 94% 61%)" opacity="0.220"/>+<circle cx="891.320" cy="483.320" r="35.000" fill="hsl(246 94% 61%)" opacity="0.237"/>+<circle cx="925.660" cy="483.320" r="35.000" fill="hsl(263 94% 61%)" opacity="0.257"/>+<circle cx="960.000" cy="483.320" r="35.000" fill="hsl(279 94% 61%)" opacity="0.278"/>+<circle cx="994.340" cy="483.320" r="35.000" fill="hsl(292 94% 61%)" opacity="0.294"/>+<circle cx="1028.680" cy="483.320" r="35.000" fill="hsl(297 94% 61%)" opacity="0.301"/>+<circle cx="1063.020" cy="483.320" r="35.000" fill="hsl(296 94% 61%)" opacity="0.299"/>+<circle cx="1097.360" cy="483.320" r="35.000" fill="hsl(291 94% 61%)" opacity="0.293"/>+<circle cx="1131.700" cy="483.320" r="34.000" fill="hsl(283 94% 61%)" opacity="0.283"/>+<circle cx="1166.040" cy="483.320" r="35.000" fill="hsl(267 94% 61%)" opacity="0.262"/>+<circle cx="1200.380" cy="483.320" r="35.000" fill="hsl(251 94% 61%)" opacity="0.242"/>+<circle cx="1234.720" cy="483.320" r="35.000" fill="hsl(238 94% 61%)" opacity="0.226"/>+<circle cx="1269.060" cy="483.320" r="35.000" fill="hsl(229 94% 61%)" opacity="0.215"/>+<circle cx="1303.400" cy="483.320" r="35.000" fill="hsl(226 94% 61%)" opacity="0.210"/>+<circle cx="1337.740" cy="483.320" r="35.000" fill="hsl(227 94% 61%)" opacity="0.212"/>+<circle cx="582.260" cy="517.660" r="35.000" fill="hsl(253 94% 61%)" opacity="0.245"/>+<circle cx="616.600" cy="517.660" r="35.000" fill="hsl(255 94% 61%)" opacity="0.247"/>+<circle cx="650.940" cy="517.660" r="35.000" fill="hsl(252 94% 61%)" opacity="0.244"/>+<circle cx="685.280" cy="517.660" r="35.000" fill="hsl(246 94% 61%)" opacity="0.236"/>+<circle cx="719.620" cy="517.660" r="35.000" fill="hsl(237 94% 61%)" opacity="0.225"/>+<circle cx="753.960" cy="517.660" r="35.000" fill="hsl(230 94% 61%)" opacity="0.216"/>+<circle cx="788.300" cy="517.660" r="35.000" fill="hsl(226 94% 61%)" opacity="0.210"/>+<circle cx="822.640" cy="517.660" r="34.000" fill="hsl(227 94% 61%)" opacity="0.212"/>+<circle cx="856.980" cy="517.660" r="35.000" fill="hsl(234 94% 61%)" opacity="0.221"/>+<circle cx="891.320" cy="517.660" r="35.000" fill="hsl(247 94% 61%)" opacity="0.237"/>+<circle cx="925.660" cy="517.660" r="35.000" fill="hsl(261 94% 61%)" opacity="0.256"/>+<circle cx="960.000" cy="517.660" r="35.000" fill="hsl(276 94% 61%)" opacity="0.274"/>+<circle cx="994.340" cy="517.660" r="35.000" fill="hsl(290 94% 61%)" opacity="0.292"/>+<circle cx="1028.680" cy="517.660" r="33.000" fill="hsl(299 94% 61%)" opacity="0.303"/>+<circle cx="1063.020" cy="517.660" r="34.000" fill="hsl(301 94% 61%)" opacity="0.306"/>+<circle cx="1097.360" cy="517.660" r="34.000" fill="hsl(296 94% 61%)" opacity="0.300"/>+<circle cx="1131.700" cy="517.660" r="35.000" fill="hsl(284 94% 61%)" opacity="0.285"/>+<circle cx="1166.040" cy="517.660" r="34.000" fill="hsl(268 94% 61%)" opacity="0.265"/>+<circle cx="1200.380" cy="517.660" r="35.000" fill="hsl(251 94% 61%)" opacity="0.243"/>+<circle cx="1234.720" cy="517.660" r="35.000" fill="hsl(236 94% 61%)" opacity="0.223"/>+<circle cx="1269.060" cy="517.660" r="35.000" fill="hsl(224 94% 61%)" opacity="0.209"/>+<circle cx="1303.400" cy="517.660" r="35.000" fill="hsl(219 94% 61%)" opacity="0.201"/>+<circle cx="1337.740" cy="517.660" r="35.000" fill="hsl(219 94% 61%)" opacity="0.201"/>+<circle cx="582.260" cy="552.000" r="35.000" fill="hsl(259 94% 61%)" opacity="0.252"/>+<circle cx="616.600" cy="552.000" r="35.000" fill="hsl(264 94% 61%)" opacity="0.259"/>+<circle cx="650.940" cy="552.000" r="35.000" fill="hsl(264 94% 61%)" opacity="0.259"/>+<circle cx="685.280" cy="552.000" r="35.000" fill="hsl(259 94% 61%)" opacity="0.253"/>+<circle cx="719.620" cy="552.000" r="35.000" fill="hsl(251 94% 61%)" opacity="0.242"/>+<circle cx="753.960" cy="552.000" r="35.000" fill="hsl(242 94% 61%)" opacity="0.231"/>+<circle cx="788.300" cy="552.000" r="35.000" fill="hsl(236 94% 61%)" opacity="0.224"/>+<circle cx="822.640" cy="552.000" r="35.000" fill="hsl(234 94% 61%)" opacity="0.221"/>+<circle cx="856.980" cy="552.000" r="35.000" fill="hsl(238 94% 61%)" opacity="0.225"/>+<circle cx="891.320" cy="552.000" r="35.000" fill="hsl(246 94% 61%)" opacity="0.237"/>+<circle cx="925.660" cy="552.000" r="35.000" fill="hsl(258 94% 61%)" opacity="0.252"/>+<circle cx="960.000" cy="552.000" r="35.000" fill="hsl(272 94% 61%)" opacity="0.269"/>+<circle cx="994.340" cy="552.000" r="35.000" fill="hsl(283 94% 61%)" opacity="0.283"/>+<circle cx="1028.680" cy="552.000" r="35.000" fill="hsl(293 94% 61%)" opacity="0.296"/>+<circle cx="1063.020" cy="552.000" r="35.000" fill="hsl(295 94% 61%)" opacity="0.298"/>+<circle cx="1097.360" cy="552.000" r="35.000" fill="hsl(290 94% 61%)" opacity="0.293"/>+<circle cx="1131.700" cy="552.000" r="35.000" fill="hsl(282 94% 61%)" opacity="0.281"/>+<circle cx="1166.040" cy="552.000" r="35.000" fill="hsl(269 94% 61%)" opacity="0.265"/>+<circle cx="1200.380" cy="552.000" r="35.000" fill="hsl(252 94% 61%)" opacity="0.244"/>+<circle cx="1234.720" cy="552.000" r="35.000" fill="hsl(235 94% 61%)" opacity="0.222"/>+<circle cx="1269.060" cy="552.000" r="35.000" fill="hsl(220 94% 61%)" opacity="0.203"/>+<circle cx="1303.400" cy="552.000" r="35.000" fill="hsl(211 94% 61%)" opacity="0.192"/>+<circle cx="1337.740" cy="552.000" r="35.000" fill="hsl(209 94% 61%)" opacity="0.190"/>+<circle cx="547.920" cy="586.340" r="35.000" fill="hsl(253 94% 61%)" opacity="0.245"/>+<circle cx="582.260" cy="586.340" r="34.000" fill="hsl(268 94% 61%)" opacity="0.264"/>+<circle cx="616.600" cy="586.340" r="35.000" fill="hsl(275 94% 61%)" opacity="0.273"/>+<circle cx="650.940" cy="586.340" r="35.000" fill="hsl(275 94% 61%)" opacity="0.273"/>+<circle cx="685.280" cy="586.340" r="35.000" fill="hsl(271 94% 61%)" opacity="0.267"/>+<circle cx="719.620" cy="586.340" r="35.000" fill="hsl(263 94% 61%)" opacity="0.258"/>+<circle cx="753.960" cy="586.340" r="35.000" fill="hsl(254 94% 61%)" opacity="0.247"/>+<circle cx="788.300" cy="586.340" r="35.000" fill="hsl(246 94% 61%)" opacity="0.237"/>+<circle cx="822.640" cy="586.340" r="35.000" fill="hsl(241 94% 61%)" opacity="0.230"/>+<circle cx="856.980" cy="586.340" r="35.000" fill="hsl(240 94% 61%)" opacity="0.229"/>+<circle cx="891.320" cy="586.340" r="35.000" fill="hsl(244 94% 61%)" opacity="0.234"/>+<circle cx="925.660" cy="586.340" r="34.000" fill="hsl(252 94% 61%)" opacity="0.244"/>+<circle cx="960.000" cy="586.340" r="35.000" fill="hsl(262 94% 61%)" opacity="0.256"/>+<circle cx="994.340" cy="586.340" r="35.000" fill="hsl(273 94% 61%)" opacity="0.270"/>+<circle cx="1028.680" cy="586.340" r="35.000" fill="hsl(283 94% 61%)" opacity="0.283"/>+<circle cx="1063.020" cy="586.340" r="35.000" fill="hsl(284 94% 61%)" opacity="0.285"/>+<circle cx="1097.360" cy="586.340" r="35.000" fill="hsl(281 94% 61%)" opacity="0.281"/>+<circle cx="1131.700" cy="586.340" r="35.000" fill="hsl(275 94% 61%)" opacity="0.273"/>+<circle cx="1166.040" cy="586.340" r="35.000" fill="hsl(264 94% 61%)" opacity="0.259"/>+<circle cx="1200.380" cy="586.340" r="35.000" fill="hsl(250 94% 61%)" opacity="0.242"/>+<circle cx="1234.720" cy="586.340" r="35.000" fill="hsl(235 94% 61%)" opacity="0.223"/>+<circle cx="1269.060" cy="586.340" r="35.000" fill="hsl(220 94% 61%)" opacity="0.204"/>+<circle cx="1303.400" cy="586.340" r="35.000" fill="hsl(207 94% 61%)" opacity="0.187"/>+<circle cx="1337.740" cy="586.340" r="35.000" fill="hsl(200 94% 61%)" opacity="0.177"/>+<circle cx="1372.080" cy="586.340" r="35.000" fill="hsl(207 94% 61%)" opacity="0.186"/>+<circle cx="547.920" cy="620.680" r="35.000" fill="hsl(259 94% 61%)" opacity="0.252"/>+<circle cx="582.260" cy="620.680" r="35.000" fill="hsl(272 94% 61%)" opacity="0.269"/>+<circle cx="616.600" cy="620.680" r="35.000" fill="hsl(280 94% 61%)" opacity="0.280"/>+<circle cx="650.940" cy="620.680" r="35.000" fill="hsl(284 94% 61%)" opacity="0.284"/>+<circle cx="685.280" cy="620.680" r="35.000" fill="hsl(282 94% 61%)" opacity="0.281"/>+<circle cx="719.620" cy="620.680" r="35.000" fill="hsl(275 94% 61%)" opacity="0.273"/>+<circle cx="753.960" cy="620.680" r="35.000" fill="hsl(266 94% 61%)" opacity="0.262"/>+<circle cx="788.300" cy="620.680" r="35.000" fill="hsl(257 94% 61%)" opacity="0.250"/>+<circle cx="822.640" cy="620.680" r="35.000" fill="hsl(248 94% 61%)" opacity="0.239"/>+<circle cx="856.980" cy="620.680" r="33.000" fill="hsl(243 94% 61%)" opacity="0.232"/>+<circle cx="891.320" cy="620.680" r="35.000" fill="hsl(240 94% 61%)" opacity="0.229"/>+<circle cx="925.660" cy="620.680" r="35.000" fill="hsl(244 94% 61%)" opacity="0.233"/>+<circle cx="960.000" cy="620.680" r="35.000" fill="hsl(251 94% 61%)" opacity="0.242"/>+<circle cx="994.340" cy="620.680" r="35.000" fill="hsl(260 94% 61%)" opacity="0.254"/>+<circle cx="1028.680" cy="620.680" r="34.000" fill="hsl(268 94% 61%)" opacity="0.265"/>+<circle cx="1063.020" cy="620.680" r="35.000" fill="hsl(275 94% 61%)" opacity="0.273"/>+<circle cx="1097.360" cy="620.680" r="35.000" fill="hsl(274 94% 61%)" opacity="0.272"/>+<circle cx="1131.700" cy="620.680" r="35.000" fill="hsl(270 94% 61%)" opacity="0.266"/>+<circle cx="1166.040" cy="620.680" r="35.000" fill="hsl(261 94% 61%)" opacity="0.255"/>+<circle cx="1200.380" cy="620.680" r="35.000" fill="hsl(250 94% 61%)" opacity="0.241"/>+<circle cx="1234.720" cy="620.680" r="35.000" fill="hsl(236 94% 61%)" opacity="0.224"/>+<circle cx="1269.060" cy="620.680" r="35.000" fill="hsl(223 94% 61%)" opacity="0.207"/>+<circle cx="1303.400" cy="620.680" r="35.000" fill="hsl(212 94% 61%)" opacity="0.192"/>+<circle cx="1337.740" cy="620.680" r="35.000" fill="hsl(203 94% 61%)" opacity="0.181"/>+<circle cx="1372.080" cy="620.680" r="35.000" fill="hsl(198 94% 61%)" opacity="0.175"/>+<circle cx="547.920" cy="655.020" r="35.000" fill="hsl(261 94% 61%)" opacity="0.255"/>+<circle cx="582.260" cy="655.020" r="35.000" fill="hsl(275 94% 61%)" opacity="0.274"/>+<circle cx="616.600" cy="655.020" r="35.000" fill="hsl(286 94% 61%)" opacity="0.287"/>+<circle cx="650.940" cy="655.020" r="35.000" fill="hsl(293 94% 61%)" opacity="0.295"/>+<circle cx="685.280" cy="655.020" r="35.000" fill="hsl(293 94% 61%)" opacity="0.296"/>+<circle cx="719.620" cy="655.020" r="35.000" fill="hsl(288 94% 61%)" opacity="0.290"/>+<circle cx="753.960" cy="655.020" r="35.000" fill="hsl(279 94% 61%)" opacity="0.278"/>+<circle cx="788.300" cy="655.020" r="35.000" fill="hsl(266 94% 61%)" opacity="0.261"/>+<circle cx="822.640" cy="655.020" r="35.000" fill="hsl(252 94% 61%)" opacity="0.244"/>+<circle cx="856.980" cy="655.020" r="34.000" fill="hsl(242 94% 61%)" opacity="0.232"/>+<circle cx="891.320" cy="655.020" r="35.000" fill="hsl(237 94% 61%)" opacity="0.224"/>+<circle cx="925.660" cy="655.020" r="35.000" fill="hsl(234 94% 61%)" opacity="0.221"/>+<circle cx="960.000" cy="655.020" r="34.000" fill="hsl(237 94% 61%)" opacity="0.225"/>+<circle cx="994.340" cy="655.020" r="35.000" fill="hsl(245 94% 61%)" opacity="0.234"/>+<circle cx="1028.680" cy="655.020" r="35.000" fill="hsl(253 94% 61%)" opacity="0.245"/>+<circle cx="1063.020" cy="655.020" r="34.000" fill="hsl(260 94% 61%)" opacity="0.254"/>+<circle cx="1097.360" cy="655.020" r="35.000" fill="hsl(264 94% 61%)" opacity="0.259"/>+<circle cx="1131.700" cy="655.020" r="34.000" fill="hsl(263 94% 61%)" opacity="0.258"/>+<circle cx="1166.040" cy="655.020" r="35.000" fill="hsl(260 94% 61%)" opacity="0.254"/>+<circle cx="1200.380" cy="655.020" r="35.000" fill="hsl(250 94% 61%)" opacity="0.241"/>+<circle cx="1234.720" cy="655.020" r="35.000" fill="hsl(238 94% 61%)" opacity="0.226"/>+<circle cx="1269.060" cy="655.020" r="35.000" fill="hsl(226 94% 61%)" opacity="0.211"/>+<circle cx="1303.400" cy="655.020" r="35.000" fill="hsl(215 94% 61%)" opacity="0.197"/>+<circle cx="1337.740" cy="655.020" r="35.000" fill="hsl(206 94% 61%)" opacity="0.186"/>+<circle cx="1372.080" cy="655.020" r="35.000" fill="hsl(201 94% 61%)" opacity="0.179"/>+<circle cx="582.260" cy="689.360" r="35.000" fill="hsl(272 94% 61%)" opacity="0.269"/>+<circle cx="616.600" cy="689.360" r="35.000" fill="hsl(287 94% 61%)" opacity="0.288"/>+<circle cx="650.940" cy="689.360" r="35.000" fill="hsl(294 94% 61%)" opacity="0.297"/>+<circle cx="685.280" cy="689.360" r="35.000" fill="hsl(295 94% 61%)" opacity="0.298"/>+<circle cx="719.620" cy="689.360" r="35.000" fill="hsl(290 94% 61%)" opacity="0.292"/>+<circle cx="753.960" cy="689.360" r="35.000" fill="hsl(280 94% 61%)" opacity="0.279"/>+<circle cx="788.300" cy="689.360" r="35.000" fill="hsl(267 94% 61%)" opacity="0.263"/>+<circle cx="822.640" cy="689.360" r="34.000" fill="hsl(254 94% 61%)" opacity="0.246"/>+<circle cx="856.980" cy="689.360" r="35.000" fill="hsl(241 94% 61%)" opacity="0.230"/>+<circle cx="891.320" cy="689.360" r="35.000" fill="hsl(232 94% 61%)" opacity="0.218"/>+<circle cx="925.660" cy="689.360" r="35.000" fill="hsl(225 94% 61%)" opacity="0.210"/>+<circle cx="960.000" cy="689.360" r="34.000" fill="hsl(224 94% 61%)" opacity="0.208"/>+<circle cx="994.340" cy="689.360" r="35.000" fill="hsl(230 94% 61%)" opacity="0.215"/>+<circle cx="1028.680" cy="689.360" r="35.000" fill="hsl(238 94% 61%)" opacity="0.226"/>+<circle cx="1063.020" cy="689.360" r="35.000" fill="hsl(246 94% 61%)" opacity="0.236"/>+<circle cx="1097.360" cy="689.360" r="35.000" fill="hsl(252 94% 61%)" opacity="0.244"/>+<circle cx="1131.700" cy="689.360" r="35.000" fill="hsl(254 94% 61%)" opacity="0.246"/>+<circle cx="1166.040" cy="689.360" r="35.000" fill="hsl(251 94% 61%)" opacity="0.243"/>+<circle cx="1200.380" cy="689.360" r="35.000" fill="hsl(245 94% 61%)" opacity="0.235"/>+<circle cx="1234.720" cy="689.360" r="35.000" fill="hsl(237 94% 61%)" opacity="0.225"/>+<circle cx="1269.060" cy="689.360" r="35.000" fill="hsl(228 94% 61%)" opacity="0.213"/>+<circle cx="1303.400" cy="689.360" r="35.000" fill="hsl(218 94% 61%)" opacity="0.201"/>+<circle cx="1337.740" cy="689.360" r="35.000" fill="hsl(210 94% 61%)" opacity="0.191"/>+<circle cx="616.600" cy="723.700" r="35.000" fill="hsl(271 94% 61%)" opacity="0.268"/>+<circle cx="650.940" cy="723.700" r="35.000" fill="hsl(281 94% 61%)" opacity="0.281"/>+<circle cx="685.280" cy="723.700" r="35.000" fill="hsl(286 94% 61%)" opacity="0.287"/>+<circle cx="719.620" cy="723.700" r="35.000" fill="hsl(285 94% 61%)" opacity="0.285"/>+<circle cx="753.960" cy="723.700" r="35.000" fill="hsl(279 94% 61%)" opacity="0.278"/>+<circle cx="788.300" cy="723.700" r="35.000" fill="hsl(268 94% 61%)" opacity="0.265"/>+<circle cx="822.640" cy="723.700" r="35.000" fill="hsl(255 94% 61%)" opacity="0.247"/>+<circle cx="856.980" cy="723.700" r="35.000" fill="hsl(240 94% 61%)" opacity="0.228"/>+<circle cx="891.320" cy="723.700" r="35.000" fill="hsl(227 94% 61%)" opacity="0.212"/>+<circle cx="925.660" cy="723.700" r="35.000" fill="hsl(216 94% 61%)" opacity="0.198"/>+<circle cx="960.000" cy="723.700" r="35.000" fill="hsl(213 94% 61%)" opacity="0.195"/>+<circle cx="994.340" cy="723.700" r="35.000" fill="hsl(216 94% 61%)" opacity="0.198"/>+<circle cx="1028.680" cy="723.700" r="35.000" fill="hsl(225 94% 61%)" opacity="0.210"/>+<circle cx="1063.020" cy="723.700" r="35.000" fill="hsl(234 94% 61%)" opacity="0.221"/>+<circle cx="1097.360" cy="723.700" r="35.000" fill="hsl(244 94% 61%)" opacity="0.234"/>+<circle cx="1131.700" cy="723.700" r="35.000" fill="hsl(248 94% 61%)" opacity="0.238"/>+<circle cx="1166.040" cy="723.700" r="35.000" fill="hsl(247 94% 61%)" opacity="0.237"/>+<circle cx="1200.380" cy="723.700" r="35.000" fill="hsl(243 94% 61%)" opacity="0.232"/>+<circle cx="1234.720" cy="723.700" r="35.000" fill="hsl(236 94% 61%)" opacity="0.224"/>+<circle cx="1269.060" cy="723.700" r="35.000" fill="hsl(229 94% 61%)" opacity="0.214"/>+<circle cx="1303.400" cy="723.700" r="35.000" fill="hsl(221 94% 61%)" opacity="0.205"/>+<circle cx="616.600" cy="758.040" r="35.000" fill="hsl(255 94% 61%)" opacity="0.247"/>+<circle cx="650.940" cy="758.040" r="35.000" fill="hsl(269 94% 61%)" opacity="0.266"/>+<circle cx="685.280" cy="758.040" r="35.000" fill="hsl(277 94% 61%)" opacity="0.275"/>+<circle cx="719.620" cy="758.040" r="35.000" fill="hsl(279 94% 61%)" opacity="0.278"/>+<circle cx="753.960" cy="758.040" r="35.000" fill="hsl(276 94% 61%)" opacity="0.274"/>+<circle cx="788.300" cy="758.040" r="35.000" fill="hsl(269 94% 61%)" opacity="0.265"/>+<circle cx="822.640" cy="758.040" r="35.000" fill="hsl(254 94% 61%)" opacity="0.246"/>+<circle cx="856.980" cy="758.040" r="35.000" fill="hsl(238 94% 61%)" opacity="0.226"/>+<circle cx="891.320" cy="758.040" r="35.000" fill="hsl(222 94% 61%)" opacity="0.206"/>+<circle cx="925.660" cy="758.040" r="35.000" fill="hsl(209 94% 61%)" opacity="0.189"/>+<circle cx="960.000" cy="758.040" r="35.000" fill="hsl(207 94% 61%)" opacity="0.187"/>+<circle cx="994.340" cy="758.040" r="35.000" fill="hsl(205 94% 61%)" opacity="0.184"/>+<circle cx="1028.680" cy="758.040" r="35.000" fill="hsl(214 94% 61%)" opacity="0.196"/>+<circle cx="1063.020" cy="758.040" r="35.000" fill="hsl(226 94% 61%)" opacity="0.210"/>+<circle cx="1097.360" cy="758.040" r="35.000" fill="hsl(237 94% 61%)" opacity="0.224"/>+<circle cx="1131.700" cy="758.040" r="34.000" fill="hsl(246 94% 61%)" opacity="0.236"/>+<circle cx="1166.040" cy="758.040" r="35.000" fill="hsl(247 94% 61%)" opacity="0.237"/>+<circle cx="1200.380" cy="758.040" r="35.000" fill="hsl(244 94% 61%)" opacity="0.233"/>+<circle cx="1234.720" cy="758.040" r="35.000" fill="hsl(238 94% 61%)" opacity="0.226"/>+<circle cx="1269.060" cy="758.040" r="35.000" fill="hsl(231 94% 61%)" opacity="0.218"/>+<circle cx="650.940" cy="792.380" r="35.000" fill="hsl(256 94% 61%)" opacity="0.249"/>+<circle cx="685.280" cy="792.380" r="35.000" fill="hsl(267 94% 61%)" opacity="0.263"/>+<circle cx="719.620" cy="792.380" r="35.000" fill="hsl(272 94% 61%)" opacity="0.270"/>+<circle cx="753.960" cy="792.380" r="35.000" fill="hsl(273 94% 61%)" opacity="0.270"/>+<circle cx="788.300" cy="792.380" r="34.000" fill="hsl(266 94% 61%)" opacity="0.262"/>+<circle cx="822.640" cy="792.380" r="35.000" fill="hsl(252 94% 61%)" opacity="0.244"/>+<circle cx="856.980" cy="792.380" r="35.000" fill="hsl(237 94% 61%)" opacity="0.224"/>+<circle cx="891.320" cy="792.380" r="35.000" fill="hsl(220 94% 61%)" opacity="0.203"/>+<circle cx="925.660" cy="792.380" r="35.000" fill="hsl(211 94% 61%)" opacity="0.191"/>+<circle cx="960.000" cy="792.380" r="35.000" fill="hsl(207 94% 61%)" opacity="0.187"/>+<circle cx="994.340" cy="792.380" r="35.000" fill="hsl(203 94% 61%)" opacity="0.182"/>+<circle cx="1028.680" cy="792.380" r="35.000" fill="hsl(207 94% 61%)" opacity="0.186"/>+<circle cx="1063.020" cy="792.380" r="35.000" fill="hsl(220 94% 61%)" opacity="0.203"/>+<circle cx="1097.360" cy="792.380" r="35.000" fill="hsl(233 94% 61%)" opacity="0.220"/>+<circle cx="1131.700" cy="792.380" r="35.000" fill="hsl(246 94% 61%)" opacity="0.236"/>+<circle cx="1166.040" cy="792.380" r="35.000" fill="hsl(250 94% 61%)" opacity="0.241"/>+<circle cx="1200.380" cy="792.380" r="35.000" fill="hsl(247 94% 61%)" opacity="0.238"/>+<circle cx="1234.720" cy="792.380" r="35.000" fill="hsl(241 94% 61%)" opacity="0.230"/>+<circle cx="1269.060" cy="792.380" r="35.000" fill="hsl(232 94% 61%)" opacity="0.219"/>+<circle cx="685.280" cy="826.720" r="35.000" fill="hsl(257 94% 61%)" opacity="0.251"/>+<circle cx="719.620" cy="826.720" r="35.000" fill="hsl(265 94% 61%)" opacity="0.261"/>+<circle cx="753.960" cy="826.720" r="35.000" fill="hsl(268 94% 61%)" opacity="0.264"/>+<circle cx="788.300" cy="826.720" r="35.000" fill="hsl(262 94% 61%)" opacity="0.257"/>+<circle cx="822.640" cy="826.720" r="35.000" fill="hsl(251 94% 61%)" opacity="0.242"/>+<circle cx="856.980" cy="826.720" r="35.000" fill="hsl(237 94% 61%)" opacity="0.225"/>+<circle cx="891.320" cy="826.720" r="34.000" fill="hsl(221 94% 61%)" opacity="0.205"/>+<circle cx="925.660" cy="826.720" r="35.000" fill="hsl(217 94% 61%)" opacity="0.199"/>+<circle cx="960.000" cy="826.720" r="35.000" fill="hsl(213 94% 61%)" opacity="0.194"/>+<circle cx="994.340" cy="826.720" r="35.000" fill="hsl(208 94% 61%)" opacity="0.188"/>+<circle cx="1028.680" cy="826.720" r="34.000" fill="hsl(203 94% 61%)" opacity="0.181"/>+<circle cx="1063.020" cy="826.720" r="35.000" fill="hsl(217 94% 61%)" opacity="0.199"/>+<circle cx="1097.360" cy="826.720" r="35.000" fill="hsl(232 94% 61%)" opacity="0.218"/>+<circle cx="1131.700" cy="826.720" r="35.000" fill="hsl(247 94% 61%)" opacity="0.237"/>+<circle cx="1166.040" cy="826.720" r="35.000" fill="hsl(255 94% 61%)" opacity="0.248"/>+<circle cx="1200.380" cy="826.720" r="35.000" fill="hsl(251 94% 61%)" opacity="0.243"/>+<circle cx="1234.720" cy="826.720" r="35.000" fill="hsl(242 94% 61%)" opacity="0.232"/>+<circle cx="719.620" cy="861.060" r="35.000" fill="hsl(257 94% 61%)" opacity="0.251"/>+<circle cx="753.960" cy="861.060" r="35.000" fill="hsl(263 94% 61%)" opacity="0.257"/>+<circle cx="788.300" cy="861.060" r="35.000" fill="hsl(259 94% 61%)" opacity="0.253"/>+<circle cx="822.640" cy="861.060" r="35.000" fill="hsl(251 94% 61%)" opacity="0.242"/>+<circle cx="856.980" cy="861.060" r="35.000" fill="hsl(240 94% 61%)" opacity="0.228"/>+<circle cx="891.320" cy="861.060" r="35.000" fill="hsl(231 94% 61%)" opacity="0.217"/>+<circle cx="925.660" cy="861.060" r="35.000" fill="hsl(227 94% 61%)" opacity="0.212"/>+<circle cx="960.000" cy="861.060" r="35.000" fill="hsl(223 94% 61%)" opacity="0.206"/>+<circle cx="994.340" cy="861.060" r="35.000" fill="hsl(218 94% 61%)" opacity="0.201"/>+<circle cx="1028.680" cy="861.060" r="35.000" fill="hsl(213 94% 61%)" opacity="0.194"/>+<circle cx="1063.020" cy="861.060" r="35.000" fill="hsl(217 94% 61%)" opacity="0.199"/>+<circle cx="1097.360" cy="861.060" r="35.000" fill="hsl(232 94% 61%)" opacity="0.219"/>+<circle cx="1131.700" cy="861.060" r="35.000" fill="hsl(248 94% 61%)" opacity="0.239"/>+<circle cx="1166.040" cy="861.060" r="35.000" fill="hsl(262 94% 61%)" opacity="0.257"/>+<circle cx="1200.380" cy="861.060" r="35.000" fill="hsl(254 94% 61%)" opacity="0.246"/>+<circle cx="753.960" cy="895.400" r="35.000" fill="hsl(256 94% 61%)" opacity="0.248"/>+<circle cx="788.300" cy="895.400" r="35.000" fill="hsl(256 94% 61%)" opacity="0.249"/>+<circle cx="822.640" cy="895.400" r="35.000" fill="hsl(253 94% 61%)" opacity="0.245"/>+<circle cx="856.980" cy="895.400" r="35.000" fill="hsl(246 94% 61%)" opacity="0.236"/>+<circle cx="891.320" cy="895.400" r="35.000" fill="hsl(242 94% 61%)" opacity="0.231"/>+<circle cx="925.660" cy="895.400" r="35.000" fill="hsl(238 94% 61%)" opacity="0.226"/>+<circle cx="960.000" cy="895.400" r="35.000" fill="hsl(234 94% 61%)" opacity="0.221"/>+<circle cx="994.340" cy="895.400" r="35.000" fill="hsl(231 94% 61%)" opacity="0.217"/>+<circle cx="1028.680" cy="895.400" r="35.000" fill="hsl(227 94% 61%)" opacity="0.212"/>+<circle cx="1063.020" cy="895.400" r="35.000" fill="hsl(222 94% 61%)" opacity="0.206"/>+<circle cx="1097.360" cy="895.400" r="35.000" fill="hsl(234 94% 61%)" opacity="0.221"/>+<circle cx="1131.700" cy="895.400" r="35.000" fill="hsl(250 94% 61%)" opacity="0.241"/>+<circle cx="1166.040" cy="895.400" r="35.000" fill="hsl(266 94% 61%)" opacity="0.261"/>+<circle cx="753.960" cy="929.740" r="34.000" fill="hsl(251 94% 61%)" opacity="0.243"/>+<circle cx="788.300" cy="929.740" r="35.000" fill="hsl(256 94% 61%)" opacity="0.248"/>+<circle cx="822.640" cy="929.740" r="34.000" fill="hsl(257 94% 61%)" opacity="0.250"/>+<circle cx="856.980" cy="929.740" r="35.000" fill="hsl(253 94% 61%)" opacity="0.246"/>+<circle cx="891.320" cy="929.740" r="35.000" fill="hsl(250 94% 61%)" opacity="0.242"/>+<circle cx="925.660" cy="929.740" r="35.000" fill="hsl(248 94% 61%)" opacity="0.239"/>+<circle cx="960.000" cy="929.740" r="35.000" fill="hsl(246 94% 61%)" opacity="0.236"/>+<circle cx="994.340" cy="929.740" r="35.000" fill="hsl(244 94% 61%)" opacity="0.234"/>+<circle cx="1028.680" cy="929.740" r="35.000" fill="hsl(242 94% 61%)" opacity="0.231"/>+<circle cx="1063.020" cy="929.740" r="35.000" fill="hsl(240 94% 61%)" opacity="0.228"/>+<circle cx="1097.360" cy="929.740" r="35.000" fill="hsl(236 94% 61%)" opacity="0.223"/>+<circle cx="1131.700" cy="929.740" r="35.000" fill="hsl(250 94% 61%)" opacity="0.241"/>+<circle cx="1166.040" cy="929.740" r="34.000" fill="hsl(262 94% 61%)" opacity="0.257"/>+</g>+<g opacity="0.58"><line x1="983.332" y1="534.766" x2="973.544" y2="526.349" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="988.499" y1="546.596" x2="983.332" y2="534.766" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="983.332" y1="534.766" x2="1006.907" y2="517.352" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="981.994" y1="570.912" x2="988.022" y2="559.496" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="988.022" y1="559.496" x2="988.499" y2="546.596" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1016.824" y1="567.202" x2="988.022" y2="559.496" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="988.499" y1="546.596" x2="1027.405" y2="539.218" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="991.808" y1="491.757" x2="973.544" y2="526.349" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="973.544" y1="526.349" x2="961.073" y2="523.013" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="962.146" y1="494.029" x2="961.073" y2="523.013" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="961.073" y1="523.013" x2="948.390" y2="525.418" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="971.610" y1="578.582" x2="981.994" y2="570.912" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="981.994" y1="570.912" x2="1012.465" y2="597.114" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="932.876" y1="489.898" x2="948.390" y2="525.418" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="948.390" y1="525.418" x2="938.006" y2="533.088" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="958.927" y1="580.987" x2="971.610" y2="578.582" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="971.610" y1="578.582" x2="983.824" y2="606.545" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="913.124" y1="511.692" x2="938.006" y2="533.088" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="938.006" y1="533.088" x2="931.978" y2="544.504" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="946.456" y1="577.651" x2="958.927" y2="580.987" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="958.927" y1="580.987" x2="957.415" y2="621.827" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="890.959" y1="533.530" x2="931.978" y2="544.504" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="931.978" y1="544.504" x2="931.501" y2="557.404" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="936.668" y1="569.234" x2="931.501" y2="557.404" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="899.643" y1="563.445" x2="931.501" y2="557.404" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="936.668" y1="569.234" x2="946.456" y2="577.651" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="903.183" y1="593.968" x2="936.668" y2="569.234" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="946.456" y1="577.651" x2="931.800" y2="605.409" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="972.412" y1="484.686" x2="962.146" y2="494.029" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="962.146" y1="494.029" x2="947.830" y2="484.058" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1018.788" y1="518.699" x2="1006.907" y2="517.352" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1006.907" y1="517.352" x2="1004.363" y2="498.501" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1016.824" y1="567.202" x2="1029.925" y2="551.208" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1029.925" y1="551.208" x2="1027.405" y2="539.218" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1022.389" y1="575.335" x2="1016.824" y2="567.202" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="983.824" y1="606.545" x2="1006.276" y2="604.953" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1006.276" y1="604.953" x2="1012.465" y2="597.114" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="981.859" y1="613.815" x2="983.824" y2="606.545" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="927.316" y1="607.504" x2="931.800" y2="605.409" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="931.800" y1="605.409" x2="950.032" y2="621.996" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="897.765" y1="562.566" x2="899.643" y2="563.445" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="899.643" y1="563.445" x2="900.347" y2="590.671" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="912.015" y1="511.701" x2="913.124" y2="511.692" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="912.015" y1="511.701" x2="891.092" y2="532.785" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="926.036" y1="486.913" x2="932.876" y2="489.898" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="926.036" y1="486.913" x2="913.124" y2="511.692" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="879.746" y1="488.235" x2="912.015" y2="511.701" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="888.385" y1="535.872" x2="897.765" y2="562.566" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="897.765" y1="562.566" x2="861.003" y2="574.923" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="903.269" y1="597.046" x2="927.316" y2="607.504" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="927.316" y1="607.504" x2="916.556" y2="643.053" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="959.674" y1="623.670" x2="981.859" y2="613.815" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="981.859" y1="613.815" x2="1003.828" y2="642.233" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1015.388" y1="596.606" x2="1022.389" y2="575.335" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1022.389" y1="575.335" x2="1057.456" y2="573.982" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1029.059" y1="536.487" x2="1018.788" y2="518.699" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1018.788" y1="518.699" x2="1037.830" y2="489.758" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="990.734" y1="488.378" x2="991.808" y2="491.757" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="990.734" y1="488.378" x2="972.412" y2="484.686" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="452.426" x2="972.412" y2="484.686" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="452.426" x2="947.830" y2="484.058" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="947.830" y1="484.058" x2="932.876" y2="489.898" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="924.801" y1="485.323" x2="926.036" y2="486.913" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1037.830" y1="489.758" x2="1004.363" y2="498.501" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1004.363" y1="498.501" x2="991.808" y2="491.757" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="998.095" y1="470.935" x2="990.734" y2="488.378" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1057.456" y1="573.982" x2="1029.925" y2="551.208" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1027.405" y1="539.218" x2="1029.059" y2="536.487" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1044.753" y1="530.377" x2="1029.059" y2="536.487" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1003.828" y1="642.233" x2="1006.276" y2="604.953" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1012.465" y1="597.114" x2="1015.388" y2="596.606" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1028.621" y1="602.722" x2="1015.388" y2="596.606" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="950.032" y1="621.996" x2="957.415" y2="621.827" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="957.415" y1="621.827" x2="959.674" y2="623.670" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="916.556" y1="643.053" x2="950.032" y2="621.996" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="963.524" y1="635.004" x2="959.674" y2="623.670" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="900.347" y1="590.671" x2="903.183" y2="593.968" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="903.183" y1="593.968" x2="903.269" y2="597.046" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="861.003" y1="574.923" x2="900.347" y2="590.671" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="899.115" y1="604.826" x2="903.269" y2="597.046" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="879.746" y1="488.235" x2="891.092" y2="532.785" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="891.092" y1="532.785" x2="890.959" y2="533.530" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="888.385" y1="535.872" x2="890.959" y2="533.530" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="883.649" y1="537.102" x2="888.385" y2="535.872" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="924.690" y1="468.840" x2="924.801" y2="485.323" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="924.801" y1="485.323" x2="879.076" y2="487.187" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="858.806" y1="525.718" x2="883.649" y2="537.102" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="883.649" y1="537.102" x2="858.236" y2="574.779" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="877.335" y1="612.112" x2="899.115" y2="604.826" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="899.115" y1="604.826" x2="913.901" y2="646.396" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="954.849" y1="651.750" x2="963.524" y2="635.004" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="963.524" y1="635.004" x2="1005.424" y2="647.755" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1033.065" y1="616.531" x2="1028.621" y2="602.722" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1028.621" y1="602.722" x2="1064.264" y2="576.363" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1053.303" y1="534.525" x2="1044.753" y2="530.377" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1044.753" y1="530.377" x2="1044.903" y2="484.740" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="442.292" x2="960.000" y2="442.292" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="442.292" x2="924.690" y2="468.840" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="907.607" y1="456.774" x2="924.690" y2="468.840" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1001.349" y1="469.664" x2="998.095" y2="470.935" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="998.095" y1="470.935" x2="960.000" y2="442.292" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1046.205" y1="482.726" x2="1001.349" y2="469.664" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1001.349" y1="469.664" x2="1012.440" y2="438.687" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1069.001" y1="576.148" x2="1053.303" y2="534.525" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1053.303" y1="534.525" x2="1077.607" y2="520.313" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1009.761" y1="653.301" x2="1033.065" y2="616.531" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1033.065" y1="616.531" x2="1056.813" y2="621.206" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="911.243" y1="655.315" x2="954.849" y2="651.750" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="954.849" y1="651.750" x2="966.607" y2="668.164" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="847.298" y1="578.490" x2="877.335" y2="612.112" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="877.335" y1="612.112" x2="874.824" y2="627.402" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="867.916" y1="479.092" x2="879.076" y2="487.187" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="867.916" y1="479.092" x2="858.806" y2="525.718" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="850.800" y1="531.184" x2="858.806" y2="525.718" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="912.200" y1="437.122" x2="907.607" y2="456.774" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="907.607" y1="456.774" x2="866.518" y2="476.847" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="822.234" y1="515.708" x2="850.800" y2="531.184" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="850.800" y1="531.184" x2="841.435" y2="578.126" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="847.328" y1="633.483" x2="874.824" y2="627.402" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="874.824" y1="627.402" x2="905.566" y2="662.340" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1005.424" y1="647.755" x2="1009.761" y2="653.301" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1013.053" y1="664.981" x2="1009.761" y2="653.301" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="966.607" y1="668.164" x2="1013.053" y2="664.981" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="952.990" y1="687.766" x2="966.607" y2="668.164" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1064.264" y1="576.363" x2="1069.001" y2="576.148" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1083.326" y1="581.231" x2="1069.001" y2="576.148" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1056.813" y1="621.206" x2="1083.326" y2="581.231" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1059.998" y1="639.787" x2="1056.813" y2="621.206" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1077.607" y1="520.313" x2="1061.111" y2="472.202" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1061.111" y1="472.202" x2="1046.205" y2="482.726" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1088.004" y1="527.396" x2="1077.607" y2="520.313" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="420.997" x2="960.000" y2="442.292" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="420.997" x2="912.200" y2="437.122" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="890.064" y1="422.515" x2="912.200" y2="437.122" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1016.991" y1="437.643" x2="1012.440" y2="438.687" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1012.440" y1="438.687" x2="960.000" y2="420.997" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1063.356" y1="468.620" x2="1086.418" y2="452.449" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1044.903" y1="484.740" x2="1037.830" y2="489.758" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1016.991" y1="437.643" x2="1063.356" y2="468.620" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1031.409" y1="399.015" x2="1016.991" y2="437.643" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1091.646" y1="580.750" x2="1088.004" y2="527.396" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1088.004" y1="527.396" x2="1119.190" y2="510.664" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1020.755" y1="674.626" x2="1059.998" y2="639.787" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1059.998" y1="639.787" x2="1089.392" y2="647.174" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="901.037" y1="677.977" x2="952.990" y2="687.766" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="952.990" y1="687.766" x2="966.417" y2="709.035" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="841.435" y1="578.126" x2="822.368" y2="584.702" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="822.368" y1="584.702" x2="847.328" y2="633.483" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="843.098" y1="652.260" x2="847.328" y2="633.483" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="866.518" y1="476.847" x2="867.916" y2="479.092" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="879.746" y1="488.235" x2="879.076" y2="487.187" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="847.026" y1="462.778" x2="866.518" y2="476.847" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="844.902" y1="459.236" x2="847.026" y2="462.778" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="822.234" y1="515.708" x2="847.026" y2="462.778" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="811.924" y1="521.940" x2="822.234" y2="515.708" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="892.538" y1="398.415" x2="890.064" y2="422.515" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="890.064" y1="422.515" x2="844.902" y2="459.236" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="817.477" y1="439.555" x2="844.902" y2="459.236" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="774.927" y1="505.831" x2="811.924" y2="521.940" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="811.924" y1="521.940" x2="813.251" y2="584.003" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="911.243" y1="655.315" x2="905.566" y2="662.340" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="901.037" y1="677.977" x2="905.566" y2="662.340" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="843.098" y1="652.260" x2="892.095" y2="688.774" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="811.028" y1="664.055" x2="843.098" y2="652.260" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="966.417" y1="709.035" x2="1025.682" y2="692.759" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1020.755" y1="674.626" x2="1013.053" y2="664.981" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="954.383" y1="734.417" x2="966.417" y2="709.035" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1089.392" y1="647.174" x2="1113.737" y2="588.747" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1091.646" y1="580.750" x2="1083.326" y2="581.231" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1096.731" y1="667.435" x2="1089.392" y2="647.174" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1063.356" y1="468.620" x2="1061.111" y2="472.202" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1046.205" y1="482.726" x2="1044.903" y2="484.740" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1119.190" y1="510.664" x2="1086.418" y2="452.449" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1089.518" y1="447.313" x2="1086.418" y2="452.449" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="420.997" x2="960.000" y2="420.997" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="452.426" x2="960.000" y2="442.292" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="388.149" x2="960.000" y2="420.997" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="388.149" x2="960.000" y2="388.149" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="892.538" y1="398.415" x2="960.000" y2="388.149" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="870.081" y1="377.240" x2="892.538" y2="398.415" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1031.409" y1="399.015" x2="960.000" y2="388.149" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="388.149" x2="960.000" y2="345.580" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1119.476" y1="426.455" x2="1089.518" y2="447.313" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1089.518" y1="447.313" x2="1036.135" y2="397.016" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1125.495" y1="587.895" x2="1154.077" y2="598.455" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1125.495" y1="587.895" x2="1132.028" y2="516.372" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1036.713" y1="706.233" x2="1096.731" y2="667.435" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1096.731" y1="667.435" x2="1129.234" y2="681.108" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="874.114" y1="724.752" x2="885.923" y2="710.844" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="885.923" y1="710.844" x2="954.383" y2="734.417" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="964.714" y1="760.668" x2="954.383" y2="734.417" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="786.510" y1="593.409" x2="813.251" y2="584.003" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="822.368" y1="584.702" x2="813.251" y2="584.003" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="811.028" y1="664.055" x2="786.510" y2="593.409" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="814.773" y1="434.875" x2="817.477" y2="439.555" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="817.477" y1="439.555" x2="774.927" y2="505.831" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="870.081" y1="377.240" x2="814.773" y2="434.875" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="814.773" y1="434.875" x2="781.631" y2="411.208" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="867.820" y1="350.841" x2="870.081" y2="377.240" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="847.298" y1="578.490" x2="858.236" y2="574.779" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="841.435" y1="578.126" x2="847.298" y2="578.490" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="763.070" y1="509.820" x2="774.629" y2="592.324" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="802.354" y1="682.911" x2="874.114" y2="724.752" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="901.037" y1="677.977" x2="892.095" y2="688.774" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="964.714" y1="760.668" x2="1042.887" y2="729.844" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1020.755" y1="674.626" x2="1025.682" y2="692.759" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1003.828" y1="642.233" x2="1005.424" y2="647.755" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1025.682" y1="692.759" x2="1036.713" y2="706.233" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1036.713" y1="706.233" x2="1042.887" y2="729.844" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1056.399" y1="746.009" x2="1042.887" y2="729.844" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1091.646" y1="580.750" x2="1113.737" y2="588.747" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1064.264" y1="576.363" x2="1057.456" y2="573.982" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1129.234" y1="681.108" x2="1154.077" y2="598.455" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1113.737" y1="588.747" x2="1125.495" y2="587.895" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1168.319" y1="597.246" x2="1154.077" y2="598.455" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1171.121" y1="500.189" x2="1119.476" y2="426.455" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1119.476" y1="426.455" x2="1123.156" y2="420.161" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="345.580" x2="960.000" y2="345.580" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="345.580" x2="867.820" y2="350.841" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1055.165" y1="351.011" x2="960.000" y2="345.580" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="345.580" x2="960.000" y2="297.480" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1157.051" y1="396.671" x2="1123.156" y2="420.161" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1123.156" y1="420.161" x2="1059.283" y2="348.098" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1200.567" y1="609.315" x2="1168.319" y2="597.246" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1168.319" y1="597.246" x2="1185.153" y2="503.235" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1063.217" y1="772.753" x2="1056.399" y2="746.009" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1056.399" y1="746.009" x2="1140.858" y2="700.809" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="866.867" y1="751.471" x2="853.374" y2="767.111" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="874.114" y1="724.752" x2="866.867" y2="751.471" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="956.014" y1="790.291" x2="866.867" y2="751.471" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="774.629" y1="592.324" x2="786.510" y2="593.409" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="742.414" y1="603.842" x2="767.921" y2="700.439" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="778.616" y1="405.859" x2="781.631" y2="411.208" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="781.631" y1="411.208" x2="719.271" y2="494.328" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="846.478" y1="324.667" x2="778.616" y2="405.859" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="778.616" y1="405.859" x2="743.401" y2="380.760" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="706.813" y1="496.189" x2="728.954" y2="602.485" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="742.414" y1="603.842" x2="728.954" y2="602.485" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="892.095" y1="688.774" x2="885.923" y2="710.844" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="916.556" y1="643.053" x2="913.901" y2="646.396" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="755.980" y1="718.378" x2="853.374" y2="767.111" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="913.901" y1="646.396" x2="911.243" y2="655.315" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="845.762" y1="795.518" x2="853.374" y2="767.111" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="963.309" y1="819.481" x2="1063.217" y2="772.753" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1063.217" y1="772.753" x2="1077.647" y2="789.877" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1174.640" y1="719.101" x2="1200.567" y2="609.315" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1200.567" y1="609.315" x2="1215.710" y2="607.957" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1229.348" y1="488.029" x2="1157.051" y2="396.671" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1157.051" y1="396.671" x2="1160.932" y2="389.948" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="297.480" x2="960.000" y2="297.480" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="297.480" x2="840.722" y2="297.480" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1081.464" y1="297.480" x2="960.000" y2="297.480" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="297.480" x2="960.000" y2="249.380" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1194.827" y1="366.457" x2="1160.932" y2="389.948" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1160.932" y1="389.948" x2="1085.015" y2="294.014" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1247.958" y1="620.026" x2="1215.710" y2="607.957" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1215.710" y1="607.957" x2="1243.784" y2="489.085" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1084.465" y1="816.620" x2="1077.647" y2="789.877" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1077.647" y1="789.877" x2="1188.966" y2="737.811" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="832.269" y1="811.159" x2="845.762" y2="795.518" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="845.762" y1="795.518" x2="957.220" y2="851.289" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="742.414" y1="603.842" x2="774.629" y2="592.324" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="694.769" y1="614.787" x2="720.749" y2="739.517" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="740.385" y1="375.411" x2="743.401" y2="380.760" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="743.401" y1="380.760" x2="659.219" y2="481.477" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="820.635" y1="268.446" x2="740.385" y2="375.411" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="740.385" y1="375.411" x2="707.243" y2="351.744" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="728.954" y1="602.485" x2="694.769" y2="614.787" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="681.309" y1="613.430" x2="694.769" y2="614.787" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="646.566" y1="481.855" x2="681.309" y2="613.430" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="706.783" y1="756.515" x2="832.269" y2="811.159" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="832.269" y1="811.159" x2="825.021" y2="837.878" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="962.311" y1="881.993" x2="1084.465" y2="816.620" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1084.465" y1="816.620" x2="1097.977" y2="832.785" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1223.079" y1="758.972" x2="1247.958" y2="620.026" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1247.958" y1="620.026" x2="1262.200" y2="618.818" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1290.828" y1="474.767" x2="1194.827" y2="366.457" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1194.827" y1="366.457" x2="1198.507" y2="360.164" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="249.380" x2="960.000" y2="249.380" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="249.380" x2="812.520" y2="240.963" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1109.071" y1="240.873" x2="960.000" y2="249.380" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="249.380" x2="960.000" y2="206.811" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1228.466" y1="339.305" x2="1198.507" y2="360.164" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1198.507" y1="360.164" x2="1112.243" y2="237.004" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1290.782" y1="629.377" x2="1262.200" y2="618.818" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1262.200" y1="618.818" x2="1305.599" y2="474.431" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1104.151" y1="856.396" x2="1097.977" y2="832.785" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1097.977" y1="832.785" x2="1239.349" y2="777.041" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="813.213" y1="851.786" x2="825.021" y2="837.878" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="825.021" y1="837.878" x2="958.045" y2="915.439" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="649.094" y1="624.948" x2="681.309" y2="613.430" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="861.003" y1="574.923" x2="858.236" y2="574.779" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="637.213" y1="623.863" x2="649.094" y2="624.948" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="670.857" y1="780.283" x2="649.094" y2="624.948" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="704.539" y1="347.063" x2="707.243" y2="351.744" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="707.243" y1="351.744" x2="596.046" y2="467.620" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="792.977" y1="209.314" x2="704.539" y2="347.063" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="704.539" y1="347.063" x2="677.115" y2="327.383" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="582.735" y1="466.892" x2="637.213" y2="623.863" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="637.213" y1="623.863" x2="610.472" y2="633.269" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="654.802" y1="797.239" x2="813.213" y2="851.786" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="813.213" y1="851.786" x2="807.041" y2="873.855" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="961.660" y1="948.507" x2="1104.151" y2="856.396" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1104.151" y1="856.396" x2="1115.182" y2="869.870" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1275.085" y1="801.240" x2="1290.782" y2="629.377" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1290.782" y1="629.377" x2="1302.541" y2="628.525" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1356.776" y1="460.198" x2="1228.466" y2="339.305" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1228.466" y1="339.305" x2="1231.566" y2="334.170" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="206.811" x2="960.000" y2="206.811" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="206.811" x2="782.440" y2="179.793" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1138.787" y1="179.606" x2="960.000" y2="206.811" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="206.811" x2="960.000" y2="173.963" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1254.627" y1="317.999" x2="1231.566" y2="334.170" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1231.566" y1="334.170" x2="1141.961" y2="174.998" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1324.631" y1="636.522" x2="1302.541" y2="628.525" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1302.541" y1="628.525" x2="1373.328" y2="458.637" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1120.109" y1="888.003" x2="1115.182" y2="869.870" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1115.182" y1="869.870" x2="1294.663" y2="820.579" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="798.099" y1="884.652" x2="807.041" y2="873.855" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="807.041" y1="873.855" x2="958.533" y2="986.753" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="601.355" y1="632.570" x2="610.472" y2="633.269" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="610.472" y1="633.269" x2="614.586" y2="825.722" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="674.990" y1="323.841" x2="677.115" y2="327.383" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="677.115" y1="327.383" x2="524.370" y2="451.576" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="760.577" y1="141.117" x2="674.990" y2="323.841" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="674.990" y1="323.841" x2="655.498" y2="309.772" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="507.715" y1="449.567" x2="601.355" y2="632.570" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="601.355" y1="632.570" x2="582.288" y2="639.146" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="593.158" y1="846.038" x2="798.099" y2="884.652" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="798.099" y1="884.652" x2="793.570" y2="900.289" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="961.349" y1="1028.947" x2="1120.109" y2="888.003" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1120.109" y1="888.003" x2="1127.812" y2="897.649" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1339.402" y1="852.893" x2="1324.631" y2="636.522" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1324.631" y1="636.522" x2="1332.952" y2="636.041" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1439.513" y1="441.523" x2="1254.627" y2="317.999" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1254.627" y1="317.999" x2="1256.873" y2="314.417" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="173.963" x2="960.000" y2="173.963" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="173.963" x2="744.361" y2="101.218" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1176.815" y1="100.821" x2="960.000" y2="173.963" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="173.963" x2="960.000" y2="152.668" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1271.779" y1="303.892" x2="1256.873" y2="314.417" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1256.873" y1="314.417" x2="1181.142" y2="93.546" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1347.277" y1="641.124" x2="1332.952" y2="636.041" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1332.952" y1="636.041" x2="1464.468" y2="437.742" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1131.103" y1="909.328" x2="1127.812" y2="897.649" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1127.812" y1="897.649" x2="1370.608" y2="881.008" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="787.893" y1="907.314" x2="793.570" y2="900.289" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="793.570" y1="900.289" x2="958.625" y2="1087.870" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="576.425" y1="638.782" x2="582.288" y2="639.146" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="582.288" y1="639.146" x2="531.894" y2="891.743" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="654.101" y1="307.526" x2="655.498" y2="309.772" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="655.498" y1="309.772" x2="415.868" y2="426.834" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="707.944" y1="31.960" x2="654.101" y2="307.526" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="654.101" y1="307.526" x2="642.940" y2="299.432" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="381.778" y1="420.908" x2="576.425" y2="638.782" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="576.425" y1="638.782" x2="565.486" y2="642.493" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="485.594" y1="932.026" x2="787.893" y2="907.314" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="787.893" y1="907.314" x2="785.235" y2="916.233" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="961.588" y1="1176.797" x2="1131.103" y2="909.328" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1131.103" y1="909.328" x2="1135.441" y2="914.874" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1464.690" y1="952.440" x2="1347.277" y2="641.124" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1347.277" y1="641.124" x2="1352.013" y2="640.909" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1609.901" y1="402.354" x2="1271.779" y2="303.892" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1271.779" y1="303.892" x2="1273.081" y2="301.879" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="152.668" x2="960.000" y2="152.668" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="152.668" x2="661.656" y2="-71.645" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1260.498" y1="-73.265" x2="960.000" y2="152.668" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="960.000" y1="152.668" x2="960.000" y2="142.534" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1280.154" y1="296.861" x2="1273.081" y2="301.879" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1273.081" y1="301.879" x2="1274.399" y2="-99.719" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1358.822" y1="643.290" x2="1352.013" y2="640.909" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1352.013" y1="640.909" x2="1698.162" y2="384.929" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1137.036" y1="920.396" x2="1135.441" y2="914.874" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1135.441" y1="914.874" x2="1582.195" y2="1050.836" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="782.580" y1="919.577" x2="785.235" y2="916.233" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="785.235" y1="916.233" x2="957.480" y2="1400.496" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="562.720" y1="642.349" x2="565.486" y2="642.493" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="565.486" y1="642.493" x2="243.214" y2="1120.292" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="642.270" y1="298.383" x2="642.940" y2="299.432" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="642.940" y1="299.432" x2="-18.861" y2="326.409" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="428.039" y1="-542.846" x2="642.270" y2="298.383" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="-470.272" y1="228.865" x2="562.720" y2="642.349" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="-509.558" y1="1732.361" x2="782.580" y2="919.577" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="972.408" y1="3428.116" x2="1137.036" y2="920.396" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="7397.757" y1="5638.793" x2="1358.822" y2="643.290" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="846.478" y1="324.667" x2="867.820" y2="350.841" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="846.478" y1="324.667" x2="840.722" y2="297.480" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="840.722" y1="297.480" x2="820.635" y2="268.446" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="812.520" y1="240.963" x2="820.635" y2="268.446" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="792.977" y1="209.314" x2="812.520" y2="240.963" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="782.440" y1="179.793" x2="792.977" y2="209.314" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="782.440" y1="179.793" x2="760.577" y2="141.117" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="744.361" y1="101.218" x2="760.577" y2="141.117" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="744.361" y1="101.218" x2="707.944" y2="31.960" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="707.944" y1="31.960" x2="661.656" y2="-71.645" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="428.039" y1="-542.846" x2="661.656" y2="-71.645" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="763.070" y1="509.820" x2="774.927" y2="505.831" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="763.070" y1="509.820" x2="719.271" y2="494.328" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="719.271" y1="494.328" x2="706.813" y2="496.189" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="659.219" y1="481.477" x2="706.813" y2="496.189" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="659.219" y1="481.477" x2="646.566" y2="481.855" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="596.046" y1="467.620" x2="646.566" y2="481.855" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="596.046" y1="467.620" x2="582.735" y2="466.892" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="524.370" y1="451.576" x2="582.735" y2="466.892" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="524.370" y1="451.576" x2="507.715" y2="449.567" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="507.715" y1="449.567" x2="415.868" y2="426.834" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="415.868" y1="426.834" x2="381.778" y2="420.908" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="381.778" y1="420.908" x2="-18.861" y2="326.409" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="-470.272" y1="228.865" x2="-18.861" y2="326.409" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="802.354" y1="682.911" x2="811.028" y2="664.055" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="802.354" y1="682.911" x2="767.921" y2="700.439" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="767.921" y1="700.439" x2="755.980" y2="718.378" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="720.749" y1="739.517" x2="755.980" y2="718.378" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="706.783" y1="756.515" x2="720.749" y2="739.517" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="670.857" y1="780.283" x2="706.783" y2="756.515" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="670.857" y1="780.283" x2="654.802" y2="797.239" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="614.586" y1="825.722" x2="654.802" y2="797.239" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="614.586" y1="825.722" x2="593.158" y2="846.038" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="593.158" y1="846.038" x2="531.894" y2="891.743" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="531.894" y1="891.743" x2="485.594" y2="932.026" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="485.594" y1="932.026" x2="243.214" y2="1120.292" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="-509.558" y1="1732.361" x2="243.214" y2="1120.292" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="964.714" y1="760.668" x2="956.014" y2="790.291" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="956.014" y1="790.291" x2="963.309" y2="819.481" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="957.220" y1="851.289" x2="963.309" y2="819.481" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="962.311" y1="881.993" x2="957.220" y2="851.289" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="958.045" y1="915.439" x2="962.311" y2="881.993" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="961.660" y1="948.507" x2="958.045" y2="915.439" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="958.533" y1="986.753" x2="961.660" y2="948.507" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="958.533" y1="986.753" x2="961.349" y2="1028.947" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="958.625" y1="1087.870" x2="961.349" y2="1028.947" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="958.625" y1="1087.870" x2="961.588" y2="1176.797" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="961.588" y1="1176.797" x2="957.480" y2="1400.496" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="972.408" y1="3428.116" x2="957.480" y2="1400.496" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1129.234" y1="681.108" x2="1140.858" y2="700.809" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1140.858" y1="700.809" x2="1174.640" y2="719.101" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1188.966" y1="737.811" x2="1174.640" y2="719.101" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1223.079" y1="758.972" x2="1188.966" y2="737.811" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1239.349" y1="777.041" x2="1223.079" y2="758.972" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1275.085" y1="801.240" x2="1239.349" y2="777.041" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1294.663" y1="820.579" x2="1275.085" y2="801.240" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1294.663" y1="820.579" x2="1339.402" y2="852.893" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1370.608" y1="881.008" x2="1339.402" y2="852.893" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1370.608" y1="881.008" x2="1464.690" y2="952.440" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1464.690" y1="952.440" x2="1582.195" y2="1050.836" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="7397.757" y1="5638.793" x2="1582.195" y2="1050.836" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1119.190" y1="510.664" x2="1132.028" y2="516.372" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1132.028" y1="516.372" x2="1171.121" y2="500.189" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1185.153" y1="503.235" x2="1171.121" y2="500.189" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1229.348" y1="488.029" x2="1185.153" y2="503.235" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1243.784" y1="489.085" x2="1229.348" y2="488.029" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1290.828" y1="474.767" x2="1243.784" y2="489.085" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1305.599" y1="474.431" x2="1290.828" y2="474.767" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1356.776" y1="460.198" x2="1305.599" y2="474.431" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1373.328" y1="458.637" x2="1356.776" y2="460.198" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1373.328" y1="458.637" x2="1439.513" y2="441.523" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1464.468" y1="437.742" x2="1439.513" y2="441.523" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1464.468" y1="437.742" x2="1609.901" y2="402.354" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1609.901" y1="402.354" x2="1698.162" y2="384.929" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1031.409" y1="399.015" x2="1036.135" y2="397.016" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1036.135" y1="397.016" x2="1055.165" y2="351.011" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1059.283" y1="348.098" x2="1055.165" y2="351.011" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1081.464" y1="297.480" x2="1059.283" y2="348.098" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1085.015" y1="294.014" x2="1081.464" y2="297.480" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1109.071" y1="240.873" x2="1085.015" y2="294.014" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1112.243" y1="237.004" x2="1109.071" y2="240.873" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1138.787" y1="179.606" x2="1112.243" y2="237.004" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1141.961" y1="174.998" x2="1138.787" y2="179.606" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1141.961" y1="174.998" x2="1176.815" y2="100.821" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1181.142" y1="93.546" x2="1176.815" y2="100.821" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1181.142" y1="93.546" x2="1260.498" y2="-73.265" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+<line x1="1260.498" y1="-73.265" x2="1274.399" y2="-99.719" stroke="#61efff" stroke-width="1.150" stroke-linecap="round" opacity="0.500" />+</g>+<polygon points="960.000,552.000 996.876,509.114 1011.832,529.361" fill="hsl(232 88% 60%)" opacity="0.230"/>+<polygon points="960.000,552.000 1016.521,554.092 1010.016,578.409" fill="hsl(233 88% 60%)" opacity="0.230"/>+<polygon points="1016.521,554.092 960.000,552.000 1011.832,529.361" fill="hsl(234 88% 60%)" opacity="0.230"/>+<polygon points="996.876,509.114 960.000,552.000 974.617,497.361" fill="hsl(232 88% 60%)" opacity="0.230"/>+<polygon points="974.617,497.361 960.000,552.000 949.463,496.430" fill="hsl(234 88% 60%)" opacity="0.230"/>+<polygon points="960.000,552.000 1010.016,578.409 993.605,597.495" fill="hsl(233 88% 60%)" opacity="0.230"/>+<polygon points="949.463,496.430 960.000,552.000 926.395,506.505" fill="hsl(233 88% 60%)" opacity="0.230"/>+<polygon points="960.000,552.000 993.605,597.495 970.537,607.570" fill="hsl(233 88% 60%)" opacity="0.230"/>+<polygon points="926.395,506.505 960.000,552.000 909.984,525.591" fill="hsl(234 88% 60%)" opacity="0.230"/>+<polygon points="960.000,552.000 970.537,607.570 945.383,606.639" fill="hsl(234 88% 60%)" opacity="0.230"/>+<polygon points="909.984,525.591 960.000,552.000 903.479,549.908" fill="hsl(234 88% 60%)" opacity="0.230"/>+<polygon points="960.000,552.000 908.168,574.639 903.479,549.908" fill="hsl(233 88% 60%)" opacity="0.230"/>+<polygon points="960.000,552.000 923.124,594.886 908.168,574.639" fill="hsl(233 88% 60%)" opacity="0.230"/>+<polygon points="923.124,594.886 960.000,552.000 945.383,606.639" fill="hsl(233 88% 60%)" opacity="0.230"/>+<polygon points="974.617,497.361 949.463,496.430 960.000,481.300" fill="hsl(270 88% 60%)" opacity="0.230"/>+<polygon points="1011.832,529.361 996.876,509.114 1014.395,506.750" fill="hsl(270 88% 60%)" opacity="0.230"/>+<polygon points="1016.521,554.092 1043.355,548.453 1029.736,564.916" fill="hsl(267 88% 60%)" opacity="0.230"/>+<polygon points="1010.016,578.409 1016.521,554.092 1029.736,564.916" fill="hsl(269 88% 60%)" opacity="0.230"/>+<polygon points="993.605,597.495 1016.470,615.548 994.784,614.125" fill="hsl(265 88% 60%)" opacity="0.230"/>+<polygon points="970.537,607.570 993.605,597.495 994.784,614.125" fill="hsl(268 88% 60%)" opacity="0.230"/>+<polygon points="923.124,594.886 945.383,606.639 934.305,618.816" fill="hsl(267 88% 60%)" opacity="0.230"/>+<polygon points="903.479,549.908 908.168,574.639 891.708,575.064" fill="hsl(266 88% 60%)" opacity="0.230"/>+<polygon points="909.984,525.591 909.772,497.843 926.395,506.505" fill="hsl(266 88% 60%)" opacity="0.230"/>+<polygon points="926.395,506.505 940.647,473.854 949.463,496.430" fill="hsl(258 88% 60%)" opacity="0.230"/>+<polygon points="909.772,497.843 909.984,525.591 898.140,513.838" fill="hsl(266 88% 60%)" opacity="0.230"/>+<polygon points="903.479,549.908 891.708,575.064 885.389,556.265" fill="hsl(267 88% 60%)" opacity="0.230"/>+<polygon points="923.124,594.886 934.305,618.816 915.227,613.042" fill="hsl(268 88% 60%)" opacity="0.230"/>+<polygon points="970.537,607.570 994.784,614.125 978.903,626.402" fill="hsl(270 88% 60%)" opacity="0.230"/>+<polygon points="1010.016,578.409 1029.736,564.916 1030.517,585.156" fill="hsl(271 88% 60%)" opacity="0.230"/>+<polygon points="1011.832,529.361 1014.395,506.750 1031.501,518.004" fill="hsl(271 88% 60%)" opacity="0.230"/>+<polygon points="974.617,497.361 1009.078,486.399 996.876,509.114" fill="hsl(257 88% 60%)" opacity="0.230"/>+<polygon points="979.353,473.854 974.617,497.361 960.000,481.300" fill="hsl(270 88% 60%)" opacity="0.230"/>+<polygon points="960.000,481.300 949.463,496.430 940.647,473.854" fill="hsl(274 88% 60%)" opacity="0.230"/>+<polygon points="940.647,473.854 926.395,506.505 909.772,497.843" fill="hsl(252 88% 60%)" opacity="0.230"/>+<polygon points="1014.395,506.750 996.876,509.114 1009.078,486.399" fill="hsl(270 88% 60%)" opacity="0.230"/>+<polygon points="1009.078,486.399 974.617,497.361 979.353,473.854" fill="hsl(256 88% 60%)" opacity="0.230"/>+<polygon points="1043.355,548.453 1016.521,554.092 1011.832,529.361" fill="hsl(256 88% 60%)" opacity="0.230"/>+<polygon points="1043.355,548.453 1011.832,529.361 1031.501,518.004" fill="hsl(255 88% 60%)" opacity="0.230"/>+<polygon points="1016.470,615.548 993.605,597.495 1010.016,578.409" fill="hsl(255 88% 60%)" opacity="0.230"/>+<polygon points="1016.470,615.548 1010.016,578.409 1030.517,585.156" fill="hsl(254 88% 60%)" opacity="0.230"/>+<polygon points="945.383,606.639 970.537,607.570 946.088,637.549" fill="hsl(253 88% 60%)" opacity="0.230"/>+<polygon points="934.305,618.816 945.383,606.639 946.088,637.549" fill="hsl(263 88% 60%)" opacity="0.230"/>+<polygon points="946.088,637.549 970.537,607.570 978.903,626.402" fill="hsl(253 88% 60%)" opacity="0.230"/>+<polygon points="908.168,574.639 923.124,594.886 883.325,596.007" fill="hsl(251 88% 60%)" opacity="0.230"/>+<polygon points="891.708,575.064 908.168,574.639 883.325,596.007" fill="hsl(258 88% 60%)" opacity="0.230"/>+<polygon points="883.325,596.007 923.124,594.886 915.227,613.042" fill="hsl(251 88% 60%)" opacity="0.230"/>+<polygon points="898.140,513.838 909.984,525.591 875.839,519.518" fill="hsl(251 88% 60%)" opacity="0.230"/>+<polygon points="875.839,519.518 909.984,525.591 903.479,549.908" fill="hsl(250 88% 60%)" opacity="0.230"/>+<polygon points="875.839,519.518 903.479,549.908 885.389,556.265" fill="hsl(250 88% 60%)" opacity="0.230"/>+<polygon points="940.647,473.854 909.772,497.843 908.803,474.067" fill="hsl(252 88% 60%)" opacity="0.230"/>+<polygon points="875.839,519.518 885.389,556.265 865.231,542.668" fill="hsl(254 88% 60%)" opacity="0.230"/>+<polygon points="883.325,596.007 915.227,613.042 891.810,621.371" fill="hsl(257 88% 60%)" opacity="0.230"/>+<polygon points="946.088,637.549 978.903,626.402 971.504,650.715" fill="hsl(259 88% 60%)" opacity="0.230"/>+<polygon points="1016.470,615.548 1030.517,585.156 1045.972,606.054" fill="hsl(259 88% 60%)" opacity="0.230"/>+<polygon points="1043.355,548.453 1031.501,518.004 1058.086,518.092" fill="hsl(257 88% 60%)" opacity="0.230"/>+<polygon points="940.647,473.854 979.353,473.854 960.000,481.300" fill="hsl(235 88% 60%)" opacity="0.230"/>+<polygon points="924.305,452.119 940.647,473.854 908.803,474.067" fill="hsl(261 88% 60%)" opacity="0.230"/>+<polygon points="1009.078,486.399 979.353,473.854 995.695,452.119" fill="hsl(254 88% 60%)" opacity="0.230"/>+<polygon points="1009.078,486.399 995.695,452.119 1016.855,459.695" fill="hsl(256 88% 60%)" opacity="0.230"/>+<polygon points="1043.355,548.453 1058.086,518.092 1069.970,538.415" fill="hsl(260 88% 60%)" opacity="0.230"/>+<polygon points="1016.470,615.548 1045.972,606.054 1041.038,631.119" fill="hsl(262 88% 60%)" opacity="0.230"/>+<polygon points="946.088,637.549 971.504,650.715 948.510,667.186" fill="hsl(262 88% 60%)" opacity="0.230"/>+<polygon points="883.325,596.007 891.810,621.371 860.659,616.256" fill="hsl(260 88% 60%)" opacity="0.230"/>+<polygon points="875.839,519.518 909.772,497.843 898.140,513.838" fill="hsl(230 88% 60%)" opacity="0.230"/>+<polygon points="845.359,513.562 875.839,519.518 865.231,542.668" fill="hsl(257 88% 60%)" opacity="0.230"/>+<polygon points="924.305,452.119 908.803,474.067 894.702,445.202" fill="hsl(260 88% 60%)" opacity="0.230"/>+<polygon points="845.359,513.562 865.231,542.668 833.067,536.251" fill="hsl(256 88% 60%)" opacity="0.230"/>+<polygon points="860.659,616.256 891.810,621.371 866.681,643.482" fill="hsl(258 88% 60%)" opacity="0.230"/>+<polygon points="971.504,650.715 1016.470,615.548 1041.038,631.119" fill="hsl(226 88% 60%)" opacity="0.230"/>+<polygon points="971.504,650.715 1041.038,631.119 973.839,684.781" fill="hsl(222 88% 60%)" opacity="0.230"/>+<polygon points="948.510,667.186 971.504,650.715 973.839,684.781" fill="hsl(257 88% 60%)" opacity="0.230"/>+<polygon points="1045.972,606.054 1043.355,548.453 1069.970,538.415" fill="hsl(226 88% 60%)" opacity="0.230"/>+<polygon points="1045.972,606.054 1069.970,538.415 1074.989,625.299" fill="hsl(222 88% 60%)" opacity="0.230"/>+<polygon points="1041.038,631.119 1045.972,606.054 1074.989,625.299" fill="hsl(255 88% 60%)" opacity="0.230"/>+<polygon points="1058.086,518.092 1016.855,459.695 1091.658,506.581" fill="hsl(222 88% 60%)" opacity="0.230"/>+<polygon points="1069.970,538.415 1058.086,518.092 1091.658,506.581" fill="hsl(252 88% 60%)" opacity="0.230"/>+<polygon points="995.695,452.119 940.647,473.854 924.305,452.119" fill="hsl(226 88% 60%)" opacity="0.230"/>+<polygon points="912.747,417.857 924.305,452.119 894.702,445.202" fill="hsl(253 88% 60%)" opacity="0.230"/>+<polygon points="1016.855,459.695 995.695,452.119 1007.253,417.857" fill="hsl(249 88% 60%)" opacity="0.230"/>+<polygon points="1009.078,486.399 1058.086,518.092 1031.501,518.004" fill="hsl(227 88% 60%)" opacity="0.230"/>+<polygon points="1009.078,486.399 1031.501,518.004 1014.395,506.750" fill="hsl(234 88% 60%)" opacity="0.230"/>+<polygon points="1037.312,429.076 1016.855,459.695 1007.253,417.857" fill="hsl(248 88% 60%)" opacity="0.230"/>+<polygon points="1069.970,538.415 1091.658,506.581 1107.369,535.862" fill="hsl(249 88% 60%)" opacity="0.230"/>+<polygon points="1041.038,631.119 1074.989,625.299 1066.359,659.641" fill="hsl(250 88% 60%)" opacity="0.230"/>+<polygon points="948.510,667.186 973.839,684.781 941.328,705.304" fill="hsl(250 88% 60%)" opacity="0.230"/>+<polygon points="883.325,596.007 885.389,556.265 891.708,575.064" fill="hsl(231 88% 60%)" opacity="0.230"/>+<polygon points="825.558,634.217 860.659,616.256 866.681,643.482" fill="hsl(248 88% 60%)" opacity="0.230"/>+<polygon points="908.803,474.067 875.839,519.518 845.359,513.562" fill="hsl(224 88% 60%)" opacity="0.230"/>+<polygon points="845.359,513.562 894.702,445.202 908.803,474.067" fill="hsl(223 88% 60%)" opacity="0.230"/>+<polygon points="894.702,445.202 845.359,513.562 809.079,496.569" fill="hsl(218 88% 60%)" opacity="0.230"/>+<polygon points="909.772,497.843 875.839,519.518 908.803,474.067" fill="hsl(229 88% 60%)" opacity="0.230"/>+<polygon points="809.079,496.569 845.359,513.562 833.067,536.251" fill="hsl(245 88% 60%)" opacity="0.230"/>+<polygon points="912.747,417.857 894.702,445.202 868.801,413.347" fill="hsl(246 88% 60%)" opacity="0.230"/>+<polygon points="868.801,413.347 894.702,445.202 809.079,496.569" fill="hsl(216 88% 60%)" opacity="0.230"/>+<polygon points="809.079,496.569 833.067,536.251 791.413,537.142" fill="hsl(241 88% 60%)" opacity="0.230"/>+<polygon points="891.810,621.371 948.510,667.186 866.681,643.482" fill="hsl(223 88% 60%)" opacity="0.230"/>+<polygon points="866.681,643.482 941.328,705.304 841.428,677.368" fill="hsl(216 88% 60%)" opacity="0.230"/>+<polygon points="825.558,634.217 866.681,643.482 841.428,677.368" fill="hsl(242 88% 60%)" opacity="0.230"/>+<polygon points="973.839,684.781 1066.359,659.641 985.185,726.096" fill="hsl(215 88% 60%)" opacity="0.230"/>+<polygon points="941.328,705.304 973.839,684.781 985.185,726.096" fill="hsl(241 88% 60%)" opacity="0.230"/>+<polygon points="1074.989,625.299 1107.369,535.862 1115.066,641.998" fill="hsl(215 88% 60%)" opacity="0.230"/>+<polygon points="1066.359,659.641 1074.989,625.299 1115.066,641.998" fill="hsl(237 88% 60%)" opacity="0.230"/>+<polygon points="1058.086,518.092 1009.078,486.399 1016.855,459.695" fill="hsl(226 88% 60%)" opacity="0.230"/>+<polygon points="1091.658,506.581 1037.312,429.076 1129.979,485.008" fill="hsl(214 88% 60%)" opacity="0.230"/>+<polygon points="1037.312,429.076 1091.658,506.581 1016.855,459.695" fill="hsl(221 88% 60%)" opacity="0.230"/>+<polygon points="995.695,452.119 924.305,452.119 912.747,417.857" fill="hsl(220 88% 60%)" opacity="0.230"/>+<polygon points="912.747,417.857 1007.253,417.857 995.695,452.119" fill="hsl(220 88% 60%)" opacity="0.230"/>+<polygon points="1007.253,417.857 912.747,417.857 906.049,373.842" fill="hsl(211 88% 60%)" opacity="0.230"/>+<polygon points="979.353,473.854 940.647,473.854 995.695,452.119" fill="hsl(227 88% 60%)" opacity="0.230"/>+<polygon points="906.049,373.842 912.747,417.857 868.801,413.347" fill="hsl(237 88% 60%)" opacity="0.230"/>+<polygon points="1007.253,417.857 906.049,373.842 1013.951,373.842" fill="hsl(211 88% 60%)" opacity="0.230"/>+<polygon points="1129.979,485.008 1037.312,429.076 1068.207,396.285" fill="hsl(212 88% 60%)" opacity="0.230"/>+<polygon points="1107.369,535.862 1074.989,625.299 1069.970,538.415" fill="hsl(220 88% 60%)" opacity="0.230"/>+<polygon points="1066.359,659.641 1115.066,641.998 1091.369,698.330" fill="hsl(230 88% 60%)" opacity="0.230"/>+<polygon points="946.088,637.549 915.227,613.042 934.305,618.816" fill="hsl(231 88% 60%)" opacity="0.230"/>+<polygon points="926.172,749.320 941.328,705.304 985.185,726.096" fill="hsl(230 88% 60%)" opacity="0.230"/>+<polygon points="825.558,634.217 833.067,536.251 860.659,616.256" fill="hsl(218 88% 60%)" opacity="0.230"/>+<polygon points="860.659,616.256 865.231,542.668 883.325,596.007" fill="hsl(224 88% 60%)" opacity="0.230"/>+<polygon points="868.801,413.347 809.079,496.569 769.133,470.923" fill="hsl(207 88% 60%)" opacity="0.230"/>+<polygon points="868.801,413.347 769.133,470.923 834.058,380.006" fill="hsl(206 88% 60%)" opacity="0.230"/>+<polygon points="906.049,373.842 868.801,413.347 834.058,380.006" fill="hsl(227 88% 60%)" opacity="0.230"/>+<polygon points="833.067,536.251 825.558,634.217 791.413,537.142" fill="hsl(217 88% 60%)" opacity="0.230"/>+<polygon points="731.345,662.781 692.378,554.491 743.326,543.879" fill="hsl(201 88% 60%)" opacity="0.230"/>+<polygon points="841.428,677.368 926.172,749.320 816.777,719.646" fill="hsl(208 88% 60%)" opacity="0.230"/>+<polygon points="985.185,726.096 1091.369,698.330 1003.272,771.965" fill="hsl(207 88% 60%)" opacity="0.230"/>+<polygon points="1016.470,615.548 971.504,650.715 978.903,626.402" fill="hsl(228 88% 60%)" opacity="0.230"/>+<polygon points="1016.470,615.548 978.903,626.402 994.784,614.125" fill="hsl(231 88% 60%)" opacity="0.230"/>+<polygon points="1066.359,659.641 973.839,684.781 1041.038,631.119" fill="hsl(219 88% 60%)" opacity="0.230"/>+<polygon points="1091.369,698.330 985.185,726.096 1066.359,659.641" fill="hsl(213 88% 60%)" opacity="0.230"/>+<polygon points="1043.355,548.453 1045.972,606.054 1030.517,585.156" fill="hsl(228 88% 60%)" opacity="0.230"/>+<polygon points="1115.066,641.998 1152.748,540.007 1162.616,656.290" fill="hsl(205 88% 60%)" opacity="0.230"/>+<polygon points="1043.355,548.453 1030.517,585.156 1029.736,564.916" fill="hsl(232 88% 60%)" opacity="0.230"/>+<polygon points="1152.748,540.007 1115.066,641.998 1107.369,535.862" fill="hsl(213 88% 60%)" opacity="0.230"/>+<polygon points="1129.979,485.008 1068.207,396.285 1170.914,456.336" fill="hsl(203 88% 60%)" opacity="0.230"/>+<polygon points="1170.914,456.336 1068.207,396.285 1106.050,362.743" fill="hsl(203 88% 60%)" opacity="0.230"/>+<polygon points="1162.616,656.290 1152.748,540.007 1202.785,548.966" fill="hsl(204 88% 60%)" opacity="0.230"/>+<polygon points="1003.272,771.965 1091.369,698.330 1115.469,743.362" fill="hsl(205 88% 60%)" opacity="0.230"/>+<polygon points="926.172,749.320 841.428,677.368 941.328,705.304" fill="hsl(212 88% 60%)" opacity="0.230"/>+<polygon points="941.328,705.304 866.681,643.482 948.510,667.186" fill="hsl(219 88% 60%)" opacity="0.230"/>+<polygon points="791.413,537.142 825.558,634.217 781.137,649.633" fill="hsl(210 88% 60%)" opacity="0.230"/>+<polygon points="692.378,554.491 731.345,662.781 680.396,673.393" fill="hsl(201 88% 60%)" opacity="0.230"/>+<polygon points="891.810,621.371 946.088,637.549 948.510,667.186" fill="hsl(225 88% 60%)" opacity="0.230"/>+<polygon points="816.777,719.646 905.691,796.353 793.444,766.277" fill="hsl(202 88% 60%)" opacity="0.230"/>+<polygon points="915.227,613.042 946.088,637.549 891.810,621.371" fill="hsl(228 88% 60%)" opacity="0.230"/>+<polygon points="905.691,796.353 816.777,719.646 926.172,749.320" fill="hsl(204 88% 60%)" opacity="0.230"/>+<polygon points="1003.272,771.965 1115.469,743.362 1025.396,819.267" fill="hsl(202 88% 60%)" opacity="0.230"/>+<polygon points="1213.493,668.306 1202.785,548.966 1253.661,560.982" fill="hsl(201 88% 60%)" opacity="0.170"/>+<polygon points="1025.396,819.267 1115.469,743.362 1137.592,790.664" fill="hsl(202 88% 60%)" opacity="0.230"/>+<polygon points="793.444,766.277 905.691,796.353 882.359,842.983" fill="hsl(202 88% 60%)" opacity="0.230"/>+<polygon points="781.137,649.633 743.326,543.879 791.413,537.142" fill="hsl(207 88% 60%)" opacity="0.230"/>+<polygon points="865.231,542.668 860.659,616.256 833.067,536.251" fill="hsl(223 88% 60%)" opacity="0.230"/>+<polygon points="692.378,554.491 680.396,673.393 642.585,567.639" fill="hsl(202 88% 60%)" opacity="0.230"/>+<polygon points="793.444,766.277 882.359,842.983 772.964,813.309" fill="hsl(204 88% 60%)" opacity="0.230"/>+<polygon points="1025.396,819.267 1137.592,790.664 1049.496,864.300" fill="hsl(205 88% 60%)" opacity="0.230"/>+<polygon points="1213.493,668.306 1253.661,560.982 1263.530,677.265" fill="hsl(204 88% 60%)" opacity="0.230"/>+<polygon points="1211.934,423.876 1147.069,330.282 1249.776,390.334" fill="hsl(203 88% 60%)" opacity="0.230"/>+<polygon points="1249.776,390.334 1147.069,330.282 1188.004,301.611" fill="hsl(203 88% 60%)" opacity="0.230"/>+<polygon points="1263.530,677.265 1253.661,560.982 1301.211,575.274" fill="hsl(205 88% 60%)" opacity="0.230"/>+<polygon points="1049.496,864.300 1137.592,790.664 1155.679,836.533" fill="hsl(207 88% 60%)" opacity="0.230"/>+<polygon points="772.964,813.309 882.359,842.983 857.708,885.262" fill="hsl(208 88% 60%)" opacity="0.230"/>+<polygon points="743.326,543.879 781.137,649.633 731.345,662.781" fill="hsl(202 88% 60%)" opacity="0.230"/>+<polygon points="642.585,567.639 680.396,673.393 632.310,680.130" fill="hsl(207 88% 60%)" opacity="0.230"/>+<polygon points="883.325,596.007 865.231,542.668 885.389,556.265" fill="hsl(229 88% 60%)" opacity="0.230"/>+<polygon points="752.883,315.696 687.959,406.613 653.215,373.272" fill="hsl(206 88% 60%)" opacity="0.230"/>+<polygon points="752.883,315.696 653.215,373.272 712.938,290.050" fill="hsl(207 88% 60%)" opacity="0.230"/>+<polygon points="642.585,567.639 632.310,680.130 598.165,583.055" fill="hsl(210 88% 60%)" opacity="0.230"/>+<polygon points="772.964,813.309 857.708,885.262 757.808,857.325" fill="hsl(211 88% 60%)" opacity="0.230"/>+<polygon points="1049.496,864.300 1155.679,836.533 1074.505,902.988" fill="hsl(212 88% 60%)" opacity="0.230"/>+<polygon points="1263.530,677.265 1301.211,575.274 1308.909,681.410" fill="hsl(213 88% 60%)" opacity="0.230"/>+<polygon points="1249.776,390.334 1188.004,301.611 1280.671,357.543" fill="hsl(212 88% 60%)" opacity="0.230"/>+<polygon points="1013.951,221.118 906.049,221.118 912.747,177.103" fill="hsl(211 88% 60%)" opacity="0.230"/>+<polygon points="1013.951,221.118 912.747,177.103 1007.253,177.103" fill="hsl(211 88% 60%)" opacity="0.230"/>+<polygon points="1280.671,357.543 1188.004,301.611 1226.325,280.038" fill="hsl(213 88% 60%)" opacity="0.230"/>+<polygon points="1308.909,681.410 1301.211,575.274 1341.288,591.973" fill="hsl(215 88% 60%)" opacity="0.230"/>+<polygon points="1074.505,902.988 1155.679,836.533 1167.025,877.848" fill="hsl(215 88% 60%)" opacity="0.230"/>+<polygon points="757.808,857.325 857.708,885.262 832.455,919.147" fill="hsl(216 88% 60%)" opacity="0.230"/>+<polygon points="598.165,583.055 632.310,680.130 590.656,681.021" fill="hsl(217 88% 60%)" opacity="0.230"/>+<polygon points="712.938,290.050 653.215,373.272 627.315,341.417" fill="hsl(216 88% 60%)" opacity="0.230"/>+<polygon points="712.938,290.050 627.315,341.417 676.658,273.057" fill="hsl(217 88% 60%)" opacity="0.230"/>+<polygon points="598.165,583.055 590.656,681.021 563.063,601.016" fill="hsl(218 88% 60%)" opacity="0.230"/>+<polygon points="757.808,857.325 832.455,919.147 750.625,895.443" fill="hsl(219 88% 60%)" opacity="0.230"/>+<polygon points="1074.505,902.988 1167.025,877.848 1099.827,931.510" fill="hsl(219 88% 60%)" opacity="0.230"/>+<polygon points="1308.909,681.410 1341.288,591.973 1346.307,678.857" fill="hsl(220 88% 60%)" opacity="0.230"/>+<polygon points="1280.671,357.543 1226.325,280.038 1301.129,326.923" fill="hsl(220 88% 60%)" opacity="0.230"/>+<polygon points="1007.253,177.103 912.747,177.103 924.305,142.841" fill="hsl(220 88% 60%)" opacity="0.230"/>+<polygon points="1007.253,177.103 924.305,142.841 995.695,142.841" fill="hsl(220 88% 60%)" opacity="0.230"/>+<polygon points="1301.129,326.923 1226.325,280.038 1259.898,268.527" fill="hsl(222 88% 60%)" opacity="0.230"/>+<polygon points="1346.307,678.857 1341.288,591.973 1370.306,611.218" fill="hsl(222 88% 60%)" opacity="0.230"/>+<polygon points="1099.827,931.510 1167.025,877.848 1169.360,911.914" fill="hsl(222 88% 60%)" opacity="0.230"/>+<polygon points="750.625,895.443 832.455,919.147 807.326,941.258" fill="hsl(223 88% 60%)" opacity="0.230"/>+<polygon points="563.063,601.016 590.656,681.021 558.492,674.604" fill="hsl(223 88% 60%)" opacity="0.230"/>+<polygon points="676.658,273.057 627.315,341.417 613.214,312.551" fill="hsl(223 88% 60%)" opacity="0.230"/>+<polygon points="676.658,273.057 613.214,312.551 646.178,267.101" fill="hsl(224 88% 60%)" opacity="0.230"/>+<polygon points="563.063,601.016 558.492,674.604 540.398,621.265" fill="hsl(224 88% 60%)" opacity="0.230"/>+<polygon points="750.625,895.443 807.326,941.258 753.048,925.081" fill="hsl(225 88% 60%)" opacity="0.230"/>+<polygon points="1099.827,931.510 1169.360,911.914 1124.394,947.081" fill="hsl(225 88% 60%)" opacity="0.230"/>+<polygon points="1346.307,678.857 1370.306,611.218 1372.922,668.819" fill="hsl(226 88% 60%)" opacity="0.230"/>+<polygon points="1301.129,326.923 1259.898,268.527 1308.905,300.219" fill="hsl(226 88% 60%)" opacity="0.230"/>+<polygon points="924.305,142.841 979.353,121.106 995.695,142.841" fill="hsl(227 88% 60%)" opacity="0.230"/>+<polygon points="979.353,121.106 924.305,142.841 940.647,121.106" fill="hsl(227 88% 60%)" opacity="0.230"/>+<polygon points="1308.905,300.219 1259.898,268.527 1286.483,268.614" fill="hsl(227 88% 60%)" opacity="0.230"/>+<polygon points="1372.922,668.819 1370.306,611.218 1385.760,632.116" fill="hsl(228 88% 60%)" opacity="0.230"/>+<polygon points="1124.394,947.081 1169.360,911.914 1161.961,936.228" fill="hsl(228 88% 60%)" opacity="0.230"/>+<polygon points="753.048,925.081 807.326,941.258 783.908,949.587" fill="hsl(228 88% 60%)" opacity="0.230"/>+<polygon points="540.398,621.265 558.492,674.604 538.334,661.008" fill="hsl(229 88% 60%)" opacity="0.230"/>+<polygon points="646.178,267.101 613.214,312.551 612.245,288.776" fill="hsl(229 88% 60%)" opacity="0.230"/>+<polygon points="646.178,267.101 612.245,288.776 623.876,272.780" fill="hsl(230 88% 60%)" opacity="0.230"/>+<polygon points="540.398,621.265 538.334,661.008 532.015,642.208" fill="hsl(230 88% 60%)" opacity="0.230"/>+<polygon points="753.048,925.081 783.908,949.587 764.831,943.813" fill="hsl(231 88% 60%)" opacity="0.230"/>+<polygon points="1124.394,947.081 1161.961,936.228 1146.080,948.504" fill="hsl(232 88% 60%)" opacity="0.230"/>+<polygon points="1372.922,668.819 1385.760,632.116 1386.541,652.356" fill="hsl(232 88% 60%)" opacity="0.230"/>+<polygon points="1308.905,300.219 1286.483,268.614 1303.589,279.869" fill="hsl(234 88% 60%)" opacity="0.230"/>+<polygon points="979.353,121.106 940.647,121.106 960.000,113.660" fill="hsl(235 88% 60%)" opacity="0.230"/>+<polygon points="903.184,323.640 906.049,373.842 834.058,380.006" fill="hsl(222 88% 60%)" opacity="0.230"/>+<polygon points="794.221,346.709 903.184,323.640 834.058,380.006" fill="hsl(209 88% 60%)" opacity="0.230"/>+<polygon points="769.133,470.923 809.079,496.569 791.413,537.142" fill="hsl(228 88% 60%)" opacity="0.230"/>+<polygon points="769.133,470.923 743.326,543.879 727.796,439.910" fill="hsl(213 88% 60%)" opacity="0.230"/>+<polygon points="743.326,543.879 769.133,470.923 791.413,537.142" fill="hsl(225 88% 60%)" opacity="0.230"/>+<polygon points="692.378,554.491 727.796,439.910 743.326,543.879" fill="hsl(202 88% 60%)" opacity="0.230"/>+<polygon points="781.137,649.633 825.558,634.217 841.428,677.368" fill="hsl(229 88% 60%)" opacity="0.230"/>+<polygon points="781.137,649.633 816.777,719.646 731.345,662.781" fill="hsl(215 88% 60%)" opacity="0.230"/>+<polygon points="816.777,719.646 781.137,649.633 841.428,677.368" fill="hsl(225 88% 60%)" opacity="0.230"/>+<polygon points="926.172,749.320 1003.272,771.965 905.691,796.353" fill="hsl(218 88% 60%)" opacity="0.230"/>+<polygon points="1003.272,771.965 926.172,749.320 985.185,726.096" fill="hsl(224 88% 60%)" opacity="0.230"/>+<polygon points="1091.369,698.330 1162.616,656.290 1115.469,743.362" fill="hsl(218 88% 60%)" opacity="0.230"/>+<polygon points="1162.616,656.290 1091.369,698.330 1115.066,641.998" fill="hsl(224 88% 60%)" opacity="0.230"/>+<polygon points="1107.369,535.862 1129.979,485.008 1152.748,540.007" fill="hsl(230 88% 60%)" opacity="0.230"/>+<polygon points="1152.748,540.007 1170.914,456.336 1202.785,548.966" fill="hsl(218 88% 60%)" opacity="0.230"/>+<polygon points="1129.979,485.008 1107.369,535.862 1091.658,506.581" fill="hsl(237 88% 60%)" opacity="0.230"/>+<polygon points="1170.914,456.336 1152.748,540.007 1129.979,485.008" fill="hsl(223 88% 60%)" opacity="0.230"/>+<polygon points="1037.312,429.076 1013.951,373.842 1068.207,396.285" fill="hsl(229 88% 60%)" opacity="0.230"/>+<polygon points="1068.207,396.285 1016.816,323.640 1106.050,362.743" fill="hsl(219 88% 60%)" opacity="0.230"/>+<polygon points="1013.951,373.842 1037.312,429.076 1007.253,417.857" fill="hsl(231 88% 60%)" opacity="0.230"/>+<polygon points="1016.816,323.640 1068.207,396.285 1013.951,373.842" fill="hsl(221 88% 60%)" opacity="0.230"/>+<line x1="960.000" y1="552.000" x2="996.876" y2="509.114" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="960.000" y1="552.000" x2="1011.832" y2="529.361" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="996.876" y1="509.114" x2="1011.832" y2="529.361" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="960.000" y1="552.000" x2="1010.016" y2="578.409" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="960.000" y1="552.000" x2="1016.521" y2="554.092" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1010.016" y1="578.409" x2="1016.521" y2="554.092" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1011.832" y1="529.361" x2="1016.521" y2="554.092" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="996.876" y1="509.114" x2="974.617" y2="497.361" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="960.000" y1="552.000" x2="974.617" y2="497.361" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="974.617" y1="497.361" x2="949.463" y2="496.430" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="960.000" y1="552.000" x2="949.463" y2="496.430" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="960.000" y1="552.000" x2="993.605" y2="597.495" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1010.016" y1="578.409" x2="993.605" y2="597.495" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="949.463" y1="496.430" x2="926.395" y2="506.505" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="960.000" y1="552.000" x2="926.395" y2="506.505" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="960.000" y1="552.000" x2="970.537" y2="607.570" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="993.605" y1="597.495" x2="970.537" y2="607.570" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="926.395" y1="506.505" x2="909.984" y2="525.591" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="960.000" y1="552.000" x2="909.984" y2="525.591" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="960.000" y1="552.000" x2="945.383" y2="606.639" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="970.537" y1="607.570" x2="945.383" y2="606.639" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="909.984" y1="525.591" x2="903.479" y2="549.908" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="960.000" y1="552.000" x2="903.479" y2="549.908" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="908.168" y1="574.639" x2="960.000" y2="552.000" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="903.479" y1="549.908" x2="908.168" y2="574.639" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="960.000" y1="552.000" x2="923.124" y2="594.886" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="908.168" y1="574.639" x2="923.124" y2="594.886" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="945.383" y1="606.639" x2="923.124" y2="594.886" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="974.617" y1="497.361" x2="960.000" y2="481.300" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="949.463" y1="496.430" x2="960.000" y2="481.300" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1011.832" y1="529.361" x2="1014.395" y2="506.750" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="996.876" y1="509.114" x2="1014.395" y2="506.750" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1016.521" y1="554.092" x2="1029.736" y2="564.916" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1016.521" y1="554.092" x2="1043.355" y2="548.453" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1010.016" y1="578.409" x2="1029.736" y2="564.916" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="993.605" y1="597.495" x2="994.784" y2="614.125" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="993.605" y1="597.495" x2="1016.470" y2="615.548" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="970.537" y1="607.570" x2="994.784" y2="614.125" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="923.124" y1="594.886" x2="934.305" y2="618.816" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="945.383" y1="606.639" x2="934.305" y2="618.816" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="903.479" y1="549.908" x2="891.708" y2="575.064" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="908.168" y1="574.639" x2="891.708" y2="575.064" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="909.772" y1="497.843" x2="909.984" y2="525.591" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="909.984" y1="525.591" x2="898.140" y2="513.838" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="940.647" y1="473.854" x2="926.395" y2="506.505" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="926.395" y1="506.505" x2="909.772" y2="497.843" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="909.772" y1="497.843" x2="898.140" y2="513.838" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="903.479" y1="549.908" x2="885.389" y2="556.265" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="891.708" y1="575.064" x2="885.389" y2="556.265" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="923.124" y1="594.886" x2="915.227" y2="613.042" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="934.305" y1="618.816" x2="915.227" y2="613.042" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="970.537" y1="607.570" x2="978.903" y2="626.402" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="994.784" y1="614.125" x2="978.903" y2="626.402" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1010.016" y1="578.409" x2="1030.517" y2="585.156" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1029.736" y1="564.916" x2="1030.517" y2="585.156" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1011.832" y1="529.361" x2="1031.501" y2="518.004" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1014.395" y1="506.750" x2="1031.501" y2="518.004" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1009.078" y1="486.399" x2="974.617" y2="497.361" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="974.617" y1="497.361" x2="979.353" y2="473.854" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="979.353" y1="473.854" x2="960.000" y2="481.300" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="960.000" y1="481.300" x2="940.647" y2="473.854" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="949.463" y1="496.430" x2="940.647" y2="473.854" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="940.647" y1="473.854" x2="909.772" y2="497.843" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1014.395" y1="506.750" x2="1009.078" y2="486.399" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="996.876" y1="509.114" x2="1009.078" y2="486.399" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1009.078" y1="486.399" x2="979.353" y2="473.854" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1029.736" y1="564.916" x2="1043.355" y2="548.453" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1011.832" y1="529.361" x2="1043.355" y2="548.453" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1043.355" y1="548.453" x2="1031.501" y2="518.004" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="994.784" y1="614.125" x2="1016.470" y2="615.548" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1010.016" y1="578.409" x2="1016.470" y2="615.548" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1016.470" y1="615.548" x2="1030.517" y2="585.156" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="945.383" y1="606.639" x2="946.088" y2="637.549" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="970.537" y1="607.570" x2="946.088" y2="637.549" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="934.305" y1="618.816" x2="946.088" y2="637.549" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="946.088" y1="637.549" x2="978.903" y2="626.402" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="908.168" y1="574.639" x2="883.325" y2="596.007" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="923.124" y1="594.886" x2="883.325" y2="596.007" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="891.708" y1="575.064" x2="883.325" y2="596.007" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="883.325" y1="596.007" x2="915.227" y2="613.042" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="898.140" y1="513.838" x2="875.839" y2="519.518" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="909.984" y1="525.591" x2="875.839" y2="519.518" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="875.839" y1="519.518" x2="903.479" y2="549.908" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="875.839" y1="519.518" x2="885.389" y2="556.265" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="940.647" y1="473.854" x2="908.803" y2="474.067" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="909.772" y1="497.843" x2="908.803" y2="474.067" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="875.839" y1="519.518" x2="865.231" y2="542.668" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="885.389" y1="556.265" x2="865.231" y2="542.668" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="883.325" y1="596.007" x2="891.810" y2="621.371" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="915.227" y1="613.042" x2="891.810" y2="621.371" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="946.088" y1="637.549" x2="971.504" y2="650.715" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="978.903" y1="626.402" x2="971.504" y2="650.715" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1016.470" y1="615.548" x2="1045.972" y2="606.054" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1030.517" y1="585.156" x2="1045.972" y2="606.054" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1043.355" y1="548.453" x2="1058.086" y2="518.092" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1031.501" y1="518.004" x2="1058.086" y2="518.092" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="995.695" y1="452.119" x2="940.647" y2="473.854" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="940.647" y1="473.854" x2="924.305" y2="452.119" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="924.305" y1="452.119" x2="908.803" y2="474.067" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1009.078" y1="486.399" x2="995.695" y2="452.119" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="979.353" y1="473.854" x2="995.695" y2="452.119" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1009.078" y1="486.399" x2="1016.855" y2="459.695" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="995.695" y1="452.119" x2="1016.855" y2="459.695" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1043.355" y1="548.453" x2="1069.970" y2="538.415" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1058.086" y1="518.092" x2="1069.970" y2="538.415" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1016.470" y1="615.548" x2="1041.038" y2="631.119" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1045.972" y1="606.054" x2="1041.038" y2="631.119" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="946.088" y1="637.549" x2="948.510" y2="667.186" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="971.504" y1="650.715" x2="948.510" y2="667.186" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="883.325" y1="596.007" x2="860.659" y2="616.256" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="891.810" y1="621.371" x2="860.659" y2="616.256" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="908.803" y1="474.067" x2="875.839" y2="519.518" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="875.839" y1="519.518" x2="845.359" y2="513.562" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="845.359" y1="513.562" x2="865.231" y2="542.668" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="924.305" y1="452.119" x2="894.702" y2="445.202" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="908.803" y1="474.067" x2="894.702" y2="445.202" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="845.359" y1="513.562" x2="833.067" y2="536.251" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="865.231" y1="542.668" x2="833.067" y2="536.251" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="860.659" y1="616.256" x2="866.681" y2="643.482" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="891.810" y1="621.371" x2="866.681" y2="643.482" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1016.470" y1="615.548" x2="971.504" y2="650.715" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="971.504" y1="650.715" x2="1041.038" y2="631.119" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="971.504" y1="650.715" x2="973.839" y2="684.781" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="948.510" y1="667.186" x2="973.839" y2="684.781" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1043.355" y1="548.453" x2="1045.972" y2="606.054" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1045.972" y1="606.054" x2="1069.970" y2="538.415" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1045.972" y1="606.054" x2="1074.989" y2="625.299" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1041.038" y1="631.119" x2="1074.989" y2="625.299" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1058.086" y1="518.092" x2="1091.658" y2="506.581" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1058.086" y1="518.092" x2="1016.855" y2="459.695" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1069.970" y1="538.415" x2="1091.658" y2="506.581" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="995.695" y1="452.119" x2="924.305" y2="452.119" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="924.305" y1="452.119" x2="912.747" y2="417.857" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="912.747" y1="417.857" x2="894.702" y2="445.202" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1016.855" y1="459.695" x2="1007.253" y2="417.857" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="995.695" y1="452.119" x2="1007.253" y2="417.857" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1037.312" y1="429.076" x2="1091.658" y2="506.581" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1031.501" y1="518.004" x2="1009.078" y2="486.399" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1037.312" y1="429.076" x2="1016.855" y2="459.695" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1037.312" y1="429.076" x2="1007.253" y2="417.857" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1069.970" y1="538.415" x2="1107.369" y2="535.862" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1091.658" y1="506.581" x2="1107.369" y2="535.862" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1041.038" y1="631.119" x2="1066.359" y2="659.641" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1074.989" y1="625.299" x2="1066.359" y2="659.641" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="948.510" y1="667.186" x2="941.328" y2="705.304" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="973.839" y1="684.781" x2="941.328" y2="705.304" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="860.659" y1="616.256" x2="833.067" y2="536.251" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="860.659" y1="616.256" x2="825.558" y2="634.217" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="825.558" y1="634.217" x2="866.681" y2="643.482" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="908.803" y1="474.067" x2="845.359" y2="513.562" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="875.839" y1="519.518" x2="909.772" y2="497.843" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="894.702" y1="445.202" x2="845.359" y2="513.562" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="894.702" y1="445.202" x2="809.079" y2="496.569" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="809.079" y1="496.569" x2="845.359" y2="513.562" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="809.079" y1="496.569" x2="833.067" y2="536.251" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="912.747" y1="417.857" x2="868.801" y2="413.347" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="894.702" y1="445.202" x2="868.801" y2="413.347" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="868.801" y1="413.347" x2="809.079" y2="496.569" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="809.079" y1="496.569" x2="791.413" y2="537.142" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="833.067" y1="536.251" x2="791.413" y2="537.142" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="948.510" y1="667.186" x2="891.810" y2="621.371" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="866.681" y1="643.482" x2="948.510" y2="667.186" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="866.681" y1="643.482" x2="841.428" y2="677.368" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="825.558" y1="634.217" x2="841.428" y2="677.368" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="973.839" y1="684.781" x2="985.185" y2="726.096" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="973.839" y1="684.781" x2="1041.038" y2="631.119" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="941.328" y1="705.304" x2="985.185" y2="726.096" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1074.989" y1="625.299" x2="1115.066" y2="641.998" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1074.989" y1="625.299" x2="1069.970" y2="538.415" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1066.359" y1="659.641" x2="1115.066" y2="641.998" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1091.658" y1="506.581" x2="1016.855" y2="459.695" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1058.086" y1="518.092" x2="1009.078" y2="486.399" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1091.658" y1="506.581" x2="1129.979" y2="485.008" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1129.979" y1="485.008" x2="1037.312" y2="429.076" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="995.695" y1="452.119" x2="912.747" y2="417.857" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="940.647" y1="473.854" x2="979.353" y2="473.854" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1007.253" y1="417.857" x2="912.747" y2="417.857" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1007.253" y1="417.857" x2="906.049" y2="373.842" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="906.049" y1="373.842" x2="912.747" y2="417.857" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="906.049" y1="373.842" x2="868.801" y2="413.347" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1007.253" y1="417.857" x2="1013.951" y2="373.842" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="906.049" y1="373.842" x2="1013.951" y2="373.842" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1129.979" y1="485.008" x2="1068.207" y2="396.285" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1037.312" y1="429.076" x2="1068.207" y2="396.285" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1152.748" y1="540.007" x2="1115.066" y2="641.998" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1107.369" y1="535.862" x2="1152.748" y2="540.007" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1066.359" y1="659.641" x2="1091.369" y2="698.330" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1115.066" y1="641.998" x2="1091.369" y2="698.330" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="841.428" y1="677.368" x2="926.172" y2="749.320" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="941.328" y1="705.304" x2="926.172" y2="749.320" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="926.172" y1="749.320" x2="985.185" y2="726.096" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="791.413" y1="537.142" x2="825.558" y2="634.217" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="825.558" y1="634.217" x2="833.067" y2="536.251" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="781.137" y1="649.633" x2="825.558" y2="634.217" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="868.801" y1="413.347" x2="769.133" y2="470.923" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="809.079" y1="496.569" x2="769.133" y2="470.923" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="868.801" y1="413.347" x2="834.058" y2="380.006" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="769.133" y1="470.923" x2="834.058" y2="380.006" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="906.049" y1="373.842" x2="834.058" y2="380.006" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="865.231" y1="542.668" x2="883.325" y2="596.007" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="865.231" y1="542.668" x2="860.659" y2="616.256" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="791.413" y1="537.142" x2="743.326" y2="543.879" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="841.428" y1="677.368" x2="816.777" y2="719.646" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="941.328" y1="705.304" x2="866.681" y2="643.482" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="985.185" y1="726.096" x2="1003.272" y2="771.965" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1066.359" y1="659.641" x2="973.839" y2="684.781" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1016.470" y1="615.548" x2="978.903" y2="626.402" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1066.359" y1="659.641" x2="985.185" y2="726.096" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1091.369" y1="698.330" x2="985.185" y2="726.096" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1003.272" y1="771.965" x2="1091.369" y2="698.330" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1107.369" y1="535.862" x2="1074.989" y2="625.299" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1030.517" y1="585.156" x2="1043.355" y2="548.453" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1115.066" y1="641.998" x2="1162.616" y2="656.290" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1107.369" y1="535.862" x2="1115.066" y2="641.998" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1162.616" y1="656.290" x2="1152.748" y2="540.007" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1129.979" y1="485.008" x2="1170.914" y2="456.336" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1068.207" y1="396.285" x2="1170.914" y2="456.336" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1013.951" y1="373.842" x2="903.184" y2="323.640" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="906.049" y1="373.842" x2="903.184" y2="323.640" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1013.951" y1="373.842" x2="1016.816" y2="323.640" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="903.184" y1="323.640" x2="1016.816" y2="323.640" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1170.914" y1="456.336" x2="1106.050" y2="362.743" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1068.207" y1="396.285" x2="1106.050" y2="362.743" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1162.616" y1="656.290" x2="1202.785" y2="548.966" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1152.748" y1="540.007" x2="1202.785" y2="548.966" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1003.272" y1="771.965" x2="1115.469" y2="743.362" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1091.369" y1="698.330" x2="1115.469" y2="743.362" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="905.691" y1="796.353" x2="816.777" y2="719.646" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="926.172" y1="749.320" x2="816.777" y2="719.646" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="905.691" y1="796.353" x2="926.172" y2="749.320" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="791.413" y1="537.142" x2="781.137" y2="649.633" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="781.137" y1="649.633" x2="731.345" y2="662.781" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="834.058" y1="380.006" x2="727.796" y2="439.910" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="769.133" y1="470.923" x2="727.796" y2="439.910" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="834.058" y1="380.006" x2="794.221" y2="346.709" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="727.796" y1="439.910" x2="794.221" y2="346.709" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="743.326" y1="543.879" x2="692.378" y2="554.491" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="731.345" y1="662.781" x2="743.326" y2="543.879" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="941.328" y1="705.304" x2="841.428" y2="677.368" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="946.088" y1="637.549" x2="915.227" y2="613.042" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="816.777" y1="719.646" x2="793.444" y2="766.277" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="946.088" y1="637.549" x2="891.810" y2="621.371" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="793.444" y1="766.277" x2="905.691" y2="796.353" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1003.272" y1="771.965" x2="1025.396" y2="819.267" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1115.469" y1="743.362" x2="1025.396" y2="819.267" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1162.616" y1="656.290" x2="1213.493" y2="668.306" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1202.785" y1="548.966" x2="1213.493" y2="668.306" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1170.914" y1="456.336" x2="1211.934" y2="423.876" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1106.050" y1="362.743" x2="1211.934" y2="423.876" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1016.816" y1="323.640" x2="903.184" y2="271.320" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="903.184" y1="323.640" x2="903.184" y2="271.320" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1016.816" y1="323.640" x2="1016.816" y2="271.320" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="903.184" y1="271.320" x2="1016.816" y2="271.320" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1211.934" y1="423.876" x2="1147.069" y2="330.282" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1106.050" y1="362.743" x2="1147.069" y2="330.282" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1213.493" y1="668.306" x2="1253.661" y2="560.982" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1202.785" y1="548.966" x2="1253.661" y2="560.982" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1025.396" y1="819.267" x2="1137.592" y2="790.664" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1115.469" y1="743.362" x2="1137.592" y2="790.664" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="793.444" y1="766.277" x2="882.359" y2="842.983" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="905.691" y1="796.353" x2="882.359" y2="842.983" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="743.326" y1="543.879" x2="781.137" y2="649.633" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="731.345" y1="662.781" x2="680.396" y2="673.393" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="794.221" y1="346.709" x2="687.959" y2="406.613" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="727.796" y1="439.910" x2="687.959" y2="406.613" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="794.221" y1="346.709" x2="752.883" y2="315.696" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="687.959" y1="406.613" x2="752.883" y2="315.696" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="731.345" y1="662.781" x2="692.378" y2="554.491" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="692.378" y1="554.491" x2="680.396" y2="673.393" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="692.378" y1="554.491" x2="642.585" y2="567.639" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="793.444" y1="766.277" x2="772.964" y2="813.309" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="882.359" y1="842.983" x2="772.964" y2="813.309" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1025.396" y1="819.267" x2="1049.496" y2="864.300" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1137.592" y1="790.664" x2="1049.496" y2="864.300" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1213.493" y1="668.306" x2="1263.530" y2="677.265" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1253.661" y1="560.982" x2="1263.530" y2="677.265" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1211.934" y1="423.876" x2="1249.776" y2="390.334" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1147.069" y1="330.282" x2="1249.776" y2="390.334" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1016.816" y1="271.320" x2="906.049" y2="221.118" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="903.184" y1="271.320" x2="906.049" y2="221.118" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1016.816" y1="271.320" x2="1013.951" y2="221.118" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="906.049" y1="221.118" x2="1013.951" y2="221.118" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1249.776" y1="390.334" x2="1188.004" y2="301.611" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1147.069" y1="330.282" x2="1188.004" y2="301.611" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1263.530" y1="677.265" x2="1301.211" y2="575.274" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1253.661" y1="560.982" x2="1301.211" y2="575.274" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1049.496" y1="864.300" x2="1155.679" y2="836.533" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1137.592" y1="790.664" x2="1155.679" y2="836.533" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="772.964" y1="813.309" x2="857.708" y2="885.262" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="882.359" y1="842.983" x2="857.708" y2="885.262" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="642.585" y1="567.639" x2="680.396" y2="673.393" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="883.325" y1="596.007" x2="885.389" y2="556.265" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="642.585" y1="567.639" x2="632.310" y2="680.130" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="632.310" y1="680.130" x2="680.396" y2="673.393" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="752.883" y1="315.696" x2="653.215" y2="373.272" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="687.959" y1="406.613" x2="653.215" y2="373.272" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="752.883" y1="315.696" x2="712.938" y2="290.050" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="653.215" y1="373.272" x2="712.938" y2="290.050" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="642.585" y1="567.639" x2="598.165" y2="583.055" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="632.310" y1="680.130" x2="598.165" y2="583.055" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="772.964" y1="813.309" x2="757.808" y2="857.325" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="857.708" y1="885.262" x2="757.808" y2="857.325" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1049.496" y1="864.300" x2="1074.505" y2="902.988" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1155.679" y1="836.533" x2="1074.505" y2="902.988" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1263.530" y1="677.265" x2="1308.909" y2="681.410" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1301.211" y1="575.274" x2="1308.909" y2="681.410" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1249.776" y1="390.334" x2="1280.671" y2="357.543" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1188.004" y1="301.611" x2="1280.671" y2="357.543" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1013.951" y1="221.118" x2="912.747" y2="177.103" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="906.049" y1="221.118" x2="912.747" y2="177.103" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1013.951" y1="221.118" x2="1007.253" y2="177.103" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="912.747" y1="177.103" x2="1007.253" y2="177.103" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1280.671" y1="357.543" x2="1226.325" y2="280.038" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1188.004" y1="301.611" x2="1226.325" y2="280.038" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1308.909" y1="681.410" x2="1341.288" y2="591.973" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1301.211" y1="575.274" x2="1341.288" y2="591.973" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1074.505" y1="902.988" x2="1167.025" y2="877.848" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1155.679" y1="836.533" x2="1167.025" y2="877.848" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="757.808" y1="857.325" x2="832.455" y2="919.147" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="857.708" y1="885.262" x2="832.455" y2="919.147" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="598.165" y1="583.055" x2="590.656" y2="681.021" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="632.310" y1="680.130" x2="590.656" y2="681.021" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="712.938" y1="290.050" x2="627.315" y2="341.417" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="653.215" y1="373.272" x2="627.315" y2="341.417" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="712.938" y1="290.050" x2="676.658" y2="273.057" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="627.315" y1="341.417" x2="676.658" y2="273.057" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="598.165" y1="583.055" x2="563.063" y2="601.016" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="590.656" y1="681.021" x2="563.063" y2="601.016" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="757.808" y1="857.325" x2="750.625" y2="895.443" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="832.455" y1="919.147" x2="750.625" y2="895.443" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1074.505" y1="902.988" x2="1099.827" y2="931.510" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1167.025" y1="877.848" x2="1099.827" y2="931.510" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1308.909" y1="681.410" x2="1346.307" y2="678.857" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1341.288" y1="591.973" x2="1346.307" y2="678.857" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1280.671" y1="357.543" x2="1301.129" y2="326.923" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1226.325" y1="280.038" x2="1301.129" y2="326.923" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1007.253" y1="177.103" x2="924.305" y2="142.841" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="912.747" y1="177.103" x2="924.305" y2="142.841" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1007.253" y1="177.103" x2="995.695" y2="142.841" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="924.305" y1="142.841" x2="995.695" y2="142.841" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1301.129" y1="326.923" x2="1259.898" y2="268.527" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1226.325" y1="280.038" x2="1259.898" y2="268.527" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1346.307" y1="678.857" x2="1370.306" y2="611.218" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1341.288" y1="591.973" x2="1370.306" y2="611.218" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1099.827" y1="931.510" x2="1169.360" y2="911.914" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1167.025" y1="877.848" x2="1169.360" y2="911.914" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="750.625" y1="895.443" x2="807.326" y2="941.258" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="832.455" y1="919.147" x2="807.326" y2="941.258" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="563.063" y1="601.016" x2="558.492" y2="674.604" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="590.656" y1="681.021" x2="558.492" y2="674.604" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="676.658" y1="273.057" x2="613.214" y2="312.551" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="627.315" y1="341.417" x2="613.214" y2="312.551" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="676.658" y1="273.057" x2="646.178" y2="267.101" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="613.214" y1="312.551" x2="646.178" y2="267.101" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="563.063" y1="601.016" x2="540.398" y2="621.265" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="558.492" y1="674.604" x2="540.398" y2="621.265" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="750.625" y1="895.443" x2="753.048" y2="925.081" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="807.326" y1="941.258" x2="753.048" y2="925.081" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1099.827" y1="931.510" x2="1124.394" y2="947.081" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1169.360" y1="911.914" x2="1124.394" y2="947.081" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1346.307" y1="678.857" x2="1372.922" y2="668.819" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1370.306" y1="611.218" x2="1372.922" y2="668.819" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1301.129" y1="326.923" x2="1308.905" y2="300.219" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1259.898" y1="268.527" x2="1308.905" y2="300.219" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="979.353" y1="121.106" x2="924.305" y2="142.841" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="924.305" y1="142.841" x2="940.647" y2="121.106" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="995.695" y1="142.841" x2="979.353" y2="121.106" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="940.647" y1="121.106" x2="979.353" y2="121.106" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1308.905" y1="300.219" x2="1286.483" y2="268.614" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1259.898" y1="268.527" x2="1286.483" y2="268.614" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1372.922" y1="668.819" x2="1385.760" y2="632.116" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1370.306" y1="611.218" x2="1385.760" y2="632.116" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1124.394" y1="947.081" x2="1161.961" y2="936.228" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1169.360" y1="911.914" x2="1161.961" y2="936.228" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="753.048" y1="925.081" x2="783.908" y2="949.587" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="807.326" y1="941.258" x2="783.908" y2="949.587" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="540.398" y1="621.265" x2="538.334" y2="661.008" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="558.492" y1="674.604" x2="538.334" y2="661.008" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="646.178" y1="267.101" x2="612.245" y2="288.776" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="613.214" y1="312.551" x2="612.245" y2="288.776" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="646.178" y1="267.101" x2="623.876" y2="272.780" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="612.245" y1="288.776" x2="623.876" y2="272.780" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="540.398" y1="621.265" x2="532.015" y2="642.208" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="538.334" y1="661.008" x2="532.015" y2="642.208" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="753.048" y1="925.081" x2="764.831" y2="943.813" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="783.908" y1="949.587" x2="764.831" y2="943.813" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1124.394" y1="947.081" x2="1146.080" y2="948.504" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1161.961" y1="936.228" x2="1146.080" y2="948.504" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1372.922" y1="668.819" x2="1386.541" y2="652.356" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1385.760" y1="632.116" x2="1386.541" y2="652.356" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1308.905" y1="300.219" x2="1303.589" y2="279.869" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1286.483" y1="268.614" x2="1303.589" y2="279.869" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="979.353" y1="121.106" x2="960.000" y2="113.660" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="940.647" y1="121.106" x2="960.000" y2="113.660" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="903.184" y1="323.640" x2="834.058" y2="380.006" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="794.221" y1="346.709" x2="903.184" y2="323.640" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="794.221" y1="346.709" x2="903.184" y2="271.320" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="903.184" y1="271.320" x2="752.883" y2="315.696" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="906.049" y1="221.118" x2="752.883" y2="315.696" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="906.049" y1="221.118" x2="712.938" y2="290.050" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="712.938" y1="290.050" x2="912.747" y2="177.103" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="912.747" y1="177.103" x2="676.658" y2="273.057" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="676.658" y1="273.057" x2="924.305" y2="142.841" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="646.178" y1="267.101" x2="924.305" y2="142.841" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="940.647" y1="121.106" x2="646.178" y2="267.101" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="940.647" y1="121.106" x2="623.876" y2="272.780" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="769.133" y1="470.923" x2="791.413" y2="537.142" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="743.326" y1="543.879" x2="769.133" y2="470.923" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="743.326" y1="543.879" x2="727.796" y2="439.910" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="727.796" y1="439.910" x2="692.378" y2="554.491" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="692.378" y1="554.491" x2="687.959" y2="406.613" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="687.959" y1="406.613" x2="642.585" y2="567.639" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="642.585" y1="567.639" x2="653.215" y2="373.272" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="653.215" y1="373.272" x2="598.165" y2="583.055" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="598.165" y1="583.055" x2="627.315" y2="341.417" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="563.063" y1="601.016" x2="627.315" y2="341.417" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="563.063" y1="601.016" x2="613.214" y2="312.551" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="540.398" y1="621.265" x2="613.214" y2="312.551" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="612.245" y1="288.776" x2="540.398" y2="621.265" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="612.245" y1="288.776" x2="532.015" y2="642.208" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="781.137" y1="649.633" x2="841.428" y2="677.368" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="816.777" y1="719.646" x2="781.137" y2="649.633" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="816.777" y1="719.646" x2="731.345" y2="662.781" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="731.345" y1="662.781" x2="793.444" y2="766.277" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="680.396" y1="673.393" x2="793.444" y2="766.277" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="680.396" y1="673.393" x2="772.964" y2="813.309" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="772.964" y1="813.309" x2="632.310" y2="680.130" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="632.310" y1="680.130" x2="757.808" y2="857.325" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="757.808" y1="857.325" x2="590.656" y2="681.021" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="750.625" y1="895.443" x2="590.656" y2="681.021" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="750.625" y1="895.443" x2="558.492" y2="674.604" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="753.048" y1="925.081" x2="558.492" y2="674.604" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="538.334" y1="661.008" x2="753.048" y2="925.081" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="538.334" y1="661.008" x2="764.831" y2="943.813" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1003.272" y1="771.965" x2="926.172" y2="749.320" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1003.272" y1="771.965" x2="905.691" y2="796.353" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="905.691" y1="796.353" x2="1025.396" y2="819.267" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="882.359" y1="842.983" x2="1025.396" y2="819.267" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="882.359" y1="842.983" x2="1049.496" y2="864.300" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="857.708" y1="885.262" x2="1049.496" y2="864.300" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="857.708" y1="885.262" x2="1074.505" y2="902.988" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1074.505" y1="902.988" x2="832.455" y2="919.147" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="832.455" y1="919.147" x2="1099.827" y2="931.510" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1099.827" y1="931.510" x2="807.326" y2="941.258" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1124.394" y1="947.081" x2="807.326" y2="941.258" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="783.908" y1="949.587" x2="1124.394" y2="947.081" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="783.908" y1="949.587" x2="1146.080" y2="948.504" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1162.616" y1="656.290" x2="1091.369" y2="698.330" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1162.616" y1="656.290" x2="1115.469" y2="743.362" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1115.469" y1="743.362" x2="1213.493" y2="668.306" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1137.592" y1="790.664" x2="1213.493" y2="668.306" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1137.592" y1="790.664" x2="1263.530" y2="677.265" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1155.679" y1="836.533" x2="1263.530" y2="677.265" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1155.679" y1="836.533" x2="1308.909" y2="681.410" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1308.909" y1="681.410" x2="1167.025" y2="877.848" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1167.025" y1="877.848" x2="1346.307" y2="678.857" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1346.307" y1="678.857" x2="1169.360" y2="911.914" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1372.922" y1="668.819" x2="1169.360" y2="911.914" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1161.961" y1="936.228" x2="1372.922" y2="668.819" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1161.961" y1="936.228" x2="1386.541" y2="652.356" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1129.979" y1="485.008" x2="1107.369" y2="535.862" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1129.979" y1="485.008" x2="1152.748" y2="540.007" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1152.748" y1="540.007" x2="1170.914" y2="456.336" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1202.785" y1="548.966" x2="1170.914" y2="456.336" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1202.785" y1="548.966" x2="1211.934" y2="423.876" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1253.661" y1="560.982" x2="1211.934" y2="423.876" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1253.661" y1="560.982" x2="1249.776" y2="390.334" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1301.211" y1="575.274" x2="1249.776" y2="390.334" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1301.211" y1="575.274" x2="1280.671" y2="357.543" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1280.671" y1="357.543" x2="1341.288" y2="591.973" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1341.288" y1="591.973" x2="1301.129" y2="326.923" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1301.129" y1="326.923" x2="1370.306" y2="611.218" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1308.905" y1="300.219" x2="1370.306" y2="611.218" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1385.760" y1="632.116" x2="1308.905" y2="300.219" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1013.951" y1="373.842" x2="1037.312" y2="429.076" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1013.951" y1="373.842" x2="1068.207" y2="396.285" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1068.207" y1="396.285" x2="1016.816" y2="323.640" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1106.050" y1="362.743" x2="1016.816" y2="323.640" stroke="#ffd56a" stroke-width="2.000" stroke-linecap="round" opacity="0.880" filter="url(#edge-glow)"/>+<line x1="1106.050" y1="362.743" x2="1016.816" y2="271.320" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1147.069" y1="330.282" x2="1016.816" y2="271.320" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1147.069" y1="330.282" x2="1013.951" y2="221.118" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1188.004" y1="301.611" x2="1013.951" y2="221.118" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1188.004" y1="301.611" x2="1007.253" y2="177.103" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1007.253" y1="177.103" x2="1226.325" y2="280.038" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1226.325" y1="280.038" x2="995.695" y2="142.841" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="995.695" y1="142.841" x2="1259.898" y2="268.527" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="979.353" y1="121.106" x2="1259.898" y2="268.527" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<line x1="1286.483" y1="268.614" x2="979.353" y2="121.106" stroke="#dd78ff" stroke-width="0.750" stroke-linecap="round" opacity="0.060" filter="url(#edge-glow)"/>+<g filter="url(#hole-glow)"><path d="M 1013.951,373.842 L 906.049,373.842 L 903.184,323.640 L 1016.816,323.640 Z" fill="none" stroke="url(#hole-stroke)" stroke-width="5.4" stroke-linejoin="round" opacity="0.98"/>+<path d="M 834.058,380.006 L 769.133,470.923 L 727.796,439.910 L 794.221,346.709 Z" fill="none" stroke="url(#hole-stroke)" stroke-width="5.4" stroke-linejoin="round" opacity="0.98"/>+<path d="M 1162.616,656.290 L 1202.785,548.966 L 1213.493,668.306 Z" fill="none" stroke="url(#hole-stroke)" stroke-width="5.4" stroke-linejoin="round" opacity="0.98"/>+<path d="M 1170.914,456.336 L 1106.050,362.743 L 1147.069,330.282 L 1211.934,423.876 Z" fill="none" stroke="url(#hole-stroke)" stroke-width="5.4" stroke-linejoin="round" opacity="0.98"/>+<path d="M 1016.816,323.640 L 903.184,323.640 L 903.184,271.320 L 1016.816,271.320 Z" fill="none" stroke="url(#hole-stroke)" stroke-width="5.4" stroke-linejoin="round" opacity="0.98"/>+<path d="M 794.221,346.709 L 727.796,439.910 L 687.959,406.613 L 752.883,315.696 Z" fill="none" stroke="url(#hole-stroke)" stroke-width="5.4" stroke-linejoin="round" opacity="0.98"/>+<path d="M 1016.816,271.320 L 903.184,271.320 L 906.049,221.118 L 1013.951,221.118 Z" fill="none" stroke="url(#hole-stroke)" stroke-width="5.4" stroke-linejoin="round" opacity="0.98"/>+</g>+<circle cx="960.000" cy="552.000" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="996.876" cy="509.114" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1011.832" cy="529.361" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1010.016" cy="578.409" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1016.521" cy="554.092" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="974.617" cy="497.361" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="949.463" cy="496.430" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="993.605" cy="597.495" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="926.395" cy="506.505" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="970.537" cy="607.570" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="909.984" cy="525.591" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="945.383" cy="606.639" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="903.479" cy="549.908" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="908.168" cy="574.639" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="923.124" cy="594.886" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="960.000" cy="481.300" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1014.395" cy="506.750" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1029.736" cy="564.916" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="994.784" cy="614.125" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="934.305" cy="618.816" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="891.708" cy="575.064" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="898.140" cy="513.838" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="909.772" cy="497.843" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="885.389" cy="556.265" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="915.227" cy="613.042" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="978.903" cy="626.402" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1030.517" cy="585.156" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1031.501" cy="518.004" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="979.353" cy="473.854" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="940.647" cy="473.854" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1009.078" cy="486.399" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1043.355" cy="548.453" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1016.470" cy="615.548" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="946.088" cy="637.549" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="883.325" cy="596.007" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="875.839" cy="519.518" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="908.803" cy="474.067" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="865.231" cy="542.668" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="891.810" cy="621.371" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="971.504" cy="650.715" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1045.972" cy="606.054" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1058.086" cy="518.092" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="924.305" cy="452.119" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="995.695" cy="452.119" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1016.855" cy="459.695" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1069.970" cy="538.415" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1041.038" cy="631.119" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="948.510" cy="667.186" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="860.659" cy="616.256" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="845.359" cy="513.562" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="894.702" cy="445.202" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="833.067" cy="536.251" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="866.681" cy="643.482" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="973.839" cy="684.781" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1074.989" cy="625.299" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1091.658" cy="506.581" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="912.747" cy="417.857" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1007.253" cy="417.857" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1037.312" cy="429.076" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1107.369" cy="535.862" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1066.359" cy="659.641" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="941.328" cy="705.304" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="825.558" cy="634.217" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="809.079" cy="496.569" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="868.801" cy="413.347" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="791.413" cy="537.142" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="841.428" cy="677.368" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="985.185" cy="726.096" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1115.066" cy="641.998" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1129.979" cy="485.008" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="906.049" cy="373.842" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1013.951" cy="373.842" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1068.207" cy="396.285" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1152.748" cy="540.007" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1091.369" cy="698.330" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="926.172" cy="749.320" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="781.137" cy="649.633" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="769.133" cy="470.923" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="834.058" cy="380.006" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="743.326" cy="543.879" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="816.777" cy="719.646" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1003.272" cy="771.965" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1162.616" cy="656.290" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1170.914" cy="456.336" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="903.184" cy="323.640" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1016.816" cy="323.640" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1106.050" cy="362.743" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1202.785" cy="548.966" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1115.469" cy="743.362" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="905.691" cy="796.353" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="731.345" cy="662.781" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="727.796" cy="439.910" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="794.221" cy="346.709" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="692.378" cy="554.491" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="793.444" cy="766.277" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1025.396" cy="819.267" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1213.493" cy="668.306" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1211.934" cy="423.876" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="903.184" cy="271.320" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1016.816" cy="271.320" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1147.069" cy="330.282" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1253.661" cy="560.982" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1137.592" cy="790.664" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="882.359" cy="842.983" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="680.396" cy="673.393" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="687.959" cy="406.613" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="752.883" cy="315.696" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="642.585" cy="567.639" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="772.964" cy="813.309" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1049.496" cy="864.300" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1263.530" cy="677.265" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1249.776" cy="390.334" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="906.049" cy="221.118" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1013.951" cy="221.118" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1188.004" cy="301.611" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1301.211" cy="575.274" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1155.679" cy="836.533" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="857.708" cy="885.262" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="632.310" cy="680.130" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="653.215" cy="373.272" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="712.938" cy="290.050" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="598.165" cy="583.055" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="757.808" cy="857.325" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1074.505" cy="902.988" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1308.909" cy="681.410" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1280.671" cy="357.543" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="912.747" cy="177.103" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1007.253" cy="177.103" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1226.325" cy="280.038" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1341.288" cy="591.973" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1167.025" cy="877.848" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="832.455" cy="919.147" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="590.656" cy="681.021" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="627.315" cy="341.417" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="676.658" cy="273.057" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="563.063" cy="601.016" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="750.625" cy="895.443" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1099.827" cy="931.510" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1346.307" cy="678.857" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1301.129" cy="326.923" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="924.305" cy="142.841" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="995.695" cy="142.841" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1259.898" cy="268.527" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1370.306" cy="611.218" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1169.360" cy="911.914" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="807.326" cy="941.258" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="558.492" cy="674.604" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="613.214" cy="312.551" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="646.178" cy="267.101" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="540.398" cy="621.265" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="753.048" cy="925.081" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1124.394" cy="947.081" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1372.922" cy="668.819" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1308.905" cy="300.219" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="940.647" cy="121.106" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="979.353" cy="121.106" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1286.483" cy="268.614" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1385.760" cy="632.116" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1161.961" cy="936.228" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="783.908" cy="949.587" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="538.334" cy="661.008" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="612.245" cy="288.776" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="623.876" cy="272.780" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="532.015" cy="642.208" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="764.831" cy="943.813" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1146.080" cy="948.504" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1386.541" cy="652.356" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="1303.589" cy="279.869" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+<circle cx="960.000" cy="113.660" r="3.791" fill="#fff8d9" stroke="#ff9ad7" stroke-width="1.2" opacity="0.95"/>+</g>+<path d="M 504.232,637.038 L 511.333,619.556 L 515.575,612.082 L 529.764,595.098 L 550.582,579.300 L 577.273,565.013 L 608.822,552.264 L 644.022,540.909 L 681.558,530.816 L 720.080,522.024 L 758.277,514.831 L 781.582,511.624 L 764.940,500.588 L 733.646,477.535 L 702.754,452.899 L 673.315,427.519 L 646.527,402.016 L 623.634,376.841 L 605.785,352.389 L 601.543,344.915 L 589.641,321.648 L 584.226,300.190 L 585.414,281.358 L 592.914,266.105 L 597.156,258.631 L 610.357,247.925 L 628.453,242.576 L 637.139,242.576 L 659.264,243.081 L 684.596,249.507 L 712.407,261.467 L 742.044,278.184 L 772.869,298.625 L 804.163,321.679 L 835.056,346.315 L 864.495,371.694 L 880.355,386.794 L 878.544,366.177 L 877.056,327.337 L 877.056,287.823 L 878.544,248.983 L 881.781,212.139 L 887.190,178.544 L 895.179,149.343 L 905.949,125.532 L 910.191,118.058 L 923.591,100.445 L 939.056,89.632 L 955.657,85.986 L 964.343,85.986 L 980.944,89.632 L 996.409,100.445 L 1009.809,118.058 L 1014.051,125.532 L 1024.821,149.343 L 1032.810,178.544 L 1038.219,212.139 L 1041.456,248.983 L 1042.944,287.823 L 1042.944,327.337 L 1041.456,366.177 L 1039.645,386.794 L 1055.505,371.694 L 1084.944,346.315 L 1115.837,321.679 L 1147.131,298.625 L 1177.956,278.184 L 1207.593,261.467 L 1235.404,249.507 L 1260.736,243.081 L 1282.861,242.576 L 1291.547,242.576 L 1309.643,247.925 L 1322.844,258.631 L 1327.086,266.105 L 1334.586,281.358 L 1335.774,300.190 L 1330.359,321.648 L 1318.457,344.915 L 1314.215,352.389 L 1296.366,376.841 L 1273.473,402.016 L 1246.685,427.519 L 1217.246,452.899 L 1186.354,477.535 L 1155.060,500.588 L 1138.418,511.624 L 1161.723,514.831 L 1199.920,522.024 L 1238.442,530.816 L 1275.978,540.909 L 1311.178,552.264 L 1342.727,565.013 L 1369.418,579.300 L 1390.236,595.098 L 1404.425,612.082 L 1408.667,619.556 L 1415.768,637.038 L 1415.628,654.035 L 1408.380,669.409 L 1404.138,676.883 L 1390.155,689.553 L 1370.002,698.698 L 1344.390,703.900 L 1314.144,705.190 L 1305.458,705.190 L 1271.502,702.988 L 1234.861,697.946 L 1196.664,690.753 L 1158.141,681.961 L 1120.606,671.868 L 1102.029,665.875 L 1110.623,680.329 L 1114.865,687.803 L 1133.058,722.152 L 1150.202,757.752 L 1165.714,793.391 L 1178.783,827.992 L 1188.486,860.606 L 1193.958,890.381 L 1194.586,916.508 L 1190.155,938.190 L 1180.913,954.642 L 1176.671,962.116 L 1163.296,972.604 L 1146.757,976.523 L 1138.071,976.523 L 1119.446,973.490 L 1099.732,963.436 L 1079.696,946.655 L 1059.829,923.812 L 1040.380,895.892 L 1021.476,864.100 L 1017.234,856.626 L 999.042,822.278 L 981.898,786.678 L 966.386,751.039 L 960.000,734.132 L 953.614,751.039 L 938.102,786.678 L 920.958,822.278 L 902.766,856.626 L 898.524,864.100 L 879.620,895.892 L 860.171,923.812 L 840.304,946.655 L 820.268,963.436 L 800.554,973.490 L 781.929,976.523 L 773.243,976.523 L 756.704,972.604 L 743.329,962.116 L 739.087,954.642 L 729.845,938.190 L 725.414,916.508 L 726.042,890.381 L 731.514,860.606 L 741.217,827.992 L 754.286,793.391 L 769.798,757.752 L 786.942,722.152 L 805.135,687.803 L 809.377,680.329 L 817.971,665.875 L 799.394,671.868 L 761.859,681.961 L 723.336,690.753 L 685.139,697.946 L 648.498,702.988 L 614.542,705.190 L 605.856,705.190 L 575.610,703.900 L 549.998,698.698 L 529.845,689.553 L 515.862,676.883 L 511.620,669.409 L 504.372,654.035 Z" fill="none" stroke="url(#mask-stroke)" stroke-width="2.2" opacity="0.92" filter="url(#edge-glow)"/>+<g font-family="Inter, Avenir Next, Helvetica, Arial, sans-serif" fill="#f7f3ff">+<text x="72" y="82" font-size="24" font-weight="600" letter-spacing="8" fill="#9ff7ff">MOONLIGHT TRIANGULATION</text>+<text x="70" y="145" font-size="58" font-weight="780" letter-spacing="-1.5">PERSISTENCE ROSE</text>+<g transform="translate(1500 790)">+<text x="0" y="0" font-size="18" letter-spacing="2.4" fill="#91a8d8">TOPOLOGICAL HOLES AT THIS SCALE</text>+<text x="0" y="74" font-size="78" font-weight="720" fill="#fff5cd">β₁ = 7</text>+<text x="2" y="116" font-size="17" fill="#c9d3ff">7 independent one-dimensional holes</text>+<text x="2" y="144" font-size="15" fill="#9ba8d4">in the exact alpha complex</text>+<text x="2" y="176" font-size="14" fill="#7682aa">critical rank 538 · α² = 0.358</text>+<text x="2" y="200" font-size="12" fill="#596486">exact 94-digit / 94-digit rational</text>+</g>+</g>+</svg>
+ docs/regular-site-algebra.md view
@@ -0,0 +1,86 @@+# Persistent regular-site algebra++`Moonlight.Triangulation.PowerDiagram` owns the complete weighted-site value.+Use this surface when site identity must survive visibility changes or repeated+weight updates.++## Construct and edit++A `PowerSite label` combines a stable identity, an admitted planar position,+and an exact signed `PowerWeight`. Construction retains every site, including+hidden and coincident sites:++```haskell+regularTriangulation sites++editRegular newSite oldLabel weightPatch regular = do+  inserted <- insertRegularSite newSite regular+  removed <-+    removeRegularSite oldLabel (regularEditTriangulation inserted)+  reweightRegularSites+    weightPatch+    (regularEditTriangulation removed)+```++Each edit returns `RegularEditResult`:++- `regularEditTriangulation` is the new authoritative value.+- `regularEditChangedSites` is the exact support changed by the edit; it is+  empty for idempotent insertion, removal, or reweighting.+- `regularEditTransitions` carries every resulting disposition transition.++Read structural counts from the returned value with+`regularTriangulationReceipt`; the edit result does not duplicate them.++`RegularSiteTransition` distinguishes appearance, disappearance, and a change+between any two `RegularSiteDisposition` values. Thus removing or down-weighting+a visible site can report a previously hidden site becoming visible without a+caller-maintained hidden-site table.++## Identity and obstructions++The label is site identity. Re-inserting the same labelled position and weight+is idempotent. Reusing a label for different geometry returns+`RegularEditSiteConflict`; changing only weights belongs in+`reweightRegularSites`. A batch weight patch is applied once and returns+`RegularEditUnknownSites` before construction if any label is absent.++Distinct labels may occupy the same position. Their exact affine forms remain+separate submissions, and the result explicitly classifies them as visible,+coincident-equivalent, or coincident-dominated rather than silently deleting an+identity.++`emptyRegularTriangulation` is the insertion identity and the lawful result of+removing the final site. `regularSite`, `regularSites`, and `regularSiteCount`+read the canonical site section; faces, edges, neighbours, and visibility are+derived from it.++## Reuse the normalized topology++```haskell+(diagram, receipt) <- boundedPowerDiagramFromRegular domain regular+```++This clips regular-neighbour inequalities without reconstructing the lifted+hull. `boundedPowerDiagram domain sites` remains the one-shot entrance when the+editable regular value is not otherwise needed.++Edits descend through a persistent exact index. Coincident subordinates and+hidden sites update directly. A distinct insertion walks the slope+triangulation, discovers its lifted conflict cavity, glues the exact horizon,+and reattaches only hidden generators supported by removed faces. Interior+removal retriangulates the removed face star from its boundary and attached+hidden candidates. A single general reweight composes removal with insertion+atomically; a uniform shift of every weight translates the resident affine+section without changing topology. Multi-site patches use the direct+topology-preserving cases when exact, and otherwise normalize once through the+batch owner rather than accumulating local edits.++Every local publication checks manifold incidence, exact cavity boundary, and+strict lifted convexity. Degenerate, boundary-changing, or unsupported cases+decline to the exact batch constructor used by `regularTriangulation`; no+uncertified local result is published. On the retained 512-site fixture this+collapses insertion and removal from whole-hull reconstruction to+sub-millisecond face-star work.++[Compute signed weighted alpha persistence from the same value.](./weighted-alpha.md)
+ docs/weighted-alpha.md view
@@ -0,0 +1,32 @@+# Exact weighted alpha filtration++`Moonlight.Triangulation.RegularAlpha` derives a signed exact alpha filtration+from the canonical `RegularTriangulation`. It reuses resident regular faces,+edges, weighted-dual points, rays, and lines; no second weighted geometry is+constructed.++```haskell+filtration <- regularAlphaFiltration regular+filtered <-+  filteredPlanarComplex+    (regularAlphaComplex filtration)+    (regularAlphaBirths filtration)+pairs <- mod2PersistentPairs filtered+```++`PowerAlphaBirth` is an opaque exact rational. Negative births are lawful: a+positive site weight can make a simplex present before power radius zero.+Hidden and coincident-subordinate sites remain in the editable regular value but+contribute no simplex. `filteredPlanarComplex` is the only lowering boundary;+Homology owns chain and filtration validation.++Use ordinary `alphaFiltration` for an unweighted Delaunay DCEL. Use+`regularAlphaFiltration` when weights, exact dual rays, or repeated regular-site+edits are semantic inputs.++```console+cabal bench moonlight-triangulation-alpha-bench+```++[Return to the operation index.](../README.md#operations)+· [Edit the regular site section.](./regular-site-algebra.md)
+ ffi/abi/Moonlight/Triangulation/Foreign/Boundary.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE TypeFamilies #-}++module Moonlight.Triangulation.Foreign.Boundary+  ( GeometryMesh+  , HandleValue+  , checkedCount+  , dereferenceHandle+  , freeHandle+  , prepareHandleOutput+  , produceHandle+  , publishHandle+  , readPoints+  , requireOutputCapacity+  , requirePointer+  , runBoundary+  ) where++import Control.Exception (SomeException, try)+import Foreign.C.Types (CDouble (..), CSize, CUInt)+import Foreign.Ptr (Ptr, castPtr, nullPtr)+import Foreign.StablePtr+  ( StablePtr+  , castPtrToStablePtr+  , castStablePtrToPtr+  , deRefStablePtr+  , freeStablePtr+  , newStablePtr+  )+import Foreign.Storable (peekElemOff, poke)+import qualified Data.Vector as V+import qualified Moonlight.Triangulation as T+import Moonlight.Triangulation.Foreign.Contract+  ( CMesh+  , CObstruction+  , CRegion+  , CStructuringElement+  )+import Moonlight.Triangulation.Foreign.Obstruction+  ( AbiFailure (..)+  , bufferTooSmallFailure+  , countOverflowFailure+  , emptyObstruction+  , nullPointerFailure+  , runtimeFailure+  , statusOk+  )++type GeometryMesh = T.DelaunayTriangulation ()++type family HandleValue carrier where+  HandleValue CMesh = GeometryMesh+  HandleValue CRegion = T.PlanarRegion+  HandleValue CStructuringElement = T.StructuringElement++runBoundary :: Ptr CObstruction -> IO (Either AbiFailure ()) -> IO CUInt+runBoundary obstructionPointer action = do+  writeObstruction obstructionPointer emptyObstruction+  outcome <- try action :: IO (Either SomeException (Either AbiFailure ()))+  case outcome of+    Left exception -> finishFailure obstructionPointer (runtimeFailure exception)+    Right (Left failure) -> finishFailure obstructionPointer failure+    Right (Right ()) -> pure statusOk++finishFailure :: Ptr CObstruction -> AbiFailure -> IO CUInt+finishFailure obstructionPointer (AbiFailure status obstruction) = do+  writeObstruction obstructionPointer obstruction+  pure status++writeObstruction :: Ptr CObstruction -> CObstruction -> IO ()+writeObstruction pointer obstruction+  | pointer == nullPtr = pure ()+  | otherwise = poke pointer obstruction++requirePointer :: String -> Ptr value -> Either AbiFailure ()+requirePointer label pointer+  | pointer == nullPtr = Left (nullPointerFailure label)+  | otherwise = Right ()++checkedCount :: Int -> CSize -> Either AbiFailure Int+checkedCount elementsPerItem rawCount+  | toInteger rawCount * toInteger elementsPerItem > toInteger (maxBound :: Int) =+      Left (countOverflowFailure (fromIntegral rawCount))+  | otherwise = Right (fromIntegral rawCount)++readPoints :: Ptr CDouble -> Int -> IO (Either AbiFailure (V.Vector T.Point))+readPoints pointer count+  | count == 0 = pure (Right V.empty)+  | pointer == nullPtr = pure (Left (nullPointerFailure "coordinates"))+  | otherwise =+      Right+        <$> V.generateM+          count+          ( \index -> do+              CDouble x <- peekElemOff pointer (index * 2)+              CDouble y <- peekElemOff pointer (index * 2 + 1)+              pure (T.Point x y)+          )++prepareHandleOutput :: Ptr (Ptr carrier) -> IO (Either AbiFailure ())+prepareHandleOutput pointer =+  case requirePointer "result" pointer of+    Left failure -> pure (Left failure)+    Right () -> poke pointer nullPtr >> pure (Right ())++publishHandle :: Ptr (Ptr carrier) -> HandleValue carrier -> IO ()+publishHandle output value = do+  stable <- newStablePtr value+  poke output (castPtr (castStablePtrToPtr stable))++produceHandle+  :: Ptr (Ptr carrier)+  -> IO (Either AbiFailure (HandleValue carrier))+  -> IO (Either AbiFailure ())+produceHandle output obtain = do+  prepared <- prepareHandleOutput output+  case prepared of+    Left failure -> pure (Left failure)+    Right () -> do+      outcome <- obtain+      case outcome of+        Left failure -> pure (Left failure)+        Right value -> publishHandle output value >> pure (Right ())++dereferenceHandle :: Ptr carrier -> IO (HandleValue carrier)+dereferenceHandle pointer = deRefStablePtr (castPtrToStablePtr (castPtr pointer))++freeHandle :: Ptr carrier -> IO ()+freeHandle pointer+  | pointer == nullPtr = pure ()+  | otherwise = freeStablePtr (castPtrToStablePtr (castPtr pointer) :: StablePtr ())++requireOutputCapacity :: String -> Ptr value -> Int -> Int -> Either AbiFailure ()+requireOutputCapacity label output required capacity+  | capacity < required = Left (bufferTooSmallFailure required capacity)+  | required > 0 = requirePointer label output+  | otherwise = Right ()
+ ffi/abi/Moonlight/Triangulation/Foreign/Contract.hs view
@@ -0,0 +1,650 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}++module Moonlight.Triangulation.Foreign.Contract+  ( AbiField (..)+  , AbiFieldType (..)+  , AbiFunction+  , AbiFunctionFamily (..)+  , AbiFunctionImplementation (..)+  , AbiFunctionName (..)+  , AbiHandle (..)+  , AbiParameter (..)+  , AbiParameterKind (..)+  , AbiResult (..)+  , AbiStatus (..)+  , AbiStruct (..)+  , CMesh+  , CMinkowskiReceipt (..)+  , CObstruction (..)+  , CRegion+  , CStructuringElement+  , CoordinateErrorCode (..)+  , MinkowskiOperationCode (..)+  , ObstructionCode (..)+  , RegionLocationCode (..)+  , abiFunction+  , abiFunctionImplementation+  , abiFunctionParameters+  , abiFunctionResult+  , abiFunctionSymbol+  , abiHandleSymbol+  , abiStatusId+  , abiStatusSymbol+  , abiStructFields+  , abiStructSymbol+  , abiVersion+  , allAbiFunctionNames+  , allAbiFunctions+  , allAbiHandles+  , allAbiStatuses+  , allAbiStructs+  , allCoordinateErrorCodes+  , allMinkowskiOperationCodes+  , allObstructionCodes+  , allRegionLocationCodes+  , coordinateErrorCodeId+  , coordinateErrorCodeSymbol+  , minkowskiOperationCodeId+  , minkowskiOperationCodeSymbol+  , obstructionCodeId+  , obstructionCodeSymbol+  , regionLocationCodeId+  , regionLocationCodeSymbol+  ) where++import Data.Word (Word32, Word64)+import Foreign.C.String (peekCString, withCStringLen)+import Foreign.C.Types (CChar)+import Foreign.Marshal.Utils (copyBytes, fillBytes)+import Foreign.Ptr (Ptr, castPtr, plusPtr)+import Foreign.Storable (Storable (..))+import GHC.Generics (Generic)++abiVersion :: Word32+abiVersion = 2++data AbiStatus+  = AbiStatusOk+  | AbiStatusNullPointer+  | AbiStatusCountOverflow+  | AbiStatusBufferTooSmall+  | AbiStatusGeometryObstruction+  | AbiStatusRuntimeFailure+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++allAbiStatuses :: [AbiStatus]+allAbiStatuses = [minBound .. maxBound]++abiStatusId :: AbiStatus -> Word32+abiStatusId status =+  case status of+    AbiStatusOk -> 0+    AbiStatusNullPointer -> 1+    AbiStatusCountOverflow -> 2+    AbiStatusBufferTooSmall -> 3+    AbiStatusGeometryObstruction -> 4+    AbiStatusRuntimeFailure -> 5++abiStatusSymbol :: AbiStatus -> String+abiStatusSymbol status =+  case status of+    AbiStatusOk -> "ML_STATUS_OK"+    AbiStatusNullPointer -> "ML_STATUS_NULL_POINTER"+    AbiStatusCountOverflow -> "ML_STATUS_COUNT_OVERFLOW"+    AbiStatusBufferTooSmall -> "ML_STATUS_BUFFER_TOO_SMALL"+    AbiStatusGeometryObstruction -> "ML_STATUS_GEOMETRY_OBSTRUCTION"+    AbiStatusRuntimeFailure -> "ML_STATUS_RUNTIME_FAILURE"++data ObstructionCode+  = ObstructionNone+  | ObstructionInvalidCoordinate+  | ObstructionPointLocationFailed+  | ObstructionLocationWalkExhausted+  | ObstructionRefinementInputTopologyInvalid+  | ObstructionFreshInsertionMatchedExistingVertex+  | ObstructionDegenerateLineEndpointMissingOutgoing+  | ObstructionDegenerateLineEndpointTurnMissing+  | ObstructionDegenerateLineConnectedVertexMissing+  | ObstructionHullStartNotVisible+  | ObstructionOuterRangeDidNotTerminate+  | ObstructionOuterRangeContainsInnerEdge+  | ObstructionConstrainedEdgeFlipRefused+  | ObstructionRemovalVertexOutOfRange+  | ObstructionRemovalEdgeOutOfRange+  | ObstructionRemovalFaceOutOfRange+  | ObstructionRemovalFaceCycleDidNotTerminate+  | ObstructionRemovalEmptyTriangulation+  | ObstructionRemovalTwoPointDegreeMismatch+  | ObstructionRemovalCollinearDegreeMismatch+  | ObstructionRemovalBorderTooShort+  | ObstructionRemovalBorderArityMismatch+  | ObstructionRemovalOutgoingCycleDidNotTerminate+  | ObstructionCircleSweepHullEmpty+  | ObstructionOuterCycleDidNotTerminate+  | ObstructionHierarchyLevelPopulationMismatch+  | ObstructionHierarchyInsertionHandleMismatch+  | ObstructionPointIndexCapacityExhausted+  | ObstructionRefinementMinimumAngleNotFinite+  | ObstructionRefinementMinimumAngleOutOfRange+  | ObstructionRefinementMinimumAngleDerivedRatioNotFinite+  | ObstructionRefinementMaximumAdditionalVerticesNegative+  | ObstructionRefinementMinimumAreaNotFinite+  | ObstructionRefinementMinimumAreaNegative+  | ObstructionRefinementMaximumAreaNotFinite+  | ObstructionRefinementMaximumAreaNotPositive+  | ObstructionRefinementMaximumRadiusEdgeRatioNotFinite+  | ObstructionRefinementMaximumRadiusEdgeRatioNotPositive+  | ObstructionRefinementMinimumAreaExceedsMaximum+  | ObstructionRefinementSeedFaceNotActive+  | ObstructionRefinementDomainInterfaceEdgeNotActive+  | ObstructionRefinementDomainInterfaceMissing+  | ObstructionRefinementDomainInterfaceExtraneous+  | ObstructionRefinementDomainTopologyChanged+  | ObstructionRefinementDomainRequiresConvexHullPreservation+  | ObstructionRefinementDomainRequiresConstraintPreservation+  | ObstructionRefinementDomainForbidsOuterFaceExclusion+  | ObstructionRefinementDomainWouldCrossInterface+  | ObstructionRefinementDomainWouldRewriteProtectedFace+  | ObstructionRefinementDomainProtectedFaceChanged+  | ObstructionCapacityExceeded+  | ObstructionHalfEdgeCapacityExceeded+  | ObstructionFaceCapacityExceeded+  | ObstructionPayloadStorageFailure+  | ObstructionCoordinatePayloadCountMismatch+  | ObstructionCircleSweepRequiresDenseStorage+  | ObstructionSeamFrontierUnavailable+  | ObstructionRefinementDomainRequiresFiniteVertexBudget+  | ObstructionSeamSourceEdgeRequiresFlip+  | ObstructionSeamProtectedSourceFaceChanged+  | ObstructionRefinementMaximumEdgeLengthNotFinite+  | ObstructionRefinementMaximumEdgeLengthNotPositive+  | ObstructionRefinementOversizedEdge+  | ObstructionRefinementSeamBridgeBudgetExceeded+  | ObstructionRefinementSeamBridgeMidpointCollapsed+  | ObstructionBoundarySplitRequiresBoundaryEdge+  | ObstructionRefinementDomainInterfaceOppositeFaceNotPermitted+  | ObstructionNullPointer+  | ObstructionCountOverflow+  | ObstructionBufferTooSmall+  | ObstructionRuntimeFailure+  | ObstructionRegionLayoutInvalid+  | ObstructionRegionValidationFailed+  | ObstructionOverlayFailed+  | ObstructionRegionPublicationFailed+  | ObstructionValuationFailed+  | ObstructionMinkowskiFailed+  | ObstructionRegionProjectionFailed+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++allObstructionCodes :: [ObstructionCode]+allObstructionCodes = [minBound .. maxBound]++obstructionCodeId :: ObstructionCode -> Word32+obstructionCodeId code = fst (obstructionCodeMetadata code)++obstructionCodeSymbol :: ObstructionCode -> String+obstructionCodeSymbol code = snd (obstructionCodeMetadata code)++obstructionCodeMetadata :: ObstructionCode -> (Word32, String)+obstructionCodeMetadata code =+  case code of+    ObstructionNone -> (0, "ML_OBSTRUCTION_NONE")+    ObstructionInvalidCoordinate -> (1, "ML_OBSTRUCTION_INVALID_COORDINATE")+    ObstructionPointLocationFailed -> (2, "ML_OBSTRUCTION_POINT_LOCATION_FAILED")+    ObstructionLocationWalkExhausted -> (3, "ML_OBSTRUCTION_LOCATION_WALK_EXHAUSTED")+    ObstructionRefinementInputTopologyInvalid -> (4, "ML_OBSTRUCTION_REFINEMENT_INPUT_TOPOLOGY_INVALID")+    ObstructionFreshInsertionMatchedExistingVertex -> (5, "ML_OBSTRUCTION_FRESH_INSERTION_MATCHED_EXISTING_VERTEX")+    ObstructionDegenerateLineEndpointMissingOutgoing -> (6, "ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_MISSING_OUTGOING")+    ObstructionDegenerateLineEndpointTurnMissing -> (7, "ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_TURN_MISSING")+    ObstructionDegenerateLineConnectedVertexMissing -> (8, "ML_OBSTRUCTION_DEGENERATE_LINE_CONNECTED_VERTEX_MISSING")+    ObstructionHullStartNotVisible -> (9, "ML_OBSTRUCTION_HULL_START_NOT_VISIBLE")+    ObstructionOuterRangeDidNotTerminate -> (10, "ML_OBSTRUCTION_OUTER_RANGE_DID_NOT_TERMINATE")+    ObstructionOuterRangeContainsInnerEdge -> (11, "ML_OBSTRUCTION_OUTER_RANGE_CONTAINS_INNER_EDGE")+    ObstructionConstrainedEdgeFlipRefused -> (12, "ML_OBSTRUCTION_CONSTRAINED_EDGE_FLIP_REFUSED")+    ObstructionRemovalVertexOutOfRange -> (13, "ML_OBSTRUCTION_REMOVAL_VERTEX_OUT_OF_RANGE")+    ObstructionRemovalEdgeOutOfRange -> (14, "ML_OBSTRUCTION_REMOVAL_EDGE_OUT_OF_RANGE")+    ObstructionRemovalFaceOutOfRange -> (15, "ML_OBSTRUCTION_REMOVAL_FACE_OUT_OF_RANGE")+    ObstructionRemovalFaceCycleDidNotTerminate -> (16, "ML_OBSTRUCTION_REMOVAL_FACE_CYCLE_DID_NOT_TERMINATE")+    ObstructionRemovalEmptyTriangulation -> (17, "ML_OBSTRUCTION_REMOVAL_EMPTY_TRIANGULATION")+    ObstructionRemovalTwoPointDegreeMismatch -> (18, "ML_OBSTRUCTION_REMOVAL_TWO_POINT_DEGREE_MISMATCH")+    ObstructionRemovalCollinearDegreeMismatch -> (19, "ML_OBSTRUCTION_REMOVAL_COLLINEAR_DEGREE_MISMATCH")+    ObstructionRemovalBorderTooShort -> (20, "ML_OBSTRUCTION_REMOVAL_BORDER_TOO_SHORT")+    ObstructionRemovalBorderArityMismatch -> (21, "ML_OBSTRUCTION_REMOVAL_BORDER_ARITY_MISMATCH")+    ObstructionRemovalOutgoingCycleDidNotTerminate -> (22, "ML_OBSTRUCTION_REMOVAL_OUTGOING_CYCLE_DID_NOT_TERMINATE")+    ObstructionCircleSweepHullEmpty -> (23, "ML_OBSTRUCTION_CIRCLE_SWEEP_HULL_EMPTY")+    ObstructionOuterCycleDidNotTerminate -> (24, "ML_OBSTRUCTION_OUTER_CYCLE_DID_NOT_TERMINATE")+    ObstructionHierarchyLevelPopulationMismatch -> (25, "ML_OBSTRUCTION_HIERARCHY_LEVEL_POPULATION_MISMATCH")+    ObstructionHierarchyInsertionHandleMismatch -> (26, "ML_OBSTRUCTION_HIERARCHY_INSERTION_HANDLE_MISMATCH")+    ObstructionPointIndexCapacityExhausted -> (27, "ML_OBSTRUCTION_POINT_INDEX_CAPACITY_EXHAUSTED")+    ObstructionRefinementMinimumAngleNotFinite -> (28, "ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_NOT_FINITE")+    ObstructionRefinementMinimumAngleOutOfRange -> (29, "ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_OUT_OF_RANGE")+    ObstructionRefinementMinimumAngleDerivedRatioNotFinite -> (30, "ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_DERIVED_RATIO_NOT_FINITE")+    ObstructionRefinementMaximumAdditionalVerticesNegative -> (31, "ML_OBSTRUCTION_REFINEMENT_MAXIMUM_ADDITIONAL_VERTICES_NEGATIVE")+    ObstructionRefinementMinimumAreaNotFinite -> (32, "ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NOT_FINITE")+    ObstructionRefinementMinimumAreaNegative -> (33, "ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NEGATIVE")+    ObstructionRefinementMaximumAreaNotFinite -> (34, "ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_FINITE")+    ObstructionRefinementMaximumAreaNotPositive -> (35, "ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_POSITIVE")+    ObstructionRefinementMaximumRadiusEdgeRatioNotFinite -> (36, "ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_FINITE")+    ObstructionRefinementMaximumRadiusEdgeRatioNotPositive -> (37, "ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_POSITIVE")+    ObstructionRefinementMinimumAreaExceedsMaximum -> (38, "ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_EXCEEDS_MAXIMUM")+    ObstructionRefinementSeedFaceNotActive -> (39, "ML_OBSTRUCTION_REFINEMENT_SEED_FACE_NOT_ACTIVE")+    ObstructionRefinementDomainInterfaceEdgeNotActive -> (40, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EDGE_NOT_ACTIVE")+    ObstructionRefinementDomainInterfaceMissing -> (41, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_MISSING")+    ObstructionRefinementDomainInterfaceExtraneous -> (42, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EXTRANEOUS")+    ObstructionRefinementDomainTopologyChanged -> (43, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_TOPOLOGY_CHANGED")+    ObstructionRefinementDomainRequiresConvexHullPreservation -> (44, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONVEX_HULL_PRESERVATION")+    ObstructionRefinementDomainRequiresConstraintPreservation -> (45, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONSTRAINT_PRESERVATION")+    ObstructionRefinementDomainForbidsOuterFaceExclusion -> (46, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_FORBIDS_OUTER_FACE_EXCLUSION")+    ObstructionRefinementDomainWouldCrossInterface -> (47, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_CROSS_INTERFACE")+    ObstructionRefinementDomainWouldRewriteProtectedFace -> (48, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_REWRITE_PROTECTED_FACE")+    ObstructionRefinementDomainProtectedFaceChanged -> (49, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_PROTECTED_FACE_CHANGED")+    ObstructionCapacityExceeded -> (50, "ML_OBSTRUCTION_CAPACITY_EXCEEDED")+    ObstructionHalfEdgeCapacityExceeded -> (51, "ML_OBSTRUCTION_HALF_EDGE_CAPACITY_EXCEEDED")+    ObstructionFaceCapacityExceeded -> (52, "ML_OBSTRUCTION_FACE_CAPACITY_EXCEEDED")+    ObstructionPayloadStorageFailure -> (53, "ML_OBSTRUCTION_PAYLOAD_STORAGE_FAILURE")+    ObstructionCoordinatePayloadCountMismatch -> (54, "ML_OBSTRUCTION_COORDINATE_PAYLOAD_COUNT_MISMATCH")+    ObstructionCircleSweepRequiresDenseStorage -> (55, "ML_OBSTRUCTION_CIRCLE_SWEEP_REQUIRES_DENSE_STORAGE")+    ObstructionSeamFrontierUnavailable -> (56, "ML_OBSTRUCTION_SEAM_FRONTIER_UNAVAILABLE")+    ObstructionRefinementDomainRequiresFiniteVertexBudget -> (57, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_FINITE_VERTEX_BUDGET")+    ObstructionSeamSourceEdgeRequiresFlip -> (58, "ML_OBSTRUCTION_SEAM_SOURCE_EDGE_REQUIRES_FLIP")+    ObstructionSeamProtectedSourceFaceChanged -> (59, "ML_OBSTRUCTION_SEAM_PROTECTED_SOURCE_FACE_CHANGED")+    ObstructionRefinementMaximumEdgeLengthNotFinite -> (60, "ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_FINITE")+    ObstructionRefinementMaximumEdgeLengthNotPositive -> (61, "ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_POSITIVE")+    ObstructionRefinementOversizedEdge -> (62, "ML_OBSTRUCTION_REFINEMENT_OVERSIZED_EDGE")+    ObstructionRefinementSeamBridgeBudgetExceeded -> (63, "ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_BUDGET_EXCEEDED")+    ObstructionRefinementSeamBridgeMidpointCollapsed -> (64, "ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_MIDPOINT_COLLAPSED")+    ObstructionBoundarySplitRequiresBoundaryEdge -> (65, "ML_OBSTRUCTION_BOUNDARY_SPLIT_REQUIRES_BOUNDARY_EDGE")+    ObstructionRefinementDomainInterfaceOppositeFaceNotPermitted -> (66, "ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_OPPOSITE_FACE_NOT_PERMITTED")+    ObstructionNullPointer -> (100, "ML_OBSTRUCTION_NULL_POINTER")+    ObstructionCountOverflow -> (101, "ML_OBSTRUCTION_COUNT_OVERFLOW")+    ObstructionBufferTooSmall -> (102, "ML_OBSTRUCTION_BUFFER_TOO_SMALL")+    ObstructionRuntimeFailure -> (103, "ML_OBSTRUCTION_RUNTIME_FAILURE")+    ObstructionRegionLayoutInvalid -> (200, "ML_OBSTRUCTION_REGION_LAYOUT_INVALID")+    ObstructionRegionValidationFailed -> (201, "ML_OBSTRUCTION_REGION_VALIDATION_FAILED")+    ObstructionOverlayFailed -> (202, "ML_OBSTRUCTION_OVERLAY_FAILED")+    ObstructionRegionPublicationFailed -> (203, "ML_OBSTRUCTION_REGION_PUBLICATION_FAILED")+    ObstructionValuationFailed -> (204, "ML_OBSTRUCTION_VALUATION_FAILED")+    ObstructionMinkowskiFailed -> (205, "ML_OBSTRUCTION_MINKOWSKI_FAILED")+    ObstructionRegionProjectionFailed -> (206, "ML_OBSTRUCTION_REGION_PROJECTION_FAILED")++data CoordinateErrorCode+  = CoordinateErrorNone+  | CoordinateErrorNaN+  | CoordinateErrorInfinite+  | CoordinateErrorTooSmall+  | CoordinateErrorTooLarge+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++allCoordinateErrorCodes :: [CoordinateErrorCode]+allCoordinateErrorCodes = [minBound .. maxBound]++coordinateErrorCodeId :: CoordinateErrorCode -> Word32+coordinateErrorCodeId code =+  case code of+    CoordinateErrorNone -> 0+    CoordinateErrorNaN -> 1+    CoordinateErrorInfinite -> 2+    CoordinateErrorTooSmall -> 3+    CoordinateErrorTooLarge -> 4++coordinateErrorCodeSymbol :: CoordinateErrorCode -> String+coordinateErrorCodeSymbol code =+  case code of+    CoordinateErrorNone -> "ML_COORDINATE_ERROR_NONE"+    CoordinateErrorNaN -> "ML_COORDINATE_ERROR_NAN"+    CoordinateErrorInfinite -> "ML_COORDINATE_ERROR_INFINITE"+    CoordinateErrorTooSmall -> "ML_COORDINATE_ERROR_TOO_SMALL"+    CoordinateErrorTooLarge -> "ML_COORDINATE_ERROR_TOO_LARGE"++data RegionLocationCode+  = RegionLocationExterior+  | RegionLocationBoundary+  | RegionLocationInterior+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++allRegionLocationCodes :: [RegionLocationCode]+allRegionLocationCodes = [minBound .. maxBound]++regionLocationCodeId :: RegionLocationCode -> Word32+regionLocationCodeId code =+  case code of+    RegionLocationExterior -> 0+    RegionLocationBoundary -> 1+    RegionLocationInterior -> 2++regionLocationCodeSymbol :: RegionLocationCode -> String+regionLocationCodeSymbol code =+  case code of+    RegionLocationExterior -> "ML_REGION_EXTERIOR"+    RegionLocationBoundary -> "ML_REGION_BOUNDARY"+    RegionLocationInterior -> "ML_REGION_INTERIOR"++data MinkowskiOperationCode+  = MinkowskiOperationAddition+  | MinkowskiOperationErosion+  | MinkowskiOperationOpening+  | MinkowskiOperationClosing+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++allMinkowskiOperationCodes :: [MinkowskiOperationCode]+allMinkowskiOperationCodes = [minBound .. maxBound]++minkowskiOperationCodeId :: MinkowskiOperationCode -> Word32+minkowskiOperationCodeId code =+  case code of+    MinkowskiOperationAddition -> 0+    MinkowskiOperationErosion -> 1+    MinkowskiOperationOpening -> 2+    MinkowskiOperationClosing -> 3++minkowskiOperationCodeSymbol :: MinkowskiOperationCode -> String+minkowskiOperationCodeSymbol code =+  case code of+    MinkowskiOperationAddition -> "ML_MINKOWSKI_ADDITION"+    MinkowskiOperationErosion -> "ML_MINKOWSKI_EROSION"+    MinkowskiOperationOpening -> "ML_MINKOWSKI_OPENING"+    MinkowskiOperationClosing -> "ML_MINKOWSKI_CLOSING"++data CMesh+data CRegion+data CStructuringElement++data CObstruction = CObstruction+  { obstructionCode :: !Word32+  , obstructionCoordinateError :: !Word32+  , obstructionInputIndex :: !Word64+  , obstructionFirstIndex :: !Word64+  , obstructionSecondIndex :: !Word64+  , obstructionFirstValue :: !Double+  , obstructionSecondValue :: !Double+  , obstructionPointX :: !Double+  , obstructionPointY :: !Double+  , obstructionMessage :: !String+  }+  deriving stock (Eq, Show, Generic)++instance Storable CObstruction where+  sizeOf _ = 320+  alignment _ = alignment (0 :: Word64)+  peek pointer = do+    obstructionCode <- peekByteOff pointer 0+    obstructionCoordinateError <- peekByteOff pointer 4+    obstructionInputIndex <- peekByteOff pointer 8+    obstructionFirstIndex <- peekByteOff pointer 16+    obstructionSecondIndex <- peekByteOff pointer 24+    obstructionFirstValue <- peekByteOff pointer 32+    obstructionSecondValue <- peekByteOff pointer 40+    obstructionPointX <- peekByteOff pointer 48+    obstructionPointY <- peekByteOff pointer 56+    obstructionMessage <- peekCString (castPtr pointer `plusPtr` 64)+    pure CObstruction {..}+  poke pointer CObstruction {..} = do+    pokeByteOff pointer 0 obstructionCode+    pokeByteOff pointer 4 obstructionCoordinateError+    pokeByteOff pointer 8 obstructionInputIndex+    pokeByteOff pointer 16 obstructionFirstIndex+    pokeByteOff pointer 24 obstructionSecondIndex+    pokeByteOff pointer 32 obstructionFirstValue+    pokeByteOff pointer 40 obstructionSecondValue+    pokeByteOff pointer 48 obstructionPointX+    pokeByteOff pointer 56 obstructionPointY+    let messagePointer = castPtr pointer `plusPtr` 64 :: Ptr CChar+    fillBytes messagePointer 0 256+    withCStringLen obstructionMessage $ \(source, lengthInBytes) ->+      copyBytes messagePointer source (min 255 lengthInBytes)++data CMinkowskiReceipt = CMinkowskiReceipt+  { receiptOperation :: !Word32+  , receiptInputComponents :: !Word64+  , receiptConvexPieces :: !Word64+  , receiptGeneratedPieces :: !Word64+  , receiptGeneratedConvolutionEdges :: !Word64+  , receiptOverlayPasses :: !Word64+  , receiptExactCrossings :: !Word64+  , receiptOutputCells :: !Word64+  , receiptExactCoordinateBitGrowth :: !Word64+  }+  deriving stock (Eq, Show, Generic)++instance Storable CMinkowskiReceipt where+  sizeOf _ = 72+  alignment _ = alignment (0 :: Word64)+  peek pointer = do+    receiptOperation <- peekByteOff pointer 0+    receiptInputComponents <- peekByteOff pointer 8+    receiptConvexPieces <- peekByteOff pointer 16+    receiptGeneratedPieces <- peekByteOff pointer 24+    receiptGeneratedConvolutionEdges <- peekByteOff pointer 32+    receiptOverlayPasses <- peekByteOff pointer 40+    receiptExactCrossings <- peekByteOff pointer 48+    receiptOutputCells <- peekByteOff pointer 56+    receiptExactCoordinateBitGrowth <- peekByteOff pointer 64+    pure CMinkowskiReceipt {..}+  poke pointer CMinkowskiReceipt {..} = do+    pokeByteOff pointer 0 receiptOperation+    pokeByteOff pointer 4 (0 :: Word32)+    pokeByteOff pointer 8 receiptInputComponents+    pokeByteOff pointer 16 receiptConvexPieces+    pokeByteOff pointer 24 receiptGeneratedPieces+    pokeByteOff pointer 32 receiptGeneratedConvolutionEdges+    pokeByteOff pointer 40 receiptOverlayPasses+    pokeByteOff pointer 48 receiptExactCrossings+    pokeByteOff pointer 56 receiptOutputCells+    pokeByteOff pointer 64 receiptExactCoordinateBitGrowth++data AbiFieldType+  = AbiFieldUInt32+  | AbiFieldUInt64+  | AbiFieldDouble+  | AbiFieldCharArray !Int+  deriving stock (Eq, Show, Generic)++data AbiField = AbiField+  { abiFieldName :: !String+  , abiFieldType :: !AbiFieldType+  }+  deriving stock (Eq, Show, Generic)++data AbiStruct+  = AbiStructObstruction+  | AbiStructMinkowskiReceipt+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++allAbiStructs :: [AbiStruct]+allAbiStructs = [minBound .. maxBound]++abiStructSymbol :: AbiStruct -> String+abiStructSymbol structure =+  case structure of+    AbiStructObstruction -> "ml_obstruction"+    AbiStructMinkowskiReceipt -> "ml_minkowski_receipt"++abiStructFields :: AbiStruct -> [AbiField]+abiStructFields structure =+  case structure of+    AbiStructObstruction ->+      [ AbiField "code" AbiFieldUInt32+      , AbiField "coordinate_error" AbiFieldUInt32+      , AbiField "input_index" AbiFieldUInt64+      , AbiField "first_index" AbiFieldUInt64+      , AbiField "second_index" AbiFieldUInt64+      , AbiField "first_value" AbiFieldDouble+      , AbiField "second_value" AbiFieldDouble+      , AbiField "point_x" AbiFieldDouble+      , AbiField "point_y" AbiFieldDouble+      , AbiField "message" (AbiFieldCharArray 256)+      ]+    AbiStructMinkowskiReceipt ->+      [ AbiField "operation" AbiFieldUInt32+      , AbiField "reserved" AbiFieldUInt32+      , AbiField "input_components" AbiFieldUInt64+      , AbiField "convex_pieces" AbiFieldUInt64+      , AbiField "generated_pieces" AbiFieldUInt64+      , AbiField "generated_convolution_edges" AbiFieldUInt64+      , AbiField "overlay_passes" AbiFieldUInt64+      , AbiField "exact_crossings" AbiFieldUInt64+      , AbiField "output_cells" AbiFieldUInt64+      , AbiField "exact_coordinate_bit_growth" AbiFieldUInt64+      ]++data AbiHandle+  = AbiMesh+  | AbiRegion+  | AbiStructuringElement+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++allAbiHandles :: [AbiHandle]+allAbiHandles = [minBound .. maxBound]++abiHandleSymbol :: AbiHandle -> String+abiHandleSymbol handle =+  case handle of+    AbiMesh -> "ml_mesh"+    AbiRegion -> "ml_region"+    AbiStructuringElement -> "ml_structuring_element"++data AbiParameterKind+  = AbiValueSize+  | AbiValueDouble+  | AbiHandleInput !AbiHandle+  | AbiHandleRelease !AbiHandle+  | AbiHandleOutput !AbiHandle+  | AbiBufferInputDouble+  | AbiBufferInputSize+  | AbiBufferOutputChar+  | AbiBufferOutputDouble+  | AbiBufferOutputUInt32+  | AbiBufferOutputSize+  | AbiScalarOutputRegionLocation+  | AbiScalarOutputInt64+  | AbiScalarOutputSize+  | AbiScalarOutputDouble+  | AbiStructOutput !AbiStruct+  deriving stock (Eq, Show, Generic)++data AbiParameter = AbiParameter+  { abiParameterName :: !String+  , abiParameterKind :: !AbiParameterKind+  }+  deriving stock (Eq, Show, Generic)++data AbiResult+  = AbiResultVoid+  | AbiResultUInt32+  | AbiResultStatus+  deriving stock (Eq, Show, Generic)++data AbiFunctionFamily+  = AbiFunctionMesh+  | AbiFunctionRegion+  | AbiFunctionMorphology+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++data AbiFunctionImplementation+  = AbiFunctionRuntime+  | AbiFunctionHaskell !AbiFunctionFamily !String+  deriving stock (Eq, Show, Generic)++data AbiFunctionName+  = AbiVersion+  | RuntimeInitialize+  | DelaunayF64+  | MeshInsertManyF64+  | MeshSiteUnion+  | MeshSiteIntersection+  | MeshSiteDifference+  | MeshSiteSymmetricDifference+  | MeshVertexCount+  | MeshTriangleCount+  | MeshCopyVerticesF64+  | MeshCopyTrianglesU32+  | MeshFree+  | RegionCreateF64+  | RegionCounts+  | RegionCopyF64+  | RegionUnion+  | RegionIntersection+  | RegionDifference+  | RegionSymmetricDifference+  | RegionLocatePointF64+  | RegionMeasure+  | RegionFree+  | StructuringElementCreateF64+  | StructuringElementFree+  | RegionMinkowskiSum+  | RegionOffset+  | RegionInset+  | RegionOpen+  | RegionClose+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++data AbiFunction = AbiFunction+  { abiFunctionImplementation :: !AbiFunctionImplementation+  , abiFunctionSymbol :: !String+  , abiFunctionResult :: !AbiResult+  , abiFunctionParameters :: ![AbiParameter]+  }+  deriving stock (Eq, Show, Generic)++allAbiFunctionNames :: [AbiFunctionName]+allAbiFunctionNames = [minBound .. maxBound]++allAbiFunctions :: [AbiFunction]+allAbiFunctions = fmap abiFunction allAbiFunctionNames++abiFunction :: AbiFunctionName -> AbiFunction+abiFunction name =+  case name of+    AbiVersion -> runtime "ml_abi_version" AbiResultUInt32 []+    RuntimeInitialize -> runtime "ml_runtime_initialize" AbiResultStatus []+    DelaunayF64 -> mesh "ml_delaunay_f64" "delaunayF64" AbiResultStatus [inputDoubles "coordinates", valueSize "point_count", outputHandle "result" AbiMesh, obstruction]+    MeshInsertManyF64 -> mesh "ml_mesh_insert_many_f64" "meshInsertManyF64" AbiResultStatus [inputHandle "mesh" AbiMesh, inputDoubles "coordinates", valueSize "point_count", outputHandle "result" AbiMesh, obstruction]+    MeshSiteUnion -> binaryMesh "ml_mesh_site_union" "meshSiteUnion"+    MeshSiteIntersection -> binaryMesh "ml_mesh_site_intersection" "meshSiteIntersection"+    MeshSiteDifference -> binaryMesh "ml_mesh_site_difference" "meshSiteDifference"+    MeshSiteSymmetricDifference -> binaryMesh "ml_mesh_site_symmetric_difference" "meshSiteSymmetricDifference"+    MeshVertexCount -> meshCount "ml_mesh_vertex_count" "meshVertexCount"+    MeshTriangleCount -> meshCount "ml_mesh_triangle_count" "meshTriangleCount"+    MeshCopyVerticesF64 -> mesh "ml_mesh_copy_vertices_f64" "meshCopyVerticesF64" AbiResultStatus [inputHandle "mesh" AbiMesh, AbiParameter "coordinates" AbiBufferOutputDouble, valueSize "point_capacity", AbiParameter "points_written" AbiScalarOutputSize, obstruction]+    MeshCopyTrianglesU32 -> mesh "ml_mesh_copy_triangles_u32" "meshCopyTrianglesU32" AbiResultStatus [inputHandle "mesh" AbiMesh, AbiParameter "triangles" AbiBufferOutputUInt32, valueSize "triangle_capacity", AbiParameter "triangles_written" AbiScalarOutputSize, obstruction]+    MeshFree -> mesh "ml_mesh_free" "meshFree" AbiResultVoid [releaseHandle "mesh" AbiMesh]+    RegionCreateF64 -> region "ml_region_create_f64" "regionCreateF64" AbiResultStatus [inputDoubles "coordinates", valueSize "point_count", AbiParameter "loop_point_counts" AbiBufferInputSize, valueSize "loop_count", AbiParameter "component_loop_counts" AbiBufferInputSize, valueSize "component_count", outputHandle "result" AbiRegion, obstruction]+    RegionCounts -> region "ml_region_counts" "regionCounts" AbiResultStatus [inputHandle "region" AbiRegion, AbiParameter "component_count" AbiScalarOutputSize, AbiParameter "loop_count" AbiScalarOutputSize, AbiParameter "point_count" AbiScalarOutputSize, obstruction]+    RegionCopyF64 -> region "ml_region_copy_f64" "regionCopyF64" AbiResultStatus [inputHandle "region" AbiRegion, AbiParameter "coordinates" AbiBufferOutputDouble, valueSize "point_capacity", AbiParameter "loop_point_offsets" AbiBufferOutputSize, valueSize "loop_offset_capacity", AbiParameter "component_loop_offsets" AbiBufferOutputSize, valueSize "component_offset_capacity", obstruction]+    RegionUnion -> binaryRegion "ml_region_union" "regionUnion"+    RegionIntersection -> binaryRegion "ml_region_intersection" "regionIntersection"+    RegionDifference -> binaryRegion "ml_region_difference" "regionDifference"+    RegionSymmetricDifference -> binaryRegion "ml_region_symmetric_difference" "regionSymmetricDifference"+    RegionLocatePointF64 -> region "ml_region_locate_point_f64" "regionLocatePointF64" AbiResultStatus [inputHandle "region" AbiRegion, valueDouble "x", valueDouble "y", AbiParameter "location" AbiScalarOutputRegionLocation, obstruction]+    RegionMeasure -> region "ml_region_measure" "regionMeasure" AbiResultStatus [inputHandle "region" AbiRegion, AbiParameter "euler_characteristic" AbiScalarOutputInt64, AbiParameter "area_ratio_utf8" AbiBufferOutputChar, valueSize "area_capacity", AbiParameter "area_bytes_written" AbiScalarOutputSize, AbiParameter "perimeter_lower" AbiScalarOutputDouble, AbiParameter "perimeter_upper" AbiScalarOutputDouble, obstruction]+    RegionFree -> region "ml_region_free" "regionFree" AbiResultVoid [releaseHandle "region" AbiRegion]+    StructuringElementCreateF64 -> morphology "ml_structuring_element_create_f64" "structuringElementCreateF64" AbiResultStatus [inputDoubles "coordinates", valueSize "point_count", outputHandle "result" AbiStructuringElement, obstruction]+    StructuringElementFree -> morphology "ml_structuring_element_free" "structuringElementFree" AbiResultVoid [releaseHandle "element" AbiStructuringElement]+    RegionMinkowskiSum -> morphologyOperation "ml_region_minkowski_sum" "regionMinkowskiSum" (inputHandle "left" AbiRegion) (inputHandle "right" AbiRegion)+    RegionOffset -> morphologyOperation "ml_region_offset" "regionOffset" (inputHandle "element" AbiStructuringElement) (inputHandle "region" AbiRegion)+    RegionInset -> morphologyOperation "ml_region_inset" "regionInset" (inputHandle "element" AbiStructuringElement) (inputHandle "region" AbiRegion)+    RegionOpen -> morphologyOperation "ml_region_open" "regionOpen" (inputHandle "element" AbiStructuringElement) (inputHandle "region" AbiRegion)+    RegionClose -> morphologyOperation "ml_region_close" "regionClose" (inputHandle "element" AbiStructuringElement) (inputHandle "region" AbiRegion)+ where+  runtime = AbiFunction AbiFunctionRuntime+  implemented family symbol haskellName =+    AbiFunction (AbiFunctionHaskell family haskellName) symbol+  mesh = implemented AbiFunctionMesh+  region = implemented AbiFunctionRegion+  morphology = implemented AbiFunctionMorphology+  binaryMesh symbol haskellName =+    mesh symbol haskellName AbiResultStatus [inputHandle "left" AbiMesh, inputHandle "right" AbiMesh, outputHandle "result" AbiMesh, obstruction]+  meshCount symbol haskellName =+    mesh symbol haskellName AbiResultStatus [inputHandle "mesh" AbiMesh, AbiParameter "count" AbiScalarOutputSize, obstruction]+  binaryRegion symbol haskellName =+    region symbol haskellName AbiResultStatus [inputHandle "left" AbiRegion, inputHandle "right" AbiRegion, outputHandle "result" AbiRegion, obstruction]+  morphologyOperation symbol haskellName first second =+    morphology symbol haskellName AbiResultStatus [first, second, outputHandle "result" AbiRegion, AbiParameter "receipt" (AbiStructOutput AbiStructMinkowskiReceipt), obstruction]+  valueSize parameterName = AbiParameter parameterName AbiValueSize+  valueDouble parameterName = AbiParameter parameterName AbiValueDouble+  inputHandle parameterName handle = AbiParameter parameterName (AbiHandleInput handle)+  releaseHandle parameterName handle = AbiParameter parameterName (AbiHandleRelease handle)+  outputHandle parameterName handle = AbiParameter parameterName (AbiHandleOutput handle)+  inputDoubles parameterName = AbiParameter parameterName AbiBufferInputDouble+  obstruction = AbiParameter "obstruction" (AbiStructOutput AbiStructObstruction)
+ ffi/abi/Moonlight/Triangulation/Foreign/Contract/Render.hs view
@@ -0,0 +1,763 @@+module Moonlight.Triangulation.Foreign.Contract.Render+  ( GeneratedFile (..)+  , generatedFiles+  , renderCHeader+  , renderDefinitionFile+  , renderHaskellExports+  , renderPythonRaw+  , renderRustRaw+  , renderTypeScriptWire+  , renderTypeScriptRaw+  ) where++import Data.Char (toLower, toUpper)+import Data.List (intercalate)+import Data.Maybe (mapMaybe)+import Data.Word (Word32)+import Moonlight.Triangulation.Foreign.Contract++data GeneratedFile = GeneratedFile+  { generatedFilePath :: !FilePath+  , generatedFileContents :: !String+  }+  deriving stock (Eq, Show)++generatedFiles :: [GeneratedFile]+generatedFiles =+  [ GeneratedFile "ffi/include/moonlight_triangulation.h" renderCHeader+  , GeneratedFile "ffi/cbits/moonlight-triangulation.def" renderDefinitionFile+  , GeneratedFile "ffi/exports/Moonlight/Triangulation/Foreign/Exports.hs" renderHaskellExports+  , GeneratedFile "ffi/bindings/typescript/src/wire.generated.ts" renderTypeScriptWire+  , GeneratedFile "ffi/bindings/typescript/src/internal/native.generated.ts" renderTypeScriptRaw+  , GeneratedFile "ffi/bindings/python/src/moonlight_triangulation/_native_generated.py" renderPythonRaw+  , GeneratedFile "ffi/bindings/rust/src/raw_generated.rs" renderRustRaw+  ]++generatedNotice :: String -> String+generatedNotice comment =+  comment+    <> " Generated from Moonlight.Triangulation.Foreign.Contract.\n"+    <> comment+    <> " Run moonlight-triangulation-ffi-contract write; do not edit this file.\n\n"++renderCHeader :: String+renderCHeader =+  generatedNotice "//"+    <> unlines+      [ "#ifndef MOONLIGHT_TRIANGULATION_H"+      , "#define MOONLIGHT_TRIANGULATION_H"+      , ""+      , "#include <stddef.h>"+      , "#include <stdint.h>"+      , ""+      , "#if defined(_WIN32)"+      , "#define ML_API __declspec(dllexport)"+      , "#else"+      , "#define ML_API __attribute__((visibility(\"default\")))"+      , "#endif"+      , ""+      , "#ifdef __cplusplus"+      , "extern \"C\" {"+      , "#endif"+      , ""+      , "#define ML_ABI_VERSION " <> show abiVersion <> "u"+      , ""+      , concatMap renderCOpaqueHandle allAbiHandles+      , "typedef uint32_t ml_status;"+      , "typedef uint32_t ml_obstruction_code;"+      , "typedef uint32_t ml_coordinate_error;"+      , "typedef uint32_t ml_region_location;"+      , "typedef uint32_t ml_minkowski_operation;"+      , ""+      ]+    <> renderCEnum (fmap (wireEntry abiStatusSymbol abiStatusId) allAbiStatuses)+    <> renderCEnum (fmap (wireEntry obstructionCodeSymbol obstructionCodeId) allObstructionCodes)+    <> renderCEnum (fmap (wireEntry coordinateErrorCodeSymbol coordinateErrorCodeId) allCoordinateErrorCodes)+    <> renderCEnum (fmap (wireEntry regionLocationCodeSymbol regionLocationCodeId) allRegionLocationCodes)+    <> renderCEnum (fmap (wireEntry minkowskiOperationCodeSymbol minkowskiOperationCodeId) allMinkowskiOperationCodes)+    <> concatMap renderCStruct allAbiStructs+    <> concatMap renderCFunction allAbiFunctions+    <> unlines+      [ ""+      , "#ifdef __cplusplus"+      , "}"+      , "#endif"+      , ""+      , "#endif"+      ]++wireEntry :: (value -> String) -> (value -> Word32) -> value -> (String, Word32)+wireEntry symbol identifier value = (symbol value, identifier value)++renderCEnum :: [(String, Word32)] -> String+renderCEnum entries =+  "enum {\n"+    <> intercalate ",\n" (fmap (\(symbol, identifier) -> "  " <> symbol <> " = " <> show identifier) entries)+    <> "\n};\n\n"++renderCOpaqueHandle :: AbiHandle -> String+renderCOpaqueHandle handle =+  "typedef struct " <> abiHandleSymbol handle <> " " <> abiHandleSymbol handle <> ";\n"++renderCStruct :: AbiStruct -> String+renderCStruct structure =+  "typedef struct "+    <> abiStructSymbol structure+    <> " {\n"+    <> concatMap renderField (abiStructFields structure)+    <> "} "+    <> abiStructSymbol structure+    <> ";\n\n"+ where+  renderField (AbiField name fieldType) =+    "  " <> cFieldType fieldType <> " " <> name <> cFieldSuffix fieldType <> ";\n"++renderCFunction :: AbiFunction -> String+renderCFunction function =+  "ML_API "+    <> cResultType (abiFunctionResult function)+    <> " "+    <> abiFunctionSymbol function+    <> "("+    <> renderParameters+    <> ");\n"+ where+  parameters = abiFunctionParameters function+  renderParameters =+    if null parameters+      then "void"+      else intercalate ", " (fmap renderParameter parameters)+  renderParameter (AbiParameter name kind) = cParameterType kind <> " " <> name++cFieldType :: AbiFieldType -> String+cFieldType fieldType =+  case fieldType of+    AbiFieldUInt32 -> "uint32_t"+    AbiFieldUInt64 -> "uint64_t"+    AbiFieldDouble -> "double"+    AbiFieldCharArray _ -> "char"++cFieldSuffix :: AbiFieldType -> String+cFieldSuffix fieldType =+  case fieldType of+    AbiFieldCharArray lengthInBytes -> "[" <> show lengthInBytes <> "]"+    _ -> ""++cParameterType :: AbiParameterKind -> String+cParameterType kind =+  case kind of+    AbiValueSize -> "size_t"+    AbiValueDouble -> "double"+    AbiHandleInput handle -> "const " <> abiHandleSymbol handle <> " *"+    AbiHandleRelease handle -> abiHandleSymbol handle <> " *"+    AbiHandleOutput handle -> abiHandleSymbol handle <> " **"+    AbiBufferInputDouble -> "const double *"+    AbiBufferInputSize -> "const size_t *"+    AbiBufferOutputChar -> "char *"+    AbiBufferOutputDouble -> "double *"+    AbiBufferOutputUInt32 -> "uint32_t *"+    AbiBufferOutputSize -> "size_t *"+    AbiScalarOutputRegionLocation -> "ml_region_location *"+    AbiScalarOutputInt64 -> "int64_t *"+    AbiScalarOutputSize -> "size_t *"+    AbiScalarOutputDouble -> "double *"+    AbiStructOutput structure -> abiStructSymbol structure <> " *"++cResultType :: AbiResult -> String+cResultType result =+  case result of+    AbiResultVoid -> "void"+    AbiResultUInt32 -> "uint32_t"+    AbiResultStatus -> "ml_status"++renderDefinitionFile :: String+renderDefinitionFile =+  generatedNotice ";"+    <> "LIBRARY moonlight-triangulation-c\nEXPORTS\n"+    <> concatMap (\function -> "  " <> abiFunctionSymbol function <> "\n") allAbiFunctions++renderHaskellExports :: String+renderHaskellExports =+  generatedNotice "--"+    <> unlines+      [ "{-# LANGUAGE ForeignFunctionInterface #-}"+      , "{-# OPTIONS_GHC -Wno-missing-signatures #-}"+      , ""+      , "module Moonlight.Triangulation.Foreign.Exports where"+      , ""+      , "import Data.Int (Int64)"+      , "import Data.Word (Word32)"+      , "import Foreign.C.Types (CChar, CDouble (..), CSize (..), CUInt (..))"+      , "import Foreign.Ptr (Ptr)"+      , "import Moonlight.Triangulation.Foreign.Contract"+      , "  ( CMesh"+      , "  , CMinkowskiReceipt"+      , "  , CObstruction"+      , "  , CRegion"+      , "  , CStructuringElement"+      , "  )"+      , "import qualified Moonlight.Triangulation.Foreign.Mesh as Mesh"+      , "import qualified Moonlight.Triangulation.Foreign.Morphology as Morphology"+      , "import qualified Moonlight.Triangulation.Foreign.Region as Region"+      , ""+      ]+    <> concatMap renderHaskellAlias implementedFunctions+    <> "\n"+    <> concatMap renderHaskellExport implementedFunctions+ where+  implementedFunctions :: [(AbiFunction, String, AbiFunctionFamily)]+  implementedFunctions = mapMaybe implemented allAbiFunctions++  implemented :: AbiFunction -> Maybe (AbiFunction, String, AbiFunctionFamily)+  implemented function =+    case abiFunctionImplementation function of+      AbiFunctionRuntime -> Nothing+      AbiFunctionHaskell family haskellName -> Just (function, haskellName, family)++  renderHaskellAlias :: (AbiFunction, String, AbiFunctionFamily) -> String+  renderHaskellAlias (_, haskellName, family) =+    haskellName <> " = " <> familyQualifier family <> "." <> haskellName <> "\n"++  renderHaskellExport :: (AbiFunction, String, AbiFunctionFamily) -> String+  renderHaskellExport (function, haskellName, _) =+    "foreign export ccall \""+      <> abiFunctionSymbol function+      <> "\" "+      <> haskellName+      <> " :: "+      <> haskellFunctionType function+      <> "\n"++familyQualifier :: AbiFunctionFamily -> String+familyQualifier family =+  case family of+    AbiFunctionMesh -> "Mesh"+    AbiFunctionRegion -> "Region"+    AbiFunctionMorphology -> "Morphology"++renderTypeScriptWire :: String+renderTypeScriptWire =+  generatedNotice "//"+    <> intercalate+      "\n"+      [ renderTypeScriptVocabulary "AbiStatus" "ML_STATUS_" abiStatusSymbol abiStatusId allAbiStatuses+      , renderTypeScriptVocabulary "ObstructionCode" "ML_OBSTRUCTION_" obstructionCodeSymbol obstructionCodeId allObstructionCodes+      , renderTypeScriptVocabulary "CoordinateError" "ML_COORDINATE_ERROR_" coordinateErrorCodeSymbol coordinateErrorCodeId allCoordinateErrorCodes+      , renderTypeScriptVocabulary "RegionLocation" "ML_REGION_" regionLocationCodeSymbol regionLocationCodeId allRegionLocationCodes+      , renderTypeScriptVocabulary "MinkowskiOperation" "ML_MINKOWSKI_" minkowskiOperationCodeSymbol minkowskiOperationCodeId allMinkowskiOperationCodes+      ]++renderTypeScriptVocabulary+  :: String+  -> String+  -> (value -> String)+  -> (value -> Word32)+  -> [value]+  -> String+renderTypeScriptVocabulary typeName prefix symbol identifier values =+  "export const "+    <> typeName+    <> " = {\n"+    <> concatMap renderValue values+    <> "} as const;\n"+    <> "export type "+    <> typeName+    <> " = (typeof "+    <> typeName+    <> ")[keyof typeof "+    <> typeName+    <> "];\n"+    <> "const "+    <> lowerInitial typeName+    <> "ByWire: Readonly<Record<number, "+    <> typeName+    <> ">> = {\n"+    <> concatMap renderWireEntry values+    <> "};\n"+    <> "export function decode"+    <> typeName+    <> "(value: number): "+    <> typeName+    <> " | undefined {\n"+    <> "  return "+    <> lowerInitial typeName+    <> "ByWire[value];\n"+    <> "}\n"+ where+  renderValue value =+    "  " <> wireKey prefix (symbol value) <> ": \"" <> wireValue prefix (symbol value) <> "\",\n"+  renderWireEntry value =+    "  " <> show (identifier value) <> ": " <> typeName <> "." <> wireKey prefix (symbol value) <> ",\n"++wireKey :: String -> String -> String+wireKey prefix = concatMap capitalize . underscoreWords . drop (length prefix)++wireValue :: String -> String -> String+wireValue prefix = intercalate "-" . fmap (fmap toLower) . underscoreWords . drop (length prefix)++underscoreWords :: String -> [String]+underscoreWords value =+  case break (== '_') value of+    (word, []) -> [word]+    (word, _ : rest) -> word : underscoreWords rest++capitalize :: String -> String+capitalize value =+  case value of+    [] -> []+    firstCharacter : rest -> toUpper firstCharacter : fmap toLower rest++lowerInitial :: String -> String+lowerInitial value =+  case value of+    [] -> []+    firstCharacter : rest -> toLower firstCharacter : rest++haskellFunctionType :: AbiFunction -> String+haskellFunctionType function =+  intercalate " -> " (fmap (haskellParameterType . abiParameterKind) (abiFunctionParameters function) <> [haskellResultType (abiFunctionResult function)])++haskellParameterType :: AbiParameterKind -> String+haskellParameterType kind =+  case kind of+    AbiValueSize -> "CSize"+    AbiValueDouble -> "CDouble"+    AbiHandleInput handle -> "Ptr " <> haskellHandleName handle+    AbiHandleRelease handle -> "Ptr " <> haskellHandleName handle+    AbiHandleOutput handle -> "Ptr (Ptr " <> haskellHandleName handle <> ")"+    AbiBufferInputDouble -> "Ptr CDouble"+    AbiBufferInputSize -> "Ptr CSize"+    AbiBufferOutputChar -> "Ptr CChar"+    AbiBufferOutputDouble -> "Ptr CDouble"+    AbiBufferOutputUInt32 -> "Ptr Word32"+    AbiBufferOutputSize -> "Ptr CSize"+    AbiScalarOutputRegionLocation -> "Ptr CUInt"+    AbiScalarOutputInt64 -> "Ptr Int64"+    AbiScalarOutputSize -> "Ptr CSize"+    AbiScalarOutputDouble -> "Ptr CDouble"+    AbiStructOutput structure -> "Ptr " <> haskellStructName structure++haskellResultType :: AbiResult -> String+haskellResultType result =+  case result of+    AbiResultVoid -> "IO ()"+    AbiResultUInt32 -> "IO CUInt"+    AbiResultStatus -> "IO CUInt"++haskellHandleName :: AbiHandle -> String+haskellHandleName handle =+  case handle of+    AbiMesh -> "CMesh"+    AbiRegion -> "CRegion"+    AbiStructuringElement -> "CStructuringElement"++haskellStructName :: AbiStruct -> String+haskellStructName structure =+  case structure of+    AbiStructObstruction -> "CObstruction"+    AbiStructMinkowskiReceipt -> "CMinkowskiReceipt"++renderTypeScriptRaw :: String+renderTypeScriptRaw =+  generatedNotice "//"+    <> "import koffi from \"koffi\";\n\n"+    <> "export const ABI_VERSION = " <> show abiVersion <> ";\n"+    <> renderTypeScriptConstants abiStatusSymbol abiStatusId allAbiStatuses+    <> renderTypeScriptConstants obstructionCodeSymbol obstructionCodeId allObstructionCodes+    <> renderTypeScriptConstants coordinateErrorCodeSymbol coordinateErrorCodeId allCoordinateErrorCodes+    <> renderTypeScriptConstants regionLocationCodeSymbol regionLocationCodeId allRegionLocationCodes+    <> renderTypeScriptConstants minkowskiOperationCodeSymbol minkowskiOperationCodeId allMinkowskiOperationCodes+    <> "\nexport type NativeHandle = object;\n"+    <> "export type NativeInteger = number | bigint;\n"+    <> "export type HandleOutput = Array<NativeHandle | null>;\n\n"+    <> renderTypeScriptStruct "NativeObstruction" AbiStructObstruction+    <> renderTypeScriptStruct "NativeMinkowskiReceipt" AbiStructMinkowskiReceipt+    <> "export interface NativeApi {\n"+    <> concatMap renderTypeScriptFunctionType allAbiFunctions+    <> "}\n\n"+    <> unlines+      [ "export function loadNativeApi(libraryPath: string): NativeApi {"+      , "  const library = koffi.load(libraryPath);"+      , concatMap renderTypeScriptKoffiHandleDeclarations allAbiHandles+      , renderTypeScriptKoffiStruct "obstruction" AbiStructObstruction+      , renderTypeScriptKoffiStruct "receipt" AbiStructMinkowskiReceipt+      , "  const obstructionOutput = koffi.out(koffi.pointer(obstruction));"+      , "  const receiptOutput = koffi.out(koffi.pointer(receipt));"+      , "  const sizeOutput = koffi.out(koffi.pointer(\"size_t\"));"+      , "  const uint32Output = koffi.out(koffi.pointer(\"uint32_t\"));"+      , "  const int64Output = koffi.out(koffi.pointer(\"int64_t\"));"+      , "  const doubleOutput = koffi.out(koffi.pointer(\"double\"));"+      , "  const sizeArray = koffi.pointer(\"size_t\");"+      , "  return {"+      ]+    <> concatMap renderTypeScriptFunctionBinding allAbiFunctions+    <> "  };\n}\n"++renderTypeScriptConstants :: (value -> String) -> (value -> Word32) -> [value] -> String+renderTypeScriptConstants symbol identifier =+  concatMap (\value -> "export const " <> symbol value <> " = " <> show (identifier value) <> ";\n")++renderTypeScriptStruct :: String -> AbiStruct -> String+renderTypeScriptStruct name structure =+  "export interface "+    <> name+    <> " {\n"+    <> concatMap renderField (abiStructFields structure)+    <> "}\n\n"+ where+  renderField (AbiField fieldName fieldType) =+    "  " <> fieldName <> "?: " <> typeScriptFieldType fieldType <> ";\n"++typeScriptFieldType :: AbiFieldType -> String+typeScriptFieldType fieldType =+  case fieldType of+    AbiFieldUInt32 -> "number"+    AbiFieldUInt64 -> "NativeInteger"+    AbiFieldDouble -> "number"+    AbiFieldCharArray _ -> "string | readonly number[]"++renderTypeScriptFunctionType :: AbiFunction -> String+renderTypeScriptFunctionType function =+  "  readonly "+    <> abiFunctionSymbol function+    <> ": ("+    <> intercalate ", " (fmap renderParameter (abiFunctionParameters function))+    <> ") => "+    <> typeScriptResultType (abiFunctionResult function)+    <> ";\n"+ where+  renderParameter (AbiParameter name kind) = name <> ": " <> typeScriptParameterType kind++typeScriptParameterType :: AbiParameterKind -> String+typeScriptParameterType kind =+  case kind of+    AbiValueSize -> "number"+    AbiValueDouble -> "number"+    AbiHandleInput _ -> "NativeHandle"+    AbiHandleRelease _ -> "NativeHandle"+    AbiHandleOutput _ -> "HandleOutput"+    AbiBufferInputDouble -> "Float64Array"+    AbiBufferInputSize -> "BigUint64Array"+    AbiBufferOutputChar -> "Buffer"+    AbiBufferOutputDouble -> "Float64Array"+    AbiBufferOutputUInt32 -> "Uint32Array"+    AbiBufferOutputSize -> "BigUint64Array"+    AbiScalarOutputRegionLocation -> "number[]"+    AbiScalarOutputInt64 -> "NativeInteger[]"+    AbiScalarOutputSize -> "NativeInteger[]"+    AbiScalarOutputDouble -> "number[]"+    AbiStructOutput AbiStructObstruction -> "NativeObstruction"+    AbiStructOutput AbiStructMinkowskiReceipt -> "NativeMinkowskiReceipt"++typeScriptResultType :: AbiResult -> String+typeScriptResultType result =+  case result of+    AbiResultVoid -> "void"+    AbiResultUInt32 -> "number"+    AbiResultStatus -> "number"++renderTypeScriptKoffiStruct :: String -> AbiStruct -> String+renderTypeScriptKoffiStruct variableName structure =+  "  const "+    <> variableName+    <> " = koffi.struct({\n"+    <> concatMap renderField (abiStructFields structure)+    <> "  });"+ where+  renderField (AbiField name fieldType) =+    "    " <> name <> ": " <> typeScriptKoffiFieldType fieldType <> ",\n"++typeScriptKoffiFieldType :: AbiFieldType -> String+typeScriptKoffiFieldType fieldType =+  case fieldType of+    AbiFieldUInt32 -> "\"uint32_t\""+    AbiFieldUInt64 -> "\"uint64_t\""+    AbiFieldDouble -> "\"double\""+    AbiFieldCharArray lengthInBytes -> "koffi.array(\"char\", " <> show lengthInBytes <> ")"++renderTypeScriptFunctionBinding :: AbiFunction -> String+renderTypeScriptFunctionBinding function =+  "    "+    <> abiFunctionSymbol function+    <> ": library.func(\""+    <> abiFunctionSymbol function+    <> "\", \""+    <> typeScriptKoffiResultType (abiFunctionResult function)+    <> "\", ["+    <> intercalate ", " (fmap (typeScriptKoffiParameterType . abiParameterKind) (abiFunctionParameters function))+    <> "]),\n"++typeScriptKoffiResultType :: AbiResult -> String+typeScriptKoffiResultType result =+  case result of+    AbiResultVoid -> "void"+    AbiResultUInt32 -> "uint32_t"+    AbiResultStatus -> "uint32_t"++typeScriptKoffiParameterType :: AbiParameterKind -> String+typeScriptKoffiParameterType kind =+  case kind of+    AbiValueSize -> "\"size_t\""+    AbiValueDouble -> "\"double\""+    AbiHandleInput handle -> typeScriptHandleVariable handle <> "Pointer"+    AbiHandleRelease handle -> typeScriptHandleVariable handle <> "Pointer"+    AbiHandleOutput handle -> typeScriptHandleVariable handle <> "Output"+    AbiBufferInputDouble -> "koffi.pointer(\"double\")"+    AbiBufferInputSize -> "sizeArray"+    AbiBufferOutputChar -> "koffi.out(koffi.pointer(\"char\"))"+    AbiBufferOutputDouble -> "koffi.out(koffi.pointer(\"double\"))"+    AbiBufferOutputUInt32 -> "koffi.out(koffi.pointer(\"uint32_t\"))"+    AbiBufferOutputSize -> "koffi.out(sizeArray)"+    AbiScalarOutputRegionLocation -> "uint32Output"+    AbiScalarOutputInt64 -> "int64Output"+    AbiScalarOutputSize -> "sizeOutput"+    AbiScalarOutputDouble -> "doubleOutput"+    AbiStructOutput AbiStructObstruction -> "obstructionOutput"+    AbiStructOutput AbiStructMinkowskiReceipt -> "receiptOutput"++typeScriptHandleVariable :: AbiHandle -> String+typeScriptHandleVariable handle =+  case handle of+    AbiMesh -> "mesh"+    AbiRegion -> "region"+    AbiStructuringElement -> "structuringElement"++renderTypeScriptKoffiHandleDeclarations :: AbiHandle -> String+renderTypeScriptKoffiHandleDeclarations handle =+  let variableName = typeScriptHandleVariable handle+   in unlines+        [ "  const " <> variableName <> " = koffi.opaque();"+        , "  const " <> variableName <> "Pointer = koffi.pointer(" <> variableName <> ");"+        , "  const " <> variableName <> "Output = koffi.out(koffi.pointer(" <> variableName <> ", 2));"+        ]++renderPythonRaw :: String+renderPythonRaw =+  generatedNotice "#"+    <> unlines+      [ "from __future__ import annotations"+      , ""+      , "import ctypes"+      , "from collections.abc import Sequence"+      , "from pathlib import Path"+      , "from typing import Final"+      , ""+      , "ABI_VERSION: Final = " <> show abiVersion+      ]+    <> renderPythonConstants abiStatusSymbol abiStatusId allAbiStatuses+    <> renderPythonConstants obstructionCodeSymbol obstructionCodeId allObstructionCodes+    <> renderPythonConstants coordinateErrorCodeSymbol coordinateErrorCodeId allCoordinateErrorCodes+    <> renderPythonConstants regionLocationCodeSymbol regionLocationCodeId allRegionLocationCodes+    <> renderPythonConstants minkowskiOperationCodeSymbol minkowskiOperationCodeId allMinkowskiOperationCodes+    <> "\n"+    <> renderPythonStruct "_Obstruction" AbiStructObstruction+    <> renderPythonStruct "_NativeMinkowskiReceipt" AbiStructMinkowskiReceipt+    <> unlines+      [ "class _NativeApi:"+      , "    def __init__(self, library_path: Path) -> None:"+      , "        library = ctypes.CDLL(str(library_path))"+      ]+    <> concatMap renderPythonConfiguration allAbiFunctions+    <> unlines+      [ "        self.library = library"+      , ""+      , ""+      , "def _configure("+      , "    library: ctypes.CDLL,"+      , "    name: str,"+      , "    parameters: Sequence[object],"+      , "    result: object = ctypes.c_uint32,"+      , ") -> None:"+      , "    function = getattr(library, name)"+      , "    setattr(function, \"argtypes\", list(parameters))"+      , "    setattr(function, \"restype\", result)"+      ]++renderPythonConstants :: (value -> String) -> (value -> Word32) -> [value] -> String+renderPythonConstants symbol identifier =+  concatMap (\value -> symbol value <> ": Final = " <> show (identifier value) <> "\n")++renderPythonStruct :: String -> AbiStruct -> String+renderPythonStruct name structure =+  "class "+    <> name+    <> "(ctypes.Structure):\n"+    <> "    _fields_ = [\n"+    <> concatMap renderField (abiStructFields structure)+    <> "    ]\n\n\n"+ where+  renderField (AbiField fieldName fieldType) =+    "        (\"" <> fieldName <> "\", " <> pythonFieldType fieldType <> "),\n"++pythonFieldType :: AbiFieldType -> String+pythonFieldType fieldType =+  case fieldType of+    AbiFieldUInt32 -> "ctypes.c_uint32"+    AbiFieldUInt64 -> "ctypes.c_uint64"+    AbiFieldDouble -> "ctypes.c_double"+    AbiFieldCharArray lengthInBytes -> "ctypes.c_char * " <> show lengthInBytes++renderPythonConfiguration :: AbiFunction -> String+renderPythonConfiguration function =+  "        _configure(library, \""+    <> abiFunctionSymbol function+    <> "\", "+    <> pythonTuple (fmap (pythonParameterType . abiParameterKind) (abiFunctionParameters function))+    <> ", "+    <> pythonResultType (abiFunctionResult function)+    <> ")\n"++pythonTuple :: [String] -> String+pythonTuple values =+  case values of+    [] -> "()"+    [value] -> "(" <> value <> ",)"+    _ -> "(" <> intercalate ", " values <> ")"++pythonParameterType :: AbiParameterKind -> String+pythonParameterType kind =+  case kind of+    AbiValueSize -> "ctypes.c_size_t"+    AbiValueDouble -> "ctypes.c_double"+    AbiHandleInput _ -> "ctypes.c_void_p"+    AbiHandleRelease _ -> "ctypes.c_void_p"+    AbiHandleOutput _ -> "ctypes.POINTER(ctypes.c_void_p)"+    AbiBufferInputDouble -> "ctypes.POINTER(ctypes.c_double)"+    AbiBufferInputSize -> "ctypes.POINTER(ctypes.c_size_t)"+    AbiBufferOutputChar -> "ctypes.POINTER(ctypes.c_char)"+    AbiBufferOutputDouble -> "ctypes.POINTER(ctypes.c_double)"+    AbiBufferOutputUInt32 -> "ctypes.POINTER(ctypes.c_uint32)"+    AbiBufferOutputSize -> "ctypes.POINTER(ctypes.c_size_t)"+    AbiScalarOutputRegionLocation -> "ctypes.POINTER(ctypes.c_uint32)"+    AbiScalarOutputInt64 -> "ctypes.POINTER(ctypes.c_int64)"+    AbiScalarOutputSize -> "ctypes.POINTER(ctypes.c_size_t)"+    AbiScalarOutputDouble -> "ctypes.POINTER(ctypes.c_double)"+    AbiStructOutput AbiStructObstruction -> "ctypes.POINTER(_Obstruction)"+    AbiStructOutput AbiStructMinkowskiReceipt -> "ctypes.POINTER(_NativeMinkowskiReceipt)"++pythonResultType :: AbiResult -> String+pythonResultType result =+  case result of+    AbiResultVoid -> "None"+    AbiResultUInt32 -> "ctypes.c_uint32"+    AbiResultStatus -> "ctypes.c_uint32"++renderRustRaw :: String+renderRustRaw =+  generatedNotice "//"+    <> "// This private module is the complete wire projection; wrappers consume a subset.\n"+    <> "#![allow(dead_code)]\n\n"+    <> "use std::ffi::{c_char, c_double, c_uint};\n\n"+    <> "pub(crate) const ABI_VERSION: u32 = " <> show abiVersion <> ";\n"+    <> renderRustConstants abiStatusSymbol abiStatusId allAbiStatuses+    <> renderRustConstants obstructionCodeSymbol obstructionCodeId allObstructionCodes+    <> renderRustConstants coordinateErrorCodeSymbol coordinateErrorCodeId allCoordinateErrorCodes+    <> renderRustConstants regionLocationCodeSymbol regionLocationCodeId allRegionLocationCodes+    <> renderRustConstants minkowskiOperationCodeSymbol minkowskiOperationCodeId allMinkowskiOperationCodes+    <> "\n"+    <> concatMap renderRustHandle allAbiHandles+    <> renderRustStruct "NativeObstruction" AbiStructObstruction+    <> renderRustStruct "NativeMinkowskiReceipt" AbiStructMinkowskiReceipt+    <> "#[link(name = \"moonlight-triangulation-c\")]\nunsafe extern \"C\" {\n"+    <> concatMap renderRustFunction allAbiFunctions+    <> "}\n"++renderRustConstants :: (value -> String) -> (value -> Word32) -> [value] -> String+renderRustConstants symbol identifier =+  concatMap (\value -> "pub(crate) const " <> symbol value <> ": u32 = " <> show (identifier value) <> ";\n")++renderRustHandle :: AbiHandle -> String+renderRustHandle handle =+  "#[repr(C)]\npub(crate) struct "+    <> rustHandleName handle+    <> " {\n    _private: [u8; 0],\n}\n\n"++renderRustStruct :: String -> AbiStruct -> String+renderRustStruct name structure =+  "#[repr(C)]\npub(crate) struct "+    <> name+    <> " {\n"+    <> concatMap renderField (abiStructFields structure)+    <> "}\n\n"+    <> "impl Default for "+    <> name+    <> " {\n"+    <> "    fn default() -> Self {\n"+    <> "        Self {\n"+    <> concatMap renderDefaultField (abiStructFields structure)+    <> "        }\n"+    <> "    }\n"+    <> "}\n\n"+ where+  renderField (AbiField fieldName fieldType) =+    "    pub(crate) " <> fieldName <> ": " <> rustFieldType fieldType <> ",\n"+  renderDefaultField (AbiField fieldName fieldType) =+    "            " <> fieldName <> ": " <> rustFieldDefault fieldType <> ",\n"++rustFieldType :: AbiFieldType -> String+rustFieldType fieldType =+  case fieldType of+    AbiFieldUInt32 -> "u32"+    AbiFieldUInt64 -> "u64"+    AbiFieldDouble -> "f64"+    AbiFieldCharArray lengthInBytes -> "[c_char; " <> show lengthInBytes <> "]"++rustFieldDefault :: AbiFieldType -> String+rustFieldDefault fieldType =+  case fieldType of+    AbiFieldUInt32 -> "0"+    AbiFieldUInt64 -> "0"+    AbiFieldDouble -> "0.0"+    AbiFieldCharArray lengthInBytes -> "[0; " <> show lengthInBytes <> "]"++renderRustFunction :: AbiFunction -> String+renderRustFunction function =+  case abiFunctionParameters function of+    [] -> declarationPrefix <> "()" <> resultSuffix <> ";\n"+    [parameter] -> declarationPrefix <> "(" <> renderParameter parameter <> ")" <> resultSuffix <> ";\n"+    parameters ->+      declarationPrefix+        <> "(\n"+        <> concatMap (\parameter -> "        " <> renderParameter parameter <> ",\n") parameters+        <> "    )"+        <> resultSuffix+        <> ";\n"+ where+  declarationPrefix = "    pub(crate) fn " <> abiFunctionSymbol function+  resultSuffix = rustResultSuffix (abiFunctionResult function)+  renderParameter (AbiParameter name kind) = name <> ": " <> rustParameterType kind++rustParameterType :: AbiParameterKind -> String+rustParameterType kind =+  case kind of+    AbiValueSize -> "usize"+    AbiValueDouble -> "c_double"+    AbiHandleInput handle -> "*const " <> rustHandleName handle+    AbiHandleRelease handle -> "*mut " <> rustHandleName handle+    AbiHandleOutput handle -> "*mut *mut " <> rustHandleName handle+    AbiBufferInputDouble -> "*const c_double"+    AbiBufferInputSize -> "*const usize"+    AbiBufferOutputChar -> "*mut c_char"+    AbiBufferOutputDouble -> "*mut c_double"+    AbiBufferOutputUInt32 -> "*mut u32"+    AbiBufferOutputSize -> "*mut usize"+    AbiScalarOutputRegionLocation -> "*mut u32"+    AbiScalarOutputInt64 -> "*mut i64"+    AbiScalarOutputSize -> "*mut usize"+    AbiScalarOutputDouble -> "*mut c_double"+    AbiStructOutput AbiStructObstruction -> "*mut NativeObstruction"+    AbiStructOutput AbiStructMinkowskiReceipt -> "*mut NativeMinkowskiReceipt"++rustResultSuffix :: AbiResult -> String+rustResultSuffix result =+  case result of+    AbiResultVoid -> ""+    AbiResultUInt32 -> " -> c_uint"+    AbiResultStatus -> " -> c_uint"++rustHandleName :: AbiHandle -> String+rustHandleName handle =+  case handle of+    AbiMesh -> "NativeMesh"+    AbiRegion -> "NativeRegion"+    AbiStructuringElement -> "NativeStructuringElement"
+ ffi/abi/Moonlight/Triangulation/Foreign/Mesh.hs view
@@ -0,0 +1,178 @@+module Moonlight.Triangulation.Foreign.Mesh+  ( delaunayF64+  , insertGeometryBatch+  , meshCopyTrianglesU32+  , meshCopyVerticesF64+  , meshFree+  , meshInsertManyF64+  , meshSiteDifference+  , meshSiteIntersection+  , meshSiteSymmetricDifference+  , meshSiteUnion+  , meshTriangleCount+  , meshVertexCount+  ) where++import Control.Monad (void)+import Data.Bifunctor (first)+import Data.Word (Word32)+import Foreign.C.Types (CDouble (..), CSize, CUInt)+import Foreign.Ptr (Ptr)+import Foreign.Storable (poke, pokeElemOff)+import qualified Data.Vector as V+import qualified Moonlight.Triangulation as T+import Moonlight.Triangulation.Foreign.Boundary+  ( GeometryMesh+  , HandleValue+  , checkedCount+  , dereferenceHandle+  , freeHandle+  , produceHandle+  , readPoints+  , requireOutputCapacity+  , requirePointer+  , runBoundary+  )+import Moonlight.Triangulation.Foreign.Contract (CMesh, CObstruction)+import Moonlight.Triangulation.Foreign.Obstruction (buildFailure)+import Moonlight.Triangulation.Math (validatePoint)+import qualified Moonlight.Triangulation.Internal.Session as Session++delaunayF64 :: Ptr CDouble -> CSize -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt+delaunayF64 coordinates rawCount output obstructionPointer =+  runBoundary obstructionPointer $ produceHandle output $ do+    case checkedCount 2 rawCount of+      Left failure -> pure (Left failure)+      Right count -> do+        points <- readPoints coordinates count+        pure (points >>= first buildFailure . T.delaunayGeometry)++meshInsertManyF64 :: Ptr CMesh -> Ptr CDouble -> CSize -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt+meshInsertManyF64 meshPointer coordinates rawCount output obstructionPointer =+  runBoundary obstructionPointer $ produceHandle output $ do+    case requirePointer "mesh" meshPointer >> checkedCount 2 rawCount of+      Left failure -> pure (Left failure)+      Right count -> do+        points <- readPoints coordinates count+        case points of+          Left failure -> pure (Left failure)+          Right admitted -> do+            mesh <- dereferenceHandle meshPointer+            pure (first buildFailure (insertGeometryBatch mesh admitted))++-- | Admit the complete batch before opening the immutable insertion session.+insertGeometryBatch :: GeometryMesh -> V.Vector T.Point -> Either T.BuildError GeometryMesh+insertGeometryBatch mesh points = do+  admittedPoints <- V.imapM (\index point -> validatePoint (Just index) point) points+  (_, revised, _) <-+    Session.withSession+      mesh+      (V.length points)+      ( V.mapM_+          ( \point ->+              void+                ( Session.insertAdmittedVertexAtCombining+                    (\_ replacement -> replacement)+                    point+                    ()+                )+          )+          admittedPoints+      )+  pure revised++meshSiteUnion, meshSiteIntersection, meshSiteDifference, meshSiteSymmetricDifference :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt+meshSiteUnion = binaryMeshOperation T.union+meshSiteIntersection = binaryMeshOperation T.intersection+meshSiteDifference = binaryMeshOperation T.difference+meshSiteSymmetricDifference = binaryMeshOperation T.symmetricDifference++binaryMeshOperation+  :: (GeometryMesh -> GeometryMesh -> Either T.BuildError GeometryMesh)+  -> Ptr CMesh+  -> Ptr CMesh+  -> Ptr (Ptr CMesh)+  -> Ptr CObstruction+  -> IO CUInt+binaryMeshOperation operation leftPointer rightPointer output obstructionPointer =+  runBoundary obstructionPointer $ produceHandle output $ do+    case requirePointer "left mesh" leftPointer >> requirePointer "right mesh" rightPointer of+      Left failure -> pure (Left failure)+      Right () -> do+        left <- dereferenceHandle leftPointer+        right <- dereferenceHandle rightPointer+        pure (first buildFailure (operation left right))++meshVertexCount, meshTriangleCount :: Ptr CMesh -> Ptr CSize -> Ptr CObstruction -> IO CUInt+meshVertexCount = handleCount "mesh" T.numVertices+meshTriangleCount = handleCount "mesh" (V.length . T.innerFaceVertexTriples)++handleCount+  :: String+  -> (HandleValue carrier -> Int)+  -> Ptr carrier+  -> Ptr CSize+  -> Ptr CObstruction+  -> IO CUInt+handleCount handleLabel observe handlePointer output obstructionPointer =+  runBoundary obstructionPointer $+    case requirePointer handleLabel handlePointer >> requirePointer "count" output of+      Left failure -> pure (Left failure)+      Right () -> do+        value <- dereferenceHandle handlePointer+        poke output (fromIntegral (observe value))+        pure (Right ())++meshCopyVerticesF64 :: Ptr CMesh -> Ptr CDouble -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt+meshCopyVerticesF64 =+  copyHandleProjection+    "mesh"+    "points_written"+    "coordinates"+    T.vertexPoints+    ( \output index (T.Point x y) -> do+        pokeElemOff output (index * 2) (CDouble x)+        pokeElemOff output (index * 2 + 1) (CDouble y)+    )++meshCopyTrianglesU32 :: Ptr CMesh -> Ptr Word32 -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt+meshCopyTrianglesU32 =+  copyHandleProjection+    "mesh"+    "triangles_written"+    "triangles"+    T.innerFaceVertexTriples+    ( \output index (firstVertex, secondVertex, thirdVertex) -> do+        pokeElemOff output (index * 3) (T.unVertexId firstVertex)+        pokeElemOff output (index * 3 + 1) (T.unVertexId secondVertex)+        pokeElemOff output (index * 3 + 2) (T.unVertexId thirdVertex)+    )++copyHandleProjection+  :: String+  -> String+  -> String+  -> (HandleValue carrier -> V.Vector item)+  -> (Ptr element -> Int -> item -> IO ())+  -> Ptr carrier+  -> Ptr element+  -> CSize+  -> Ptr CSize+  -> Ptr CObstruction+  -> IO CUInt+{-# INLINE copyHandleProjection #-}+copyHandleProjection handleLabel writtenLabel outputLabel project writeItem handlePointer output rawCapacity written obstructionPointer =+  runBoundary obstructionPointer $+    case requirePointer handleLabel handlePointer >> requirePointer writtenLabel written >> checkedCount 1 rawCapacity of+      Left failure -> pure (Left failure)+      Right capacity -> do+        value <- dereferenceHandle handlePointer+        let items = project value+            required = V.length items+        poke written (fromIntegral required)+        case requireOutputCapacity outputLabel output required capacity of+          Left failure -> pure (Left failure)+          Right () -> V.imapM_ (writeItem output) items >> pure (Right ())++meshFree :: Ptr CMesh -> IO ()+meshFree = freeHandle
+ ffi/abi/Moonlight/Triangulation/Foreign/Morphology.hs view
@@ -0,0 +1,160 @@+module Moonlight.Triangulation.Foreign.Morphology+  ( regionClose+  , regionInset+  , regionMinkowskiSum+  , regionOffset+  , regionOpen+  , structuringElementCreateF64+  , structuringElementFree+  ) where++import Data.Bifunctor (first)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Word (Word32)+import Foreign.C.Types (CDouble, CSize, CUInt)+import Foreign.Ptr (Ptr)+import Foreign.Storable (poke)+import qualified Data.Vector as V+import qualified Moonlight.Triangulation as T+import Moonlight.Triangulation.Foreign.Boundary+  ( checkedCount+  , dereferenceHandle+  , freeHandle+  , prepareHandleOutput+  , produceHandle+  , publishHandle+  , readPoints+  , requirePointer+  , runBoundary+  )+import Moonlight.Triangulation.Foreign.Contract+  ( CMinkowskiReceipt (..)+  , CObstruction+  , CRegion+  , CStructuringElement+  , MinkowskiOperationCode (..)+  , minkowskiOperationCodeId+  )+import Moonlight.Triangulation.Foreign.Obstruction+  ( AbiFailure+  , minkowskiFailure+  , pointInputFailure+  , structuringElementEmptyFailure+  )++structuringElementCreateF64+  :: Ptr CDouble+  -> CSize+  -> Ptr (Ptr CStructuringElement)+  -> Ptr CObstruction+  -> IO CUInt+structuringElementCreateF64 coordinates rawPointCount output obstructionPointer =+  runBoundary obstructionPointer $ produceHandle output $ do+    case checkedCount 2 rawPointCount of+      Left failure -> pure (Left failure)+      Right pointCount -> do+        points <- readPoints coordinates pointCount+        pure (points >>= buildStructuringElement)++buildStructuringElement+  :: V.Vector T.Point+  -> Either AbiFailure T.StructuringElement+buildStructuringElement points = do+  exactPoints <-+    V.imapM+      (\index point -> first (pointInputFailure index point) (T.exactPointFromPoint point))+      points+  submitted <-+    maybe+      (Left structuringElementEmptyFailure)+      Right+      (NonEmpty.nonEmpty (V.toList exactPoints))+  polygon <- first minkowskiFailure (T.convexPolygon submitted)+  first minkowskiFailure (T.structuringElement polygon)++structuringElementFree :: Ptr CStructuringElement -> IO ()+structuringElementFree = freeHandle++regionMinkowskiSum+  :: Ptr CRegion+  -> Ptr CRegion+  -> Ptr (Ptr CRegion)+  -> Ptr CMinkowskiReceipt+  -> Ptr CObstruction+  -> IO CUInt+regionMinkowskiSum leftPointer rightPointer output receiptOutput obstructionPointer =+  runBoundary obstructionPointer $+    produceRegionWithReceipt output receiptOutput $ do+      case requirePointer "left region" leftPointer >> requirePointer "right region" rightPointer of+        Left failure -> pure (Left failure)+        Right () -> do+          left <- dereferenceHandle leftPointer+          right <- dereferenceHandle rightPointer+          pure (first minkowskiFailure (T.minkowskiSum left right))++regionOffset, regionInset, regionOpen, regionClose :: Ptr CStructuringElement -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt+regionOffset = structuringElementOperation T.polygonOffset+regionInset = structuringElementOperation T.polygonInset+regionOpen = structuringElementOperation T.openWith+regionClose = structuringElementOperation T.closeWith++structuringElementOperation+  :: (T.StructuringElement -> T.PlanarRegion -> Either T.MinkowskiError (T.PlanarRegion, T.MinkowskiReceipt))+  -> Ptr CStructuringElement+  -> Ptr CRegion+  -> Ptr (Ptr CRegion)+  -> Ptr CMinkowskiReceipt+  -> Ptr CObstruction+  -> IO CUInt+structuringElementOperation operation elementPointer regionPointer output receiptOutput obstructionPointer =+  runBoundary obstructionPointer $+    produceRegionWithReceipt output receiptOutput $ do+      case requirePointer "structuring element" elementPointer >> requirePointer "region" regionPointer of+        Left failure -> pure (Left failure)+        Right () -> do+          element <- dereferenceHandle elementPointer+          region <- dereferenceHandle regionPointer+          pure (first minkowskiFailure (operation element region))++produceRegionWithReceipt+  :: Ptr (Ptr CRegion)+  -> Ptr CMinkowskiReceipt+  -> IO (Either AbiFailure (T.PlanarRegion, T.MinkowskiReceipt))+  -> IO (Either AbiFailure ())+produceRegionWithReceipt output receiptOutput obtain = do+  prepared <- prepareHandleOutput output+  case (prepared, requirePointer "receipt" receiptOutput) of+    (Left failure, _) -> pure (Left failure)+    (_, Left failure) -> pure (Left failure)+    (Right (), Right ()) -> do+      outcome <- obtain+      case outcome of+        Left failure -> pure (Left failure)+        Right (region, receipt) -> do+          poke receiptOutput (minkowskiReceiptProjection receipt)+          publishHandle output region+          pure (Right ())++minkowskiReceiptProjection :: T.MinkowskiReceipt -> CMinkowskiReceipt+minkowskiReceiptProjection receipt =+  CMinkowskiReceipt+    { receiptOperation = minkowskiOperationCode (T.minkowskiOperation receipt)+    , receiptInputComponents = fromIntegral (T.minkowskiInputComponents receipt)+    , receiptConvexPieces = fromIntegral (T.minkowskiConvexPieces receipt)+    , receiptGeneratedPieces = fromIntegral (T.minkowskiGeneratedPieces receipt)+    , receiptGeneratedConvolutionEdges = fromIntegral (T.minkowskiGeneratedConvolutionEdges receipt)+    , receiptOverlayPasses = fromIntegral (T.minkowskiOverlayPasses receipt)+    , receiptExactCrossings = fromIntegral (T.minkowskiExactCrossings receipt)+    , receiptOutputCells = fromIntegral (T.minkowskiOutputCells receipt)+    , receiptExactCoordinateBitGrowth = fromIntegral (T.minkowskiExactCoordinateBitGrowth receipt)+    }++minkowskiOperationCode :: T.MinkowskiOperation -> Word32+minkowskiOperationCode operation =+  minkowskiOperationCodeId+    ( case operation of+        T.MinkowskiAddition -> MinkowskiOperationAddition+        T.MinkowskiErosion -> MinkowskiOperationErosion+        T.MinkowskiOpening -> MinkowskiOperationOpening+        T.MinkowskiClosing -> MinkowskiOperationClosing+    )
+ ffi/abi/Moonlight/Triangulation/Foreign/Obstruction.hs view
@@ -0,0 +1,313 @@+module Moonlight.Triangulation.Foreign.Obstruction+  ( AbiFailure (..)+  , RegionCountKind (..)+  , RegionLayoutError (..)+  , bufferTooSmallFailure+  , buildFailure+  , countOverflowFailure+  , emptyObstruction+  , minkowskiFailure+  , nullPointerFailure+  , overlayFailure+  , pointInputFailure+  , projectionFailure+  , regionLayoutFailure+  , regionPublicationFailure+  , regionValidationFailure+  , runtimeFailure+  , statusOk+  , structuringElementEmptyFailure+  , valuationFailure+  ) where++import Control.Exception (SomeException, displayException)+import Data.Word (Word32, Word64)+import Foreign.C.Types (CUInt)+import Moonlight.Triangulation.Foreign.Contract+import qualified Moonlight.Triangulation as T++data AbiFailure = AbiFailure !CUInt !CObstruction++statusCode :: AbiStatus -> CUInt+statusCode = fromIntegral . abiStatusId++statusOk :: CUInt+statusOk = statusCode AbiStatusOk++emptyObstruction :: CObstruction+emptyObstruction =+  CObstruction+    { obstructionCode = obstructionCodeId ObstructionNone+    , obstructionCoordinateError = coordinateErrorCodeId CoordinateErrorNone+    , obstructionInputIndex = maxBound+    , obstructionFirstIndex = 0+    , obstructionSecondIndex = 0+    , obstructionFirstValue = 0+    , obstructionSecondValue = 0+    , obstructionPointX = 0+    , obstructionPointY = 0+    , obstructionMessage = ""+    }++apiFailure :: AbiStatus -> ObstructionCode -> String -> AbiFailure+apiFailure status code message =+  AbiFailure+    (statusCode status)+    emptyObstruction+      { obstructionCode = obstructionCodeId code+      , obstructionMessage = message+      }++geometryFailure :: Show obstruction => ObstructionCode -> obstruction -> AbiFailure+geometryFailure code obstruction =+  apiFailure AbiStatusGeometryObstruction code (show obstruction)++nullPointerFailure :: String -> AbiFailure+nullPointerFailure label =+  apiFailure AbiStatusNullPointer ObstructionNullPointer (label <> " must not be null")++countOverflowFailure :: Word64 -> AbiFailure+countOverflowFailure count =+  AbiFailure+    (statusCode AbiStatusCountOverflow)+    emptyObstruction+      { obstructionCode = obstructionCodeId ObstructionCountOverflow+      , obstructionFirstIndex = count+      , obstructionMessage = "count exceeds the host Int range"+      }++bufferTooSmallFailure :: Int -> Int -> AbiFailure+bufferTooSmallFailure required capacity =+  AbiFailure+    (statusCode AbiStatusBufferTooSmall)+    emptyObstruction+      { obstructionCode = obstructionCodeId ObstructionBufferTooSmall+      , obstructionFirstIndex = fromIntegral required+      , obstructionSecondIndex = fromIntegral capacity+      , obstructionMessage = "output buffer is smaller than the required element count"+      }++runtimeFailure :: SomeException -> AbiFailure+runtimeFailure = apiFailure AbiStatusRuntimeFailure ObstructionRuntimeFailure . displayException++buildFailure :: T.BuildError -> AbiFailure+buildFailure obstruction =+  AbiFailure (statusCode AbiStatusGeometryObstruction) (buildErrorObstruction obstruction)++data RegionCountKind+  = LoopPointCounts+  | ComponentLoopCounts+  deriving stock (Eq, Show)++data RegionLayoutError+  = RegionGroupEmpty !RegionCountKind !Int+  | RegionCountTotalMismatch !RegionCountKind !Integer !Integer+  deriving stock (Eq, Show)++regionLayoutFailure :: RegionLayoutError -> AbiFailure+regionLayoutFailure layoutError =+  AbiFailure (statusCode AbiStatusGeometryObstruction) (layoutObstruction layoutError)++layoutObstruction :: RegionLayoutError -> CObstruction+layoutObstruction layoutError =+  ( case layoutError of+      RegionCountTotalMismatch _ actual expected ->+        base+          { obstructionFirstIndex = fromIntegral actual+          , obstructionSecondIndex = fromIntegral expected+          }+      RegionGroupEmpty _ index -> base {obstructionInputIndex = fromIntegral index}+  )+    {obstructionMessage = show layoutError}+ where+  base = emptyObstruction {obstructionCode = obstructionCodeId ObstructionRegionLayoutInvalid}++regionValidationFailure :: T.RegionValidationError -> AbiFailure+regionValidationFailure = geometryFailure ObstructionRegionValidationFailed++overlayFailure :: T.OverlayError Bool Bool -> AbiFailure+overlayFailure = geometryFailure ObstructionOverlayFailed++regionPublicationFailure :: T.RegionPublicationError -> AbiFailure+regionPublicationFailure = geometryFailure ObstructionRegionPublicationFailed++valuationFailure :: T.ValuationError -> AbiFailure+valuationFailure = geometryFailure ObstructionValuationFailed++minkowskiFailure :: T.MinkowskiError -> AbiFailure+minkowskiFailure = geometryFailure ObstructionMinkowskiFailed++structuringElementEmptyFailure :: AbiFailure+structuringElementEmptyFailure =+  apiFailure+    AbiStatusGeometryObstruction+    ObstructionRegionLayoutInvalid+    "structuring element requires at least one point"++pointInputFailure :: Int -> T.Point -> T.PointValidationError -> AbiFailure+pointInputFailure index (T.Point x y) pointError =+  AbiFailure+    (statusCode AbiStatusGeometryObstruction)+    emptyObstruction+      { obstructionCode = obstructionCodeId ObstructionInvalidCoordinate+      , obstructionCoordinateError = coordinateErrorCode reason+      , obstructionInputIndex = fromIntegral index+      , obstructionFirstValue = invalidValue+      , obstructionPointX = x+      , obstructionPointY = y+      , obstructionMessage = show pointError+      }+ where+  (invalidValue, reason) =+    case pointError of+      T.InvalidPointX coordinateError -> (x, coordinateError)+      T.InvalidPointY coordinateError -> (y, coordinateError)++projectionFailure :: Int -> T.PointValidationError -> AbiFailure+projectionFailure index pointError =+  AbiFailure+    (statusCode AbiStatusGeometryObstruction)+    emptyObstruction+      { obstructionCode = obstructionCodeId ObstructionRegionProjectionFailed+      , obstructionCoordinateError =+          coordinateErrorCode+            ( case pointError of+                T.InvalidPointX coordinateError -> coordinateError+                T.InvalidPointY coordinateError -> coordinateError+            )+      , obstructionInputIndex = fromIntegral index+      , obstructionMessage = show pointError+      }++buildErrorObstruction :: T.BuildError -> CObstruction+buildErrorObstruction failure =+  ( case failure of+      T.InvalidCoordinate inputIndex value reason ->+        emptyObstruction+          { obstructionCode = obstructionCodeId ObstructionInvalidCoordinate+          , obstructionCoordinateError = coordinateErrorCode reason+          , obstructionInputIndex = maybe maxBound fromIntegral inputIndex+          , obstructionFirstValue = value+          }+      T.PointLocationFailed (T.Point x y) -> pointObstruction ObstructionPointLocationFailed x y+      T.LocationWalkExhausted (T.Point x y) steps ->+        (pointObstruction ObstructionLocationWalkExhausted x y) {obstructionFirstIndex = fromIntegral steps}+      T.RefinementInputTopologyInvalid _ -> codeOnly ObstructionRefinementInputTopologyInvalid+      T.FreshInsertionMatchedExistingVertex firstVertex secondVertex -> indices ObstructionFreshInsertionMatchedExistingVertex (T.unVertexId firstVertex) (T.unVertexId secondVertex)+      T.DegenerateLineEndpointMissingOutgoing vertex -> firstIndex ObstructionDegenerateLineEndpointMissingOutgoing (T.unVertexId vertex)+      T.DegenerateLineEndpointTurnMissing index -> firstIndex ObstructionDegenerateLineEndpointTurnMissing index+      T.DegenerateLineConnectedVertexMissing index -> firstIndex ObstructionDegenerateLineConnectedVertexMissing index+      T.HullStartNotVisible edge -> firstIndex ObstructionHullStartNotVisible (T.unDirectedEdgeId edge)+      T.OuterRangeDidNotTerminate firstEdge secondEdge steps ->+        (indices ObstructionOuterRangeDidNotTerminate (T.unDirectedEdgeId firstEdge) (T.unDirectedEdgeId secondEdge))+          {obstructionFirstValue = fromIntegral steps}+      T.OuterRangeContainsInnerEdge edge face -> indices ObstructionOuterRangeContainsInnerEdge (T.unDirectedEdgeId edge) (T.unFaceId face)+      T.ConstrainedEdgeFlipRefused edge -> firstIndex ObstructionConstrainedEdgeFlipRefused (T.unUndirectedEdgeId edge)+      T.RemovalVertexOutOfRange vertex count -> indices ObstructionRemovalVertexOutOfRange (T.unVertexId vertex) count+      T.RemovalEdgeOutOfRange edge count -> indices ObstructionRemovalEdgeOutOfRange (T.unUndirectedEdgeId edge) count+      T.RemovalFaceOutOfRange face count -> indices ObstructionRemovalFaceOutOfRange (T.unFaceId face) count+      T.RemovalFaceCycleDidNotTerminate face edge steps ->+        (indices ObstructionRemovalFaceCycleDidNotTerminate (T.unFaceId face) (T.unDirectedEdgeId edge))+          {obstructionFirstValue = fromIntegral steps}+      T.RemovalEmptyTriangulation vertex -> firstIndex ObstructionRemovalEmptyTriangulation (T.unVertexId vertex)+      T.RemovalTwoPointDegreeMismatch vertex degree -> indices ObstructionRemovalTwoPointDegreeMismatch (T.unVertexId vertex) degree+      T.RemovalCollinearDegreeMismatch vertex degree -> indices ObstructionRemovalCollinearDegreeMismatch (T.unVertexId vertex) degree+      T.RemovalBorderTooShort count -> firstIndex ObstructionRemovalBorderTooShort count+      T.RemovalBorderArityMismatch count -> firstIndex ObstructionRemovalBorderArityMismatch count+      T.RemovalOutgoingCycleDidNotTerminate vertex edge steps ->+        (indices ObstructionRemovalOutgoingCycleDidNotTerminate (T.unVertexId vertex) (T.unDirectedEdgeId edge))+          {obstructionFirstValue = fromIntegral steps}+      T.CircleSweepHullEmpty -> codeOnly ObstructionCircleSweepHullEmpty+      T.OuterCycleDidNotTerminate firstEdge secondEdge steps ->+        (indices ObstructionOuterCycleDidNotTerminate (T.unDirectedEdgeId firstEdge) (T.unDirectedEdgeId secondEdge))+          {obstructionFirstValue = fromIntegral steps}+      T.HierarchyLevelPopulationMismatch level expected observed ->+        (indices ObstructionHierarchyLevelPopulationMismatch expected observed) {obstructionFirstValue = fromIntegral level}+      T.HierarchyInsertionHandleMismatch expected observed -> indices ObstructionHierarchyInsertionHandleMismatch (T.unVertexId expected) (T.unVertexId observed)+      T.PointIndexCapacityExhausted count -> firstIndex ObstructionPointIndexCapacityExhausted count+      T.RefinementMinimumAngleNotFinite value -> nonFinite ObstructionRefinementMinimumAngleNotFinite value+      T.RefinementMinimumAngleOutOfRange value -> firstValue ObstructionRefinementMinimumAngleOutOfRange value+      T.RefinementMinimumAngleDerivedRatioNotFinite value -> nonFinite ObstructionRefinementMinimumAngleDerivedRatioNotFinite value+      T.RefinementMaximumAdditionalVerticesNegative value -> firstValue ObstructionRefinementMaximumAdditionalVerticesNegative (fromIntegral value)+      T.RefinementMinimumAreaNotFinite value -> nonFinite ObstructionRefinementMinimumAreaNotFinite value+      T.RefinementMinimumAreaNegative value -> firstValue ObstructionRefinementMinimumAreaNegative value+      T.RefinementMaximumAreaNotFinite value -> nonFinite ObstructionRefinementMaximumAreaNotFinite value+      T.RefinementMaximumAreaNotPositive value -> firstValue ObstructionRefinementMaximumAreaNotPositive value+      T.RefinementMaximumRadiusEdgeRatioNotFinite value -> nonFinite ObstructionRefinementMaximumRadiusEdgeRatioNotFinite value+      T.RefinementMaximumRadiusEdgeRatioNotPositive value -> firstValue ObstructionRefinementMaximumRadiusEdgeRatioNotPositive value+      T.RefinementMaximumEdgeLengthNotFinite value -> nonFinite ObstructionRefinementMaximumEdgeLengthNotFinite value+      T.RefinementMaximumEdgeLengthNotPositive value -> firstValue ObstructionRefinementMaximumEdgeLengthNotPositive value+      T.RefinementMinimumAreaExceedsMaximum minimumArea maximumArea -> values ObstructionRefinementMinimumAreaExceedsMaximum minimumArea maximumArea+      T.RefinementSeedFaceNotActive face count -> indices ObstructionRefinementSeedFaceNotActive (T.unFaceId face) count+      T.RefinementDomainTopologyChanged -> codeOnly ObstructionRefinementDomainTopologyChanged+      T.RefinementDomainRequiresConvexHullPreservation -> codeOnly ObstructionRefinementDomainRequiresConvexHullPreservation+      T.RefinementDomainRequiresConstraintPreservation -> codeOnly ObstructionRefinementDomainRequiresConstraintPreservation+      T.RefinementDomainForbidsOuterFaceExclusion -> codeOnly ObstructionRefinementDomainForbidsOuterFaceExclusion+      T.RefinementDomainWouldCrossInterface edge face -> indices ObstructionRefinementDomainWouldCrossInterface (T.unUndirectedEdgeId edge) (T.unFaceId face)+      T.RefinementDomainWouldRewriteProtectedFace face -> firstIndex ObstructionRefinementDomainWouldRewriteProtectedFace (T.unFaceId face)+      T.RefinementDomainProtectedFaceChanged face -> firstIndex ObstructionRefinementDomainProtectedFaceChanged (T.unFaceId face)+      T.RefinementDomainInterfaceOppositeFaceNotPermitted edge face ->+        indices ObstructionRefinementDomainInterfaceOppositeFaceNotPermitted (T.unUndirectedEdgeId edge) (T.unFaceId face)+      T.RefinementOversizedEdge face edge actual bound ->+        (indices ObstructionRefinementOversizedEdge (T.unFaceId face) (T.unUndirectedEdgeId edge))+          { obstructionFirstValue = actual+          , obstructionSecondValue = bound+          }+      T.CapacityExceeded count -> firstIndex ObstructionCapacityExceeded count+      T.HalfEdgeCapacityExceeded requested capacity -> indices ObstructionHalfEdgeCapacityExceeded requested capacity+      T.FaceCapacityExceeded requested capacity -> indices ObstructionFaceCapacityExceeded requested capacity+      T.PayloadStorageFailure _ -> codeOnly ObstructionPayloadStorageFailure+      T.CoordinatePayloadCountMismatch coordinates payloads -> indices ObstructionCoordinatePayloadCountMismatch coordinates payloads+      T.CircleSweepRequiresDenseStorage -> codeOnly ObstructionCircleSweepRequiresDenseStorage+      T.SeamFrontierUnavailable -> codeOnly ObstructionSeamFrontierUnavailable+      T.RefinementDomainRequiresFiniteVertexBudget -> codeOnly ObstructionRefinementDomainRequiresFiniteVertexBudget+      T.SeamSourceEdgeRequiresFlip edge -> firstIndex ObstructionSeamSourceEdgeRequiresFlip (T.unUndirectedEdgeId edge)+      T.RefinementSeamBridgeBudgetExceeded required available -> indices ObstructionRefinementSeamBridgeBudgetExceeded required available+      T.RefinementSeamBridgeMidpointCollapsed edge -> firstIndex ObstructionRefinementSeamBridgeMidpointCollapsed (T.unUndirectedEdgeId edge)+      T.BoundarySplitRequiresBoundaryEdge edge -> firstIndex ObstructionBoundarySplitRequiresBoundaryEdge (T.unUndirectedEdgeId edge)+  )+    {obstructionMessage = show failure}+ where+  codeOnly :: ObstructionCode -> CObstruction+  codeOnly code = emptyObstruction {obstructionCode = obstructionCodeId code}+  firstIndex :: Integral index => ObstructionCode -> index -> CObstruction+  firstIndex code index = (codeOnly code) {obstructionFirstIndex = fromIntegral index}+  indices :: (Integral first, Integral second) => ObstructionCode -> first -> second -> CObstruction+  indices code firstIndexValue secondIndexValue =+    (codeOnly code)+      { obstructionFirstIndex = fromIntegral firstIndexValue+      , obstructionSecondIndex = fromIntegral secondIndexValue+      }+  firstValue :: ObstructionCode -> Double -> CObstruction+  firstValue code value = (codeOnly code) {obstructionFirstValue = value}+  values :: ObstructionCode -> Double -> Double -> CObstruction+  values code firstCoordinateValue secondCoordinateValue =+    (codeOnly code)+      { obstructionFirstValue = firstCoordinateValue+      , obstructionSecondValue = secondCoordinateValue+      }+  pointObstruction :: ObstructionCode -> Double -> Double -> CObstruction+  pointObstruction code x y =+    (codeOnly code)+      { obstructionPointX = x+      , obstructionPointY = y+      }+  nonFinite :: ObstructionCode -> T.NonFiniteValue -> CObstruction+  nonFinite code value = firstIndex code (nonFiniteCode value)++coordinateErrorCode :: T.CoordinateError -> Word32+coordinateErrorCode reason =+  coordinateErrorCodeId+    ( case reason of+        T.CoordinateNaN -> CoordinateErrorNaN+        T.CoordinateInfinite -> CoordinateErrorInfinite+        T.CoordinateTooSmall -> CoordinateErrorTooSmall+        T.CoordinateTooLarge -> CoordinateErrorTooLarge+    )++nonFiniteCode :: T.NonFiniteValue -> Word32+nonFiniteCode value =+  case value of+    T.ValueNaN -> 1+    T.ValuePositiveInfinity -> 2+    T.ValueNegativeInfinity -> 3
+ ffi/abi/Moonlight/Triangulation/Foreign/Region.hs view
@@ -0,0 +1,408 @@+{-# LANGUAGE RecordWildCards #-}++module Moonlight.Triangulation.Foreign.Region+  ( regionCopyF64+  , regionCounts+  , regionCreateF64+  , regionDifference+  , regionFree+  , regionIntersection+  , regionLocatePointF64+  , regionMeasure+  , regionSymmetricDifference+  , regionUnion+  ) where++import Data.Bifunctor (first)+import Data.Int (Int64)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import Foreign.C.String (withCStringLen)+import Foreign.C.Types (CChar, CDouble (..), CSize, CUInt)+import Foreign.Marshal.Utils (copyBytes)+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.Storable (peekElemOff, poke, pokeElemOff)+import qualified Data.Vector as V+import qualified Moonlight.Triangulation as T+import Moonlight.Triangulation.Foreign.Boundary+  ( checkedCount+  , dereferenceHandle+  , freeHandle+  , produceHandle+  , readPoints+  , requireOutputCapacity+  , requirePointer+  , runBoundary+  )+import Moonlight.Triangulation.Foreign.Contract+  ( CObstruction+  , CRegion+  , RegionLocationCode (..)+  , regionLocationCodeId+  )+import Moonlight.Triangulation.Foreign.Obstruction+  ( AbiFailure+  , RegionCountKind (..)+  , RegionLayoutError (..)+  , nullPointerFailure+  , overlayFailure+  , pointInputFailure+  , projectionFailure+  , regionLayoutFailure+  , regionPublicationFailure+  , regionValidationFailure+  , valuationFailure+  )++readCounts+  :: String+  -> Ptr CSize+  -> Int+  -> IO (Either AbiFailure (V.Vector Int))+readCounts _ _ 0 = pure (Right V.empty)+readCounts label pointer count+  | pointer == nullPtr = pure (Left (nullPointerFailure label))+  | otherwise = do+      rawCounts <- V.generateM count (peekElemOff pointer)+      pure (V.mapM (checkedCount 1) rawCounts)++validateCounts+  :: RegionCountKind+  -> Int+  -> V.Vector Int+  -> Either RegionLayoutError ()+validateCounts kind expectedTotal counts =+  case V.findIndex (== 0) counts of+    Just index -> Left (RegionGroupEmpty kind index)+    Nothing+      | observedTotal /= toInteger expectedTotal ->+          Left (RegionCountTotalMismatch kind observedTotal (toInteger expectedTotal))+      | otherwise -> Right ()+ where+  observedTotal = V.foldl' (\total count -> total + toInteger count) 0 counts++regionCreateF64+  :: Ptr CDouble+  -> CSize+  -> Ptr CSize+  -> CSize+  -> Ptr CSize+  -> CSize+  -> Ptr (Ptr CRegion)+  -> Ptr CObstruction+  -> IO CUInt+regionCreateF64 coordinates rawPointCount loopPointCounts rawLoopCount componentLoopCounts rawComponentCount output obstructionPointer =+  runBoundary obstructionPointer $+    produceHandle output $+      readRegionF64+        coordinates+        rawPointCount+        loopPointCounts+        rawLoopCount+        componentLoopCounts+        rawComponentCount++readRegionF64+  :: Ptr CDouble+  -> CSize+  -> Ptr CSize+  -> CSize+  -> Ptr CSize+  -> CSize+  -> IO (Either AbiFailure T.PlanarRegion)+readRegionF64 coordinates rawPointCount loopPointCounts rawLoopCount componentLoopCounts rawComponentCount =+  case checkedRegionInputCounts rawPointCount rawLoopCount rawComponentCount of+    Left failure -> pure (Left failure)+    Right (pointCount, loopCount, componentCount) -> do+      points <- readPoints coordinates pointCount+      loopCounts <- readCounts "loop_point_counts" loopPointCounts loopCount+      componentCounts <- readCounts "component_loop_counts" componentLoopCounts componentCount+      pure $ do+        admittedPoints <- points+        admittedLoopCounts <- loopCounts+        admittedComponentCounts <- componentCounts+        first regionLayoutFailure (validateCounts LoopPointCounts pointCount admittedLoopCounts)+        first regionLayoutFailure (validateCounts ComponentLoopCounts loopCount admittedComponentCounts)+        buildRegion admittedPoints admittedLoopCounts admittedComponentCounts++checkedRegionInputCounts+  :: CSize+  -> CSize+  -> CSize+  -> Either AbiFailure (Int, Int, Int)+checkedRegionInputCounts rawPointCount rawLoopCount rawComponentCount = do+  pointCount <- checkedCount 2 rawPointCount+  loopCount <- checkedCount 1 rawLoopCount+  componentCount <- checkedCount 1 rawComponentCount+  pure (pointCount, loopCount, componentCount)++buildRegion+  :: V.Vector T.Point+  -> V.Vector Int+  -> V.Vector Int+  -> Either AbiFailure T.PlanarRegion+buildRegion points loopCounts componentCounts = do+  exactPoints <-+    V.imapM+      (\index point -> first (pointInputFailure index point) (T.exactPointFromPoint point))+      points+  loops <- V.imapM (buildLoop exactPoints) (adjacentOffsets loopCounts)+  components <- V.imapM (buildComponent loops) (adjacentOffsets componentCounts)+  first regionValidationFailure (T.planarRegion (V.toList components))++adjacentOffsets :: V.Vector Int -> V.Vector (Int, Int)+adjacentOffsets counts =+  let offsets = V.scanl' (+) 0 counts+   in V.zip offsets (V.drop 1 offsets)++buildLoop+  :: V.Vector T.ExactPoint+  -> Int+  -> (Int, Int)+  -> Either AbiFailure T.ExactLoop+buildLoop points loopIndex (start, end) =+  case NonEmpty.nonEmpty (V.toList (V.slice start (end - start) points)) of+    Nothing -> Left (regionLayoutFailure (RegionGroupEmpty LoopPointCounts loopIndex))+    Just submitted -> first regionValidationFailure (T.exactLoop submitted)++buildComponent+  :: V.Vector T.ExactLoop+  -> Int+  -> (Int, Int)+  -> Either AbiFailure T.PolygonComponent+buildComponent loops componentIndex (start, end) =+  case NonEmpty.nonEmpty (V.toList (V.slice start (end - start) loops)) of+    Nothing -> Left (regionLayoutFailure (RegionGroupEmpty ComponentLoopCounts componentIndex))+    Just (outer :| holes) -> first regionValidationFailure (T.polygonComponent outer holes)++regionShape+  :: T.PlanarRegion+  -> ([T.PolygonComponent], [[T.ExactLoop]], [T.ExactLoop])+regionShape region =+  let components = T.planarRegionComponents region+      componentLoops component = T.polygonOuterLoop component : T.polygonHoleLoops component+      loopsByComponent = map componentLoops components+   in (components, loopsByComponent, concat loopsByComponent)++regionCounts+  :: Ptr CRegion+  -> Ptr CSize+  -> Ptr CSize+  -> Ptr CSize+  -> Ptr CObstruction+  -> IO CUInt+regionCounts regionPointer componentCountOutput loopCountOutput pointCountOutput obstructionPointer =+  runBoundary obstructionPointer $+    case+      requirePointer "region" regionPointer+        >> requirePointer "component_count" componentCountOutput+        >> requirePointer "loop_count" loopCountOutput+        >> requirePointer "point_count" pointCountOutput+    of+      Left failure -> pure (Left failure)+      Right () -> do+        region <- dereferenceHandle regionPointer+        let (components, _, loops) = regionShape region+            pointCount = sum (map (NonEmpty.length . T.exactLoopPoints) loops)+        poke componentCountOutput (fromIntegral (length components))+        poke loopCountOutput (fromIntegral (length loops))+        poke pointCountOutput (fromIntegral pointCount)+        pure (Right ())++data RegionProjection = RegionProjection+  { projectionPoints :: !(V.Vector T.Point)+  , projectionLoopPointOffsets :: !(V.Vector CSize)+  , projectionComponentLoopOffsets :: !(V.Vector CSize)+  }++regionProjection :: T.PlanarRegion -> Either AbiFailure RegionProjection+regionProjection region = do+  let (_, loopsByComponent, loops) = regionShape region+      exactPoints = concatMap (NonEmpty.toList . T.exactLoopPoints) loops+      loopPointOffsets = scanl (+) 0 (map (NonEmpty.length . T.exactLoopPoints) loops)+      componentLoopOffsets = scanl (+) 0 (map length loopsByComponent)+  projectedPoints <-+    V.fromList+      <$> traverse+        (uncurry projectPoint)+        (zip [0 ..] exactPoints)+  pure+    RegionProjection+      { projectionPoints = projectedPoints+      , projectionLoopPointOffsets = V.fromList (map fromIntegral loopPointOffsets)+      , projectionComponentLoopOffsets = V.fromList (map fromIntegral componentLoopOffsets)+      }+ where+  projectPoint index point =+    T.queryPointValue+      <$> first (projectionFailure index) (T.exactPointToEmbeddingCandidate point)++regionCopyF64+  :: Ptr CRegion+  -> Ptr CDouble+  -> CSize+  -> Ptr CSize+  -> CSize+  -> Ptr CSize+  -> CSize+  -> Ptr CObstruction+  -> IO CUInt+regionCopyF64 regionPointer coordinates rawPointCapacity loopPointOffsets rawLoopOffsetCapacity componentLoopOffsets rawComponentOffsetCapacity obstructionPointer =+  runBoundary obstructionPointer $+    case+      (,,)+        <$> (requirePointer "region" regionPointer >> checkedCount 2 rawPointCapacity)+        <*> checkedCount 1 rawLoopOffsetCapacity+        <*> checkedCount 1 rawComponentOffsetCapacity+    of+      Left failure -> pure (Left failure)+      Right (pointCapacity, loopOffsetCapacity, componentOffsetCapacity) -> do+        region <- dereferenceHandle regionPointer+        case regionProjection region of+          Left failure -> pure (Left failure)+          Right RegionProjection {..} ->+            case+              requireOutputCapacity "coordinates" coordinates (V.length projectionPoints) pointCapacity+                >> requireOutputCapacity "loop_point_offsets" loopPointOffsets (V.length projectionLoopPointOffsets) loopOffsetCapacity+                >> requireOutputCapacity "component_loop_offsets" componentLoopOffsets (V.length projectionComponentLoopOffsets) componentOffsetCapacity+            of+              Left failure -> pure (Left failure)+              Right () -> do+                V.imapM_+                  ( \index (T.Point x y) -> do+                      pokeElemOff coordinates (index * 2) (CDouble x)+                      pokeElemOff coordinates (index * 2 + 1) (CDouble y)+                  )+                  projectionPoints+                V.imapM_ (pokeElemOff loopPointOffsets) projectionLoopPointOffsets+                V.imapM_ (pokeElemOff componentLoopOffsets) projectionComponentLoopOffsets+                pure (Right ())++regionUnion, regionIntersection, regionDifference, regionSymmetricDifference :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt+regionUnion = binaryRegionOperation (\(left, right) -> left || right)+regionIntersection = binaryRegionOperation (\(left, right) -> left && right)+regionDifference = binaryRegionOperation (\(left, right) -> left && not right)+regionSymmetricDifference = binaryRegionOperation (uncurry (/=))++binaryRegionOperation+  :: ((Bool, Bool) -> Bool)+  -> Ptr CRegion+  -> Ptr CRegion+  -> Ptr (Ptr CRegion)+  -> Ptr CObstruction+  -> IO CUInt+binaryRegionOperation selected leftPointer rightPointer output obstructionPointer =+  runBoundary obstructionPointer $ produceHandle output $ do+    case requirePointer "left region" leftPointer >> requirePointer "right region" rightPointer of+      Left failure -> pure (Left failure)+      Right () -> do+        left <- dereferenceHandle leftPointer+        right <- dereferenceHandle rightPointer+        pure (exactRegionBoolean selected left right)++exactRegionBoolean+  :: ((Bool, Bool) -> Bool)+  -> T.PlanarRegion+  -> T.PlanarRegion+  -> Either AbiFailure T.PlanarRegion+exactRegionBoolean selected left right = do+  leftLayer <- first regionValidationFailure (T.planarLayer False (Map.singleton True left))+  rightLayer <- first regionValidationFailure (T.planarLayer False (Map.singleton True right))+  overlay <- first overlayFailure (T.overlayLayers leftLayer rightLayer)+  first regionPublicationFailure (T.overlaySelectedRegion selected overlay)++regionLocatePointF64+  :: Ptr CRegion+  -> CDouble+  -> CDouble+  -> Ptr CUInt+  -> Ptr CObstruction+  -> IO CUInt+regionLocatePointF64 regionPointer (CDouble x) (CDouble y) output obstructionPointer =+  runBoundary obstructionPointer $+    case+      requirePointer "region" regionPointer+        >> requirePointer "location" output+        >> first (pointInputFailure 0 (T.Point x y)) (T.exactPointFromPoint (T.Point x y))+    of+      Left failure -> pure (Left failure)+      Right query -> do+        region <- dereferenceHandle regionPointer+        poke output (regionLocationCode (T.regionPointLocation region query))+        pure (Right ())++regionLocationCode :: T.RegionPointLocation -> CUInt+regionLocationCode location =+  fromIntegral+    ( regionLocationCodeId+        ( case location of+            T.RegionExterior -> RegionLocationExterior+            T.RegionOnBoundary -> RegionLocationBoundary+            T.RegionInterior -> RegionLocationInterior+        )+    )++regionMeasure+  :: Ptr CRegion+  -> Ptr Int64+  -> Ptr CChar+  -> CSize+  -> Ptr CSize+  -> Ptr CDouble+  -> Ptr CDouble+  -> Ptr CObstruction+  -> IO CUInt+regionMeasure regionPointer eulerOutput areaRatioOutput rawAreaCapacity areaBytesWritten perimeterLowerOutput perimeterUpperOutput obstructionPointer =+  runBoundary obstructionPointer $+    case+      requirePointer "region" regionPointer+        >> requirePointer "euler_characteristic" eulerOutput+        >> requirePointer "area_bytes_written" areaBytesWritten+        >> requirePointer "perimeter_lower" perimeterLowerOutput+        >> requirePointer "perimeter_upper" perimeterUpperOutput+        >> checkedCount 1 rawAreaCapacity+    of+      Left failure -> pure (Left failure)+      Right areaCapacity -> do+        region <- dereferenceHandle regionPointer+        case regionMeasurements region of+          Left failure -> pure (Left failure)+          Right (valuations, perimeter) -> do+            let area = T.exactAreaValue (T.valuationArea valuations)+                areaText =+                  show (T.exactRationalNumerator area)+                    <> "/"+                    <> show (T.exactRationalDenominator area)+                bounds = T.exactLengthBounds perimeter+            poke eulerOutput (fromIntegral (T.eulerCharacteristicValue (T.valuationEuler valuations)))+            poke perimeterLowerOutput (CDouble (T.intervalLower bounds))+            poke perimeterUpperOutput (CDouble (T.intervalUpper bounds))+            copyCStringOutput areaText areaRatioOutput areaCapacity areaBytesWritten++regionMeasurements+  :: T.PlanarRegion+  -> Either AbiFailure (T.PlanarValuations, T.ExactLengthMeasurement)+regionMeasurements region = do+  valuations <- first valuationFailure (T.regionValuations region)+  perimeter <- first valuationFailure (T.planarValuationsPerimeter valuations)+  pure (valuations, perimeter)++copyCStringOutput+  :: String+  -> Ptr CChar+  -> Int+  -> Ptr CSize+  -> IO (Either AbiFailure ())+copyCStringOutput value output capacity bytesWritten =+  withCStringLen value $ \(source, byteCount) -> do+    poke bytesWritten (fromIntegral byteCount)+    case requireOutputCapacity "area_ratio_utf8" output (byteCount + 1) capacity of+      Left failure -> pure (Left failure)+      Right () -> do+        copyBytes output source byteCount+        pokeElemOff output byteCount 0+        pure (Right ())++regionFree :: Ptr CRegion -> IO ()+regionFree = freeHandle
+ ffi/bindings/README.md view
@@ -0,0 +1,104 @@+# Foreign bindings++`moonlight-planar.cabal` owns the private Haskell `ffi` sublibrary and+`moonlight-triangulation-c` foreign library. Python, TypeScript, and Rust are+thin lifecycle and bulk-layout leaves over that sole ABI; none implements+triangulation, overlay, publication, valuation, or morphology.++`Moonlight.Triangulation.Foreign.Contract` is the closed wire authority. Its+pure renderer owns the installed header, Windows export list, Haskell export+module, TypeScript wire vocabulary and raw declarations, Python ctypes+declarations, and Rust extern block. Check or rewrite those derived sections+from `compiler`—never edit them directly:++```bash+../scripts/safe-cabal.sh run \+  moonlight-planar:exe:moonlight-triangulation-ffi-contract \+  --project-file=cabal.project.planar-dev \+  -- check foundation/moonlight-planar+```++From `compiler`, build and locate the shared library:++```bash+../scripts/safe-cabal.sh build \+  moonlight-planar:flib:moonlight-triangulation-c \+  --project-file=cabal.project.planar-dev --enable-shared -j1+cabal list-bin moonlight-planar:flib:moonlight-triangulation-c \+  --project-file=cabal.project.planar-dev --enable-shared+```++Set `MOONLIGHT_TRIANGULATION_LIBRARY` to that `.dylib`, `.so`, or `.dll`; Rust+linking also reads its directory from `MOONLIGHT_TRIANGULATION_LIB_DIR`.++## ABI version 2++Three opaque immutable carriers cross the boundary:++- `ml_mesh` retains a binary64 Delaunay mesh. Its `ml_mesh_site_*` algebra+  combines sites, not polygon interiors.+- `ml_region` retains the authoritative exact rational `PlanarRegion`.+  `ml_region_create_f64` admits every input coordinate exactly as its binary64+  dyadic value in one call, using point counts per loop and loop counts per+  component. The inverse bulk projection returns component/loop offsets and+  binary64 rendering points; it does not replace the exact retained geometry.+- `ml_structuring_element` retains one admitted origin-containing convex+  polygon for repeated offset, inset, opening, and closing calls.++Region union, intersection, difference, and symmetric difference call the one+Haskell overlay and grouped-publication path. Point location is exact. A single+valuation call returns Euler characteristic, exact reduced area as+`numerator/denominator`, and certified conventional-perimeter bounds. Morphology+returns a new region plus the existing operation/work receipt.++Every status-returning call accepts an optional `ml_obstruction` distinguishing+pointer/count/buffer failures from region layout, validation, overlay,+publication, valuation, projection, morphology, and runtime failures. Handles+remain valid until explicitly freed; every operation publishes a fresh output+handle. `ml_runtime_initialize` is idempotent and process-lifetime.++Python and Rust owned handles are thread-affine: create, use, and release each+handle on one thread. Python exposes context management plus `dispose`; Rust+releases through `Drop`. This prevents release from racing a foreign call after+the runtime has received the raw handle.++Batch related mesh edits into one `insert_many` call. Author a whole region with+one component list; there is deliberately no mutable builder or per-vertex FFI+surface.++## Python++```python+from fractions import Fraction+from moonlight_triangulation import Moonlight, PolygonComponent++moonlight = Moonlight()+with moonlight.region([+    PolygonComponent(((0, 0), (2, 0), (2, 2), (0, 2)))+]) as left, moonlight.region([+    PolygonComponent(((1, 0), (3, 0), (3, 2), (1, 2)))+]) as right, left.intersection(right) as intersection:+    assert intersection.valuations.area == Fraction(2, 1)+```++## TypeScript++The [`@moonlight/triangulation` package guide](./typescript/README.md) owns+installation, native-library loading, typed results, and resource lifetime.++## Rust++```rust+use moonlight_triangulation::{Moonlight, PolygonComponent};++let moonlight = Moonlight::initialize()?;+let region = moonlight.region(&[PolygonComponent {+    outer: vec![[0.0, 0.0], [2.0, 0.0], [2.0, 2.0], [0.0, 2.0]],+    holes: vec![],+}])?;+println!("{:?}", region.valuations()?.area);+```++Rust reports native refusals as `MoonlightError::AbiObstruction` and keeps ABI+version, initialization, malformed projection, and unknown-wire failures as+distinct variants; it never forges a native obstruction for a wrapper defect.
+ ffi/bindings/python/pyproject.toml view
@@ -0,0 +1,13 @@+[build-system]+requires = ["hatchling>=1.27,<2"]+build-backend = "hatchling.build"++[project]+name = "moonlight-triangulation"+version = "2.0.0"+description = "Python bindings for Moonlight exact regions and immutable Delaunay meshes."+requires-python = ">=3.11"+license = { text = "MIT" }++[tool.hatch.build.targets.wheel]+packages = ["src/moonlight_triangulation"]
+ ffi/bindings/python/src/moonlight_triangulation/__init__.py view
@@ -0,0 +1,26 @@+from ._binding import Mesh, Moonlight, Region, StructuringElement+from .errors import MoonlightError+from .values import (+    MinkowskiOperation,+    MinkowskiReceipt,+    Point,+    PolygonComponent,+    RegionLocation,+    RegionValuations,+    Triangle,+)++__all__ = [+    "Mesh",+    "MinkowskiOperation",+    "MinkowskiReceipt",+    "Moonlight",+    "MoonlightError",+    "Point",+    "PolygonComponent",+    "Region",+    "RegionLocation",+    "RegionValuations",+    "StructuringElement",+    "Triangle",+]
+ ffi/bindings/python/src/moonlight_triangulation/_binding.py view
@@ -0,0 +1,450 @@+from __future__ import annotations++import ctypes+import os+import weakref+from collections.abc import Callable, Iterable, Sequence+from fractions import Fraction+from pathlib import Path+from threading import get_ident+from typing import Self++from ._native_generated import (+    ABI_VERSION,+    ML_OBSTRUCTION_BUFFER_TOO_SMALL,+    ML_STATUS_BUFFER_TOO_SMALL,+    ML_STATUS_OK,+    _NativeApi,+    _NativeMinkowskiReceipt,+    _Obstruction,+)+from .errors import MoonlightError+from .values import (+    MinkowskiOperation,+    MinkowskiReceipt,+    Point,+    PolygonComponent,+    RegionLocation,+    RegionValuations,+    Triangle,+)++_BinaryNativeOperation = Callable[[ctypes.c_void_p, ctypes.c_void_p, object, object], int]+_MorphologyNativeOperation = Callable[[ctypes.c_void_p, ctypes.c_void_p, object, object, object], int]++class Moonlight:+    def __init__(self, library_path: str | os.PathLike[str] | None = None) -> None:+        configured_path = (+            os.environ.get("MOONLIGHT_TRIANGULATION_LIBRARY")+            if library_path is None+            else library_path+        )+        if configured_path is None:+            raise ValueError("set MOONLIGHT_TRIANGULATION_LIBRARY or pass library_path")+        if os.fspath(configured_path) == "":+            raise ValueError("Moonlight native library path must not be empty")+        self._native = _NativeApi(Path(configured_path))+        initialization_status = int(self._native.library.ml_runtime_initialize())+        if initialization_status != ML_STATUS_OK:+            raise RuntimeError(+                f"Moonlight runtime initialization failed with status {initialization_status}"+            )+        observed_version = int(self._native.library.ml_abi_version())+        if observed_version != ABI_VERSION:+            raise RuntimeError(f"unsupported Moonlight ABI version {observed_version}")++    def delaunay(self, points: Sequence[Point]) -> Mesh:+        coordinates, pointer = _coordinate_buffer(points)+        handle = _produce_handle(+            lambda output, obstruction: self._native.library.ml_delaunay_f64(+                pointer, len(coordinates) // 2, output, obstruction+            ),+        )+        return Mesh(self._native, handle)++    def region(self, components: Sequence[PolygonComponent]) -> Region:+        loops, loop_counts, component_counts = _component_layout(components)+        coordinates, coordinate_pointer = _coordinate_buffer(+            point for loop in loops for point in loop+        )+        loop_buffer = _size_buffer(loop_counts)+        component_buffer = _size_buffer(component_counts)+        handle = _produce_handle(+            lambda output, obstruction: self._native.library.ml_region_create_f64(+                coordinate_pointer,+                len(coordinates) // 2,+                loop_buffer,+                len(loop_counts),+                component_buffer,+                len(component_counts),+                output,+                obstruction,+            ),+        )+        return Region(self._native, handle)++    def structuring_element(self, points: Sequence[Point]) -> StructuringElement:+        coordinates, pointer = _coordinate_buffer(points)+        handle = _produce_handle(+            lambda output, obstruction: self._native.library.ml_structuring_element_create_f64(+                pointer, len(coordinates) // 2, output, obstruction+            ),+        )+        return StructuringElement(self._native, handle)+++class _OwnedHandle:+    __slots__ = ("_native", "_handle", "_finalizer", "_kind", "_owner_thread", "__weakref__")++    def __init__(self, native: _NativeApi, handle: ctypes.c_void_p, free: Callable[[ctypes.c_void_p], None], kind: str) -> None:+        self._native = native+        self._handle = handle+        self._kind = kind+        self._owner_thread = get_ident()+        self._finalizer = weakref.finalize(self, free, handle)++    def dispose(self) -> None:+        self._require_owner_thread()+        self._finalizer()++    def __enter__(self) -> Self:+        return self++    def __exit__(self, _type: object, _value: object, _traceback: object) -> None:+        self.dispose()++    def _live_handle(self) -> ctypes.c_void_p:+        self._require_owner_thread()+        if not self._finalizer.alive:+            raise RuntimeError(f"{self._kind} is disposed")+        return self._handle++    def _require_owner_thread(self) -> None:+        if get_ident() != self._owner_thread:+            raise RuntimeError(f"{self._kind} belongs to another thread")++    def _require_same_runtime(self, other: _OwnedHandle) -> None:+        if self._native is not other._native:+            raise ValueError("both values must belong to the same Moonlight runtime")+++class Mesh(_OwnedHandle):+    __slots__ = ()++    def __init__(self, native: _NativeApi, handle: ctypes.c_void_p) -> None:+        super().__init__(native, handle, native.library.ml_mesh_free, "mesh")++    @property+    def vertex_count(self) -> int:+        return self._count(self._native.library.ml_mesh_vertex_count)++    @property+    def triangle_count(self) -> int:+        return self._count(self._native.library.ml_mesh_triangle_count)++    @property+    def vertices(self) -> tuple[Point, ...]:+        count = self.vertex_count+        output = (ctypes.c_double * (count * 2))()+        written = ctypes.c_size_t()+        obstruction = _Obstruction()+        status = int(+            self._native.library.ml_mesh_copy_vertices_f64(+                self._live_handle(), output, count, ctypes.byref(written), ctypes.byref(obstruction)+            )+        )+        _check_status(status, obstruction)+        return tuple((float(output[index * 2]), float(output[index * 2 + 1])) for index in range(written.value))++    @property+    def triangles(self) -> tuple[Triangle, ...]:+        count = self.triangle_count+        output = (ctypes.c_uint32 * (count * 3))()+        written = ctypes.c_size_t()+        obstruction = _Obstruction()+        status = int(+            self._native.library.ml_mesh_copy_triangles_u32(+                self._live_handle(), output, count, ctypes.byref(written), ctypes.byref(obstruction)+            )+        )+        _check_status(status, obstruction)+        return tuple(+            (int(output[index * 3]), int(output[index * 3 + 1]), int(output[index * 3 + 2]))+            for index in range(written.value)+        )++    def insert_many(self, points: Sequence[Point]) -> Mesh:+        coordinates, pointer = _coordinate_buffer(points)+        handle = _produce_handle(+            lambda output, obstruction: self._native.library.ml_mesh_insert_many_f64(+                self._live_handle(), pointer, len(coordinates) // 2, output, obstruction+            ),+        )+        return Mesh(self._native, handle)++    def site_union(self, other: Mesh) -> Mesh:+        return self._binary(other, self._native.library.ml_mesh_site_union)++    def site_intersection(self, other: Mesh) -> Mesh:+        return self._binary(other, self._native.library.ml_mesh_site_intersection)++    def site_difference(self, other: Mesh) -> Mesh:+        return self._binary(other, self._native.library.ml_mesh_site_difference)++    def site_symmetric_difference(self, other: Mesh) -> Mesh:+        return self._binary(other, self._native.library.ml_mesh_site_symmetric_difference)++    def _binary(self, other: Mesh, operation: _BinaryNativeOperation) -> Mesh:+        self._require_same_runtime(other)+        handle = _produce_handle(+            lambda output, obstruction: operation(+                self._live_handle(), other._live_handle(), output, obstruction+            ),+        )+        return Mesh(self._native, handle)++    def _count(self, operation: Callable[[ctypes.c_void_p, object, object], int]) -> int:+        output = ctypes.c_size_t()+        obstruction = _Obstruction()+        status = int(operation(self._live_handle(), ctypes.byref(output), ctypes.byref(obstruction)))+        _check_status(status, obstruction)+        return int(output.value)+++class Region(_OwnedHandle):+    __slots__ = ()++    def __init__(self, native: _NativeApi, handle: ctypes.c_void_p) -> None:+        super().__init__(native, handle, native.library.ml_region_free, "region")++    @property+    def components(self) -> tuple[PolygonComponent, ...]:+        component_count, loop_count, point_count = self._counts()+        coordinates = (ctypes.c_double * (point_count * 2))()+        loop_offsets = (ctypes.c_size_t * (loop_count + 1))()+        component_offsets = (ctypes.c_size_t * (component_count + 1))()+        obstruction = _Obstruction()+        status = int(+            self._native.library.ml_region_copy_f64(+                self._live_handle(),+                coordinates,+                point_count,+                loop_offsets,+                loop_count + 1,+                component_offsets,+                component_count + 1,+                ctypes.byref(obstruction),+            )+        )+        _check_status(status, obstruction)+        points = tuple((float(coordinates[index * 2]), float(coordinates[index * 2 + 1])) for index in range(point_count))+        loops = tuple(+            points[int(loop_offsets[index]) : int(loop_offsets[index + 1])]+            for index in range(loop_count)+        )+        component_ranges = tuple(+            (int(component_offsets[index]), int(component_offsets[index + 1]))+            for index in range(component_count)+        )+        if any(start >= end for start, end in component_ranges):+            raise RuntimeError("Moonlight returned a component without an outer loop")+        return tuple(+            PolygonComponent(loops[start], loops[start + 1 : end])+            for start, end in component_ranges+        )++    @property+    def valuations(self) -> RegionValuations:+        return self._measure_with_capacity(128)++    def locate(self, point: Point) -> RegionLocation:+        output = ctypes.c_uint32()+        obstruction = _Obstruction()+        status = int(+            self._native.library.ml_region_locate_point_f64(+                self._live_handle(), point[0], point[1], ctypes.byref(output), ctypes.byref(obstruction)+            )+        )+        _check_status(status, obstruction)+        return RegionLocation(output.value)++    def union(self, other: Region) -> Region:+        return self._binary(other, self._native.library.ml_region_union)++    def intersection(self, other: Region) -> Region:+        return self._binary(other, self._native.library.ml_region_intersection)++    def difference(self, other: Region) -> Region:+        return self._binary(other, self._native.library.ml_region_difference)++    def symmetric_difference(self, other: Region) -> Region:+        return self._binary(other, self._native.library.ml_region_symmetric_difference)++    def minkowski_sum(self, other: Region) -> tuple[Region, MinkowskiReceipt]:+        self._require_same_runtime(other)+        return self._morph(+            lambda output, receipt, obstruction: self._native.library.ml_region_minkowski_sum(+                self._live_handle(), other._live_handle(), output, receipt, obstruction+            )+        )++    def offset(self, element: StructuringElement) -> tuple[Region, MinkowskiReceipt]:+        return self._with_element(element, self._native.library.ml_region_offset)++    def inset(self, element: StructuringElement) -> tuple[Region, MinkowskiReceipt]:+        return self._with_element(element, self._native.library.ml_region_inset)++    def open(self, element: StructuringElement) -> tuple[Region, MinkowskiReceipt]:+        return self._with_element(element, self._native.library.ml_region_open)++    def close(self, element: StructuringElement) -> tuple[Region, MinkowskiReceipt]:+        return self._with_element(element, self._native.library.ml_region_close)++    def _binary(self, other: Region, operation: _BinaryNativeOperation) -> Region:+        self._require_same_runtime(other)+        handle = _produce_handle(+            lambda output, obstruction: operation(+                self._live_handle(), other._live_handle(), output, obstruction+            ),+        )+        return Region(self._native, handle)++    def _with_element(+        self, element: StructuringElement, operation: _MorphologyNativeOperation+    ) -> tuple[Region, MinkowskiReceipt]:+        self._require_same_runtime(element)+        return self._morph(+            lambda output, receipt, obstruction: operation(+                element._live_handle(), self._live_handle(), output, receipt, obstruction+            )+        )++    def _morph(+        self,+        operation: Callable[[object, object, object], int],+    ) -> tuple[Region, MinkowskiReceipt]:+        handle, native_receipt = _produce_morphology(operation)+        return Region(self._native, handle), _receipt(native_receipt)++    def _counts(self) -> tuple[int, int, int]:+        component_count = ctypes.c_size_t()+        loop_count = ctypes.c_size_t()+        point_count = ctypes.c_size_t()+        obstruction = _Obstruction()+        status = int(+            self._native.library.ml_region_counts(+                self._live_handle(),+                ctypes.byref(component_count),+                ctypes.byref(loop_count),+                ctypes.byref(point_count),+                ctypes.byref(obstruction),+            )+        )+        _check_status(status, obstruction)+        return int(component_count.value), int(loop_count.value), int(point_count.value)++    def _measure_with_capacity(self, capacity: int) -> RegionValuations:+        euler = ctypes.c_int64()+        area = ctypes.create_string_buffer(capacity)+        area_bytes = ctypes.c_size_t()+        lower = ctypes.c_double()+        upper = ctypes.c_double()+        obstruction = _Obstruction()+        status = int(+            self._native.library.ml_region_measure(+                self._live_handle(),+                ctypes.byref(euler),+                area,+                capacity,+                ctypes.byref(area_bytes),+                ctypes.byref(lower),+                ctypes.byref(upper),+                ctypes.byref(obstruction),+            )+        )+        if (+            status == ML_STATUS_BUFFER_TOO_SMALL+            and obstruction.code == ML_OBSTRUCTION_BUFFER_TOO_SMALL+        ):+            return self._measure_with_capacity(int(area_bytes.value) + 1)+        _check_status(status, obstruction)+        numerator, separator, denominator = area.value.decode("ascii").partition("/")+        if separator != "/":+            raise RuntimeError("Moonlight returned a malformed exact-area ratio")+        return RegionValuations(int(euler.value), Fraction(int(numerator), int(denominator)), (lower.value, upper.value))+++class StructuringElement(_OwnedHandle):+    __slots__ = ()++    def __init__(self, native: _NativeApi, handle: ctypes.c_void_p) -> None:+        super().__init__(native, handle, native.library.ml_structuring_element_free, "structuring element")+++def _component_layout(+    components: Sequence[PolygonComponent],+) -> tuple[tuple[Sequence[Point], ...], tuple[int, ...], tuple[int, ...]]:+    loops = tuple(+        loop+        for component in components+        for loop in (component.outer, *component.holes)+    )+    loop_counts = tuple(len(loop) for loop in loops)+    component_counts = tuple(len(component.holes) + 1 for component in components)+    return loops, loop_counts, component_counts+++def _coordinate_buffer(points: Iterable[Point]) -> tuple[tuple[float, ...], object]:+    coordinates = tuple(component for x, y in points for component in (x, y))+    pointer = None if not coordinates else (ctypes.c_double * len(coordinates))(*coordinates)+    return coordinates, pointer+++def _size_buffer(values: Sequence[int]) -> object:+    return (ctypes.c_size_t * len(values))(*values)+++def _produce_handle(+    operation: Callable[[object, object], int],+) -> ctypes.c_void_p:+    output = ctypes.c_void_p()+    obstruction = _Obstruction()+    status = int(operation(ctypes.byref(output), ctypes.byref(obstruction)))+    _check_status(status, obstruction)+    return _required_handle(output)+++def _produce_morphology(+    operation: Callable[[object, object, object], int],+) -> tuple[ctypes.c_void_p, _NativeMinkowskiReceipt]:+    output = ctypes.c_void_p()+    receipt = _NativeMinkowskiReceipt()+    obstruction = _Obstruction()+    status = int(operation(ctypes.byref(output), ctypes.byref(receipt), ctypes.byref(obstruction)))+    _check_status(status, obstruction)+    return _required_handle(output), receipt+++def _receipt(native: _NativeMinkowskiReceipt) -> MinkowskiReceipt:+    return MinkowskiReceipt(+        MinkowskiOperation(native.operation),+        int(native.input_components),+        int(native.convex_pieces),+        int(native.generated_pieces),+        int(native.generated_convolution_edges),+        int(native.overlay_passes),+        int(native.exact_crossings),+        int(native.output_cells),+        int(native.exact_coordinate_bit_growth),+    )+++def _check_status(status: int, obstruction: _Obstruction) -> None:+    if status != ML_STATUS_OK:+        raise MoonlightError(status, obstruction)+++def _required_handle(handle: ctypes.c_void_p) -> ctypes.c_void_p:+    if not handle.value:+        raise RuntimeError("Moonlight returned success without a handle")+    return handle
+ ffi/bindings/python/src/moonlight_triangulation/_native_generated.py view
@@ -0,0 +1,183 @@+# Generated from Moonlight.Triangulation.Foreign.Contract.+# Run moonlight-triangulation-ffi-contract write; do not edit this file.++from __future__ import annotations++import ctypes+from collections.abc import Sequence+from pathlib import Path+from typing import Final++ABI_VERSION: Final = 2+ML_STATUS_OK: Final = 0+ML_STATUS_NULL_POINTER: Final = 1+ML_STATUS_COUNT_OVERFLOW: Final = 2+ML_STATUS_BUFFER_TOO_SMALL: Final = 3+ML_STATUS_GEOMETRY_OBSTRUCTION: Final = 4+ML_STATUS_RUNTIME_FAILURE: Final = 5+ML_OBSTRUCTION_NONE: Final = 0+ML_OBSTRUCTION_INVALID_COORDINATE: Final = 1+ML_OBSTRUCTION_POINT_LOCATION_FAILED: Final = 2+ML_OBSTRUCTION_LOCATION_WALK_EXHAUSTED: Final = 3+ML_OBSTRUCTION_REFINEMENT_INPUT_TOPOLOGY_INVALID: Final = 4+ML_OBSTRUCTION_FRESH_INSERTION_MATCHED_EXISTING_VERTEX: Final = 5+ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_MISSING_OUTGOING: Final = 6+ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_TURN_MISSING: Final = 7+ML_OBSTRUCTION_DEGENERATE_LINE_CONNECTED_VERTEX_MISSING: Final = 8+ML_OBSTRUCTION_HULL_START_NOT_VISIBLE: Final = 9+ML_OBSTRUCTION_OUTER_RANGE_DID_NOT_TERMINATE: Final = 10+ML_OBSTRUCTION_OUTER_RANGE_CONTAINS_INNER_EDGE: Final = 11+ML_OBSTRUCTION_CONSTRAINED_EDGE_FLIP_REFUSED: Final = 12+ML_OBSTRUCTION_REMOVAL_VERTEX_OUT_OF_RANGE: Final = 13+ML_OBSTRUCTION_REMOVAL_EDGE_OUT_OF_RANGE: Final = 14+ML_OBSTRUCTION_REMOVAL_FACE_OUT_OF_RANGE: Final = 15+ML_OBSTRUCTION_REMOVAL_FACE_CYCLE_DID_NOT_TERMINATE: Final = 16+ML_OBSTRUCTION_REMOVAL_EMPTY_TRIANGULATION: Final = 17+ML_OBSTRUCTION_REMOVAL_TWO_POINT_DEGREE_MISMATCH: Final = 18+ML_OBSTRUCTION_REMOVAL_COLLINEAR_DEGREE_MISMATCH: Final = 19+ML_OBSTRUCTION_REMOVAL_BORDER_TOO_SHORT: Final = 20+ML_OBSTRUCTION_REMOVAL_BORDER_ARITY_MISMATCH: Final = 21+ML_OBSTRUCTION_REMOVAL_OUTGOING_CYCLE_DID_NOT_TERMINATE: Final = 22+ML_OBSTRUCTION_CIRCLE_SWEEP_HULL_EMPTY: Final = 23+ML_OBSTRUCTION_OUTER_CYCLE_DID_NOT_TERMINATE: Final = 24+ML_OBSTRUCTION_HIERARCHY_LEVEL_POPULATION_MISMATCH: Final = 25+ML_OBSTRUCTION_HIERARCHY_INSERTION_HANDLE_MISMATCH: Final = 26+ML_OBSTRUCTION_POINT_INDEX_CAPACITY_EXHAUSTED: Final = 27+ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_NOT_FINITE: Final = 28+ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_OUT_OF_RANGE: Final = 29+ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_DERIVED_RATIO_NOT_FINITE: Final = 30+ML_OBSTRUCTION_REFINEMENT_MAXIMUM_ADDITIONAL_VERTICES_NEGATIVE: Final = 31+ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NOT_FINITE: Final = 32+ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NEGATIVE: Final = 33+ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_FINITE: Final = 34+ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_POSITIVE: Final = 35+ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_FINITE: Final = 36+ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_POSITIVE: Final = 37+ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_EXCEEDS_MAXIMUM: Final = 38+ML_OBSTRUCTION_REFINEMENT_SEED_FACE_NOT_ACTIVE: Final = 39+ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EDGE_NOT_ACTIVE: Final = 40+ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_MISSING: Final = 41+ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EXTRANEOUS: Final = 42+ML_OBSTRUCTION_REFINEMENT_DOMAIN_TOPOLOGY_CHANGED: Final = 43+ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONVEX_HULL_PRESERVATION: Final = 44+ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONSTRAINT_PRESERVATION: Final = 45+ML_OBSTRUCTION_REFINEMENT_DOMAIN_FORBIDS_OUTER_FACE_EXCLUSION: Final = 46+ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_CROSS_INTERFACE: Final = 47+ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_REWRITE_PROTECTED_FACE: Final = 48+ML_OBSTRUCTION_REFINEMENT_DOMAIN_PROTECTED_FACE_CHANGED: Final = 49+ML_OBSTRUCTION_CAPACITY_EXCEEDED: Final = 50+ML_OBSTRUCTION_HALF_EDGE_CAPACITY_EXCEEDED: Final = 51+ML_OBSTRUCTION_FACE_CAPACITY_EXCEEDED: Final = 52+ML_OBSTRUCTION_PAYLOAD_STORAGE_FAILURE: Final = 53+ML_OBSTRUCTION_COORDINATE_PAYLOAD_COUNT_MISMATCH: Final = 54+ML_OBSTRUCTION_CIRCLE_SWEEP_REQUIRES_DENSE_STORAGE: Final = 55+ML_OBSTRUCTION_SEAM_FRONTIER_UNAVAILABLE: Final = 56+ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_FINITE_VERTEX_BUDGET: Final = 57+ML_OBSTRUCTION_SEAM_SOURCE_EDGE_REQUIRES_FLIP: Final = 58+ML_OBSTRUCTION_SEAM_PROTECTED_SOURCE_FACE_CHANGED: Final = 59+ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_FINITE: Final = 60+ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_POSITIVE: Final = 61+ML_OBSTRUCTION_REFINEMENT_OVERSIZED_EDGE: Final = 62+ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_BUDGET_EXCEEDED: Final = 63+ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_MIDPOINT_COLLAPSED: Final = 64+ML_OBSTRUCTION_BOUNDARY_SPLIT_REQUIRES_BOUNDARY_EDGE: Final = 65+ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_OPPOSITE_FACE_NOT_PERMITTED: Final = 66+ML_OBSTRUCTION_NULL_POINTER: Final = 100+ML_OBSTRUCTION_COUNT_OVERFLOW: Final = 101+ML_OBSTRUCTION_BUFFER_TOO_SMALL: Final = 102+ML_OBSTRUCTION_RUNTIME_FAILURE: Final = 103+ML_OBSTRUCTION_REGION_LAYOUT_INVALID: Final = 200+ML_OBSTRUCTION_REGION_VALIDATION_FAILED: Final = 201+ML_OBSTRUCTION_OVERLAY_FAILED: Final = 202+ML_OBSTRUCTION_REGION_PUBLICATION_FAILED: Final = 203+ML_OBSTRUCTION_VALUATION_FAILED: Final = 204+ML_OBSTRUCTION_MINKOWSKI_FAILED: Final = 205+ML_OBSTRUCTION_REGION_PROJECTION_FAILED: Final = 206+ML_COORDINATE_ERROR_NONE: Final = 0+ML_COORDINATE_ERROR_NAN: Final = 1+ML_COORDINATE_ERROR_INFINITE: Final = 2+ML_COORDINATE_ERROR_TOO_SMALL: Final = 3+ML_COORDINATE_ERROR_TOO_LARGE: Final = 4+ML_REGION_EXTERIOR: Final = 0+ML_REGION_BOUNDARY: Final = 1+ML_REGION_INTERIOR: Final = 2+ML_MINKOWSKI_ADDITION: Final = 0+ML_MINKOWSKI_EROSION: Final = 1+ML_MINKOWSKI_OPENING: Final = 2+ML_MINKOWSKI_CLOSING: Final = 3++class _Obstruction(ctypes.Structure):+    _fields_ = [+        ("code", ctypes.c_uint32),+        ("coordinate_error", ctypes.c_uint32),+        ("input_index", ctypes.c_uint64),+        ("first_index", ctypes.c_uint64),+        ("second_index", ctypes.c_uint64),+        ("first_value", ctypes.c_double),+        ("second_value", ctypes.c_double),+        ("point_x", ctypes.c_double),+        ("point_y", ctypes.c_double),+        ("message", ctypes.c_char * 256),+    ]+++class _NativeMinkowskiReceipt(ctypes.Structure):+    _fields_ = [+        ("operation", ctypes.c_uint32),+        ("reserved", ctypes.c_uint32),+        ("input_components", ctypes.c_uint64),+        ("convex_pieces", ctypes.c_uint64),+        ("generated_pieces", ctypes.c_uint64),+        ("generated_convolution_edges", ctypes.c_uint64),+        ("overlay_passes", ctypes.c_uint64),+        ("exact_crossings", ctypes.c_uint64),+        ("output_cells", ctypes.c_uint64),+        ("exact_coordinate_bit_growth", ctypes.c_uint64),+    ]+++class _NativeApi:+    def __init__(self, library_path: Path) -> None:+        library = ctypes.CDLL(str(library_path))+        _configure(library, "ml_abi_version", (), ctypes.c_uint32)+        _configure(library, "ml_runtime_initialize", (), ctypes.c_uint32)+        _configure(library, "ml_delaunay_f64", (ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_mesh_insert_many_f64", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_mesh_site_union", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_mesh_site_intersection", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_mesh_site_difference", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_mesh_site_symmetric_difference", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_mesh_vertex_count", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_mesh_triangle_count", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_mesh_copy_vertices_f64", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_mesh_copy_triangles_u32", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_uint32), ctypes.c_size_t, ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_mesh_free", (ctypes.c_void_p,), None)+        _configure(library, "ml_region_create_f64", (ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, ctypes.POINTER(ctypes.c_size_t), ctypes.c_size_t, ctypes.POINTER(ctypes.c_size_t), ctypes.c_size_t, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_region_counts", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_region_copy_f64", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, ctypes.POINTER(ctypes.c_size_t), ctypes.c_size_t, ctypes.POINTER(ctypes.c_size_t), ctypes.c_size_t, ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_region_union", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_region_intersection", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_region_difference", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_region_symmetric_difference", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_region_locate_point_f64", (ctypes.c_void_p, ctypes.c_double, ctypes.c_double, ctypes.POINTER(ctypes.c_uint32), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_region_measure", (ctypes.c_void_p, ctypes.POINTER(ctypes.c_int64), ctypes.POINTER(ctypes.c_char), ctypes.c_size_t, ctypes.POINTER(ctypes.c_size_t), ctypes.POINTER(ctypes.c_double), ctypes.POINTER(ctypes.c_double), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_region_free", (ctypes.c_void_p,), None)+        _configure(library, "ml_structuring_element_create_f64", (ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_structuring_element_free", (ctypes.c_void_p,), None)+        _configure(library, "ml_region_minkowski_sum", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_NativeMinkowskiReceipt), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_region_offset", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_NativeMinkowskiReceipt), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_region_inset", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_NativeMinkowskiReceipt), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_region_open", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_NativeMinkowskiReceipt), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        _configure(library, "ml_region_close", (ctypes.c_void_p, ctypes.c_void_p, ctypes.POINTER(ctypes.c_void_p), ctypes.POINTER(_NativeMinkowskiReceipt), ctypes.POINTER(_Obstruction)), ctypes.c_uint32)+        self.library = library+++def _configure(+    library: ctypes.CDLL,+    name: str,+    parameters: Sequence[object],+    result: object = ctypes.c_uint32,+) -> None:+    function = getattr(library, name)+    setattr(function, "argtypes", list(parameters))+    setattr(function, "restype", result)
+ ffi/bindings/python/src/moonlight_triangulation/errors.py view
@@ -0,0 +1,18 @@+from __future__ import annotations++from ._native_generated import _Obstruction+++class MoonlightError(RuntimeError):+    def __init__(self, status: int, obstruction: _Obstruction) -> None:+        self.status = status+        self.code = obstruction.code+        self.coordinate_error = obstruction.coordinate_error+        self.input_index = obstruction.input_index+        self.first_index = obstruction.first_index+        self.second_index = obstruction.second_index+        self.first_value = obstruction.first_value+        self.second_value = obstruction.second_value+        self.point = (obstruction.point_x, obstruction.point_y)+        message = bytes(obstruction.message).split(b"\0", 1)[0].decode("utf-8", errors="replace")+        super().__init__(message or f"Moonlight ABI failure {status}:{self.code}")
+ ffi/bindings/python/src/moonlight_triangulation/values.py view
@@ -0,0 +1,57 @@+from __future__ import annotations++from dataclasses import dataclass+from enum import IntEnum+from fractions import Fraction++from ._native_generated import (+    ML_MINKOWSKI_ADDITION,+    ML_MINKOWSKI_CLOSING,+    ML_MINKOWSKI_EROSION,+    ML_MINKOWSKI_OPENING,+    ML_REGION_BOUNDARY,+    ML_REGION_EXTERIOR,+    ML_REGION_INTERIOR,+)++Point = tuple[float, float]+Triangle = tuple[int, int, int]+++@dataclass(frozen=True)+class PolygonComponent:+    outer: tuple[Point, ...]+    holes: tuple[tuple[Point, ...], ...] = ()+++class RegionLocation(IntEnum):+    EXTERIOR = ML_REGION_EXTERIOR+    BOUNDARY = ML_REGION_BOUNDARY+    INTERIOR = ML_REGION_INTERIOR+++class MinkowskiOperation(IntEnum):+    ADDITION = ML_MINKOWSKI_ADDITION+    EROSION = ML_MINKOWSKI_EROSION+    OPENING = ML_MINKOWSKI_OPENING+    CLOSING = ML_MINKOWSKI_CLOSING+++@dataclass(frozen=True)+class RegionValuations:+    euler_characteristic: int+    area: Fraction+    perimeter_bounds: tuple[float, float]+++@dataclass(frozen=True)+class MinkowskiReceipt:+    operation: MinkowskiOperation+    input_components: int+    convex_pieces: int+    generated_pieces: int+    generated_convolution_edges: int+    overlay_passes: int+    exact_crossings: int+    output_cells: int+    exact_coordinate_bit_growth: int
+ ffi/bindings/python/tests/test_binding.py view
@@ -0,0 +1,119 @@+from __future__ import annotations++import math+import os+import unittest+from collections.abc import Sequence+from concurrent.futures import ThreadPoolExecutor+from fractions import Fraction+from typing import ClassVar++from moonlight_triangulation import (+    MinkowskiOperation,+    Moonlight,+    MoonlightError,+    PolygonComponent,+    RegionLocation,+)+++class LengthInflatingPoints(Sequence[tuple[float, float]]):+    def __len__(self) -> int:+        return 1_000++    def __getitem__(self, index: int) -> tuple[float, float]:+        if index == 0:+            return (0.0, 0.0)+        raise IndexError(index)+++class MoonlightBindingTest(unittest.TestCase):+    engine: ClassVar[Moonlight]++    @classmethod+    def setUpClass(cls) -> None:+        cls.engine = Moonlight(os.environ["MOONLIGHT_TRIANGULATION_LIBRARY"])++    def test_immutable_site_set_algebra_and_dense_projection(self) -> None:+        left = self.engine.delaunay([(0, 0), (2, 0), (0, 2), (2, 2)])+        right = self.engine.delaunay([(2, 0), (4, 0), (2, 2), (4, 2)])+        union = left.site_union(right)+        intersection = left.site_intersection(right)+        difference = left.site_difference(right)+        symmetric = left.site_symmetric_difference(right)+        extended = left.insert_many([(1, 1), (3, 1)])+        self.addCleanup(left.dispose)+        self.addCleanup(right.dispose)+        self.addCleanup(union.dispose)+        self.addCleanup(intersection.dispose)+        self.addCleanup(difference.dispose)+        self.addCleanup(symmetric.dispose)+        self.addCleanup(extended.dispose)++        self.assertEqual(left.vertex_count, 4)+        self.assertEqual(union.vertex_count, 6)+        self.assertEqual(intersection.vertex_count, 2)+        self.assertEqual(difference.vertex_count, 2)+        self.assertEqual(symmetric.vertex_count, 4)+        self.assertEqual(extended.vertex_count, 6)+        self.assertEqual(len(left.vertices), left.vertex_count)+        self.assertEqual(len(left.triangles), left.triangle_count)+        self.assertTrue(all(max(triangle) < left.vertex_count for triangle in left.triangles))++    def test_exact_region_boolean_valuation_and_morphology(self) -> None:+        left = self.engine.region([PolygonComponent(((0, 0), (2, 0), (2, 2), (0, 2)))])+        right = self.engine.region([PolygonComponent(((1, 0), (3, 0), (3, 2), (1, 2)))])+        intersection = left.intersection(right)+        difference = left.difference(right)+        symmetric = left.symmetric_difference(right)+        kernel = self.engine.structuring_element(((-0.5, -0.5), (0.5, -0.5), (0.5, 0.5), (-0.5, 0.5)))+        offset, receipt = left.offset(kernel)+        self.addCleanup(left.dispose)+        self.addCleanup(right.dispose)+        self.addCleanup(intersection.dispose)+        self.addCleanup(difference.dispose)+        self.addCleanup(symmetric.dispose)+        self.addCleanup(kernel.dispose)+        self.addCleanup(offset.dispose)++        self.assertEqual(len(left.components), 1)+        self.assertEqual(len(left.components[0].outer), 4)+        self.assertEqual(intersection.valuations.area, Fraction(2, 1))+        self.assertEqual(difference.valuations.euler_characteristic, 1)+        self.assertEqual(symmetric.valuations.euler_characteristic, 2)+        self.assertEqual(left.locate((1, 1)), RegionLocation.INTERIOR)+        self.assertEqual(left.locate((0, 1)), RegionLocation.BOUNDARY)+        self.assertEqual(left.locate((3, 1)), RegionLocation.EXTERIOR)+        self.assertEqual(offset.valuations.area, Fraction(9, 1))+        self.assertEqual(receipt.operation, MinkowskiOperation.ADDITION)+        self.assertGreaterEqual(receipt.generated_pieces, 1)++    def test_invalid_coordinate_preserves_typed_witness(self) -> None:+        with self.assertRaises(MoonlightError) as raised:+            self.engine.delaunay([(0, 0), (math.nan, 1), (1, 0)])+        self.assertEqual(raised.exception.status, 4)+        self.assertEqual(raised.exception.code, 1)+        self.assertEqual(raised.exception.coordinate_error, 1)+        self.assertEqual(raised.exception.input_index, 1)++    def test_native_count_descends_from_materialized_coordinates(self) -> None:+        mesh = self.engine.delaunay(LengthInflatingPoints())+        self.addCleanup(mesh.dispose)+        self.assertEqual(mesh.vertex_count, 1)++    def test_explicit_empty_library_path_is_not_an_environment_fallback(self) -> None:+        with self.assertRaisesRegex(ValueError, "must not be empty"):+            Moonlight("")++    def test_owned_handles_are_thread_affine(self) -> None:+        mesh = self.engine.delaunay([(0, 0), (1, 0), (0, 1)])+        self.addCleanup(mesh.dispose)+        with ThreadPoolExecutor(max_workers=1) as executor:+            foreign_access = executor.submit(lambda: mesh.vertex_count)+            with self.assertRaisesRegex(RuntimeError, "belongs to another thread"):+                foreign_access.result()+        self.assertEqual(mesh.vertex_count, 3)+++if __name__ == "__main__":+    unittest.main()
+ ffi/bindings/rust/Cargo.toml view
@@ -0,0 +1,14 @@+[package]+name = "moonlight-triangulation"+version = "2.0.0"+edition = "2024"+license = "MIT"+description = "Rust bindings for Moonlight exact regions and immutable Delaunay meshes."+repository = "https://github.com/PaleRoses/moonlight.git"+build = "build.rs"+links = "moonlight-triangulation-c"++[lib]+path = "src/lib.rs"++[workspace]
+ ffi/bindings/rust/build.rs view
@@ -0,0 +1,11 @@+use std::env;++fn main() {+    println!("cargo:rerun-if-env-changed=MOONLIGHT_TRIANGULATION_LIB_DIR");+    if let Some(directory) = env::var_os("MOONLIGHT_TRIANGULATION_LIB_DIR") {+        println!(+            "cargo:rustc-link-search=native={}",+            directory.to_string_lossy()+        );+    }+}
+ ffi/bindings/rust/src/binding.rs view
@@ -0,0 +1,646 @@+use std::marker::PhantomData;+use std::ptr::NonNull;+use std::rc::Rc;++use crate::error::{+    MoonlightError, WireVocabulary, invalid_native_result, projection_shape_error, status_result,+    success_without_handle_error,+};+use crate::raw_generated::{+    ABI_VERSION, ML_MINKOWSKI_ADDITION, ML_MINKOWSKI_CLOSING, ML_MINKOWSKI_EROSION,+    ML_MINKOWSKI_OPENING, ML_OBSTRUCTION_BUFFER_TOO_SMALL, ML_REGION_BOUNDARY, ML_REGION_EXTERIOR,+    ML_REGION_INTERIOR, ML_STATUS_BUFFER_TOO_SMALL, ML_STATUS_OK, NativeMesh,+    NativeMinkowskiReceipt, NativeObstruction, NativeRegion, NativeStructuringElement,+    ml_abi_version, ml_delaunay_f64, ml_mesh_copy_triangles_u32, ml_mesh_copy_vertices_f64,+    ml_mesh_free, ml_mesh_insert_many_f64, ml_mesh_site_difference, ml_mesh_site_intersection,+    ml_mesh_site_symmetric_difference, ml_mesh_site_union, ml_mesh_triangle_count,+    ml_mesh_vertex_count, ml_region_close, ml_region_copy_f64, ml_region_counts,+    ml_region_create_f64, ml_region_difference, ml_region_free, ml_region_inset,+    ml_region_intersection, ml_region_locate_point_f64, ml_region_measure, ml_region_minkowski_sum,+    ml_region_offset, ml_region_open, ml_region_symmetric_difference, ml_region_union,+    ml_runtime_initialize, ml_structuring_element_create_f64, ml_structuring_element_free,+};+use crate::values::{+    ExactRational, MinkowskiOperation, MinkowskiReceipt, PolygonComponent, RegionLocation,+    RegionValuations,+};++pub struct Moonlight;++impl Moonlight {+    pub fn initialize() -> Result<Self, MoonlightError> {+        let status = unsafe { ml_runtime_initialize() };+        if status != ML_STATUS_OK {+            return Err(MoonlightError::RuntimeInitializationRefused { status });+        }+        let version = unsafe { ml_abi_version() };+        if version != ABI_VERSION {+            return Err(MoonlightError::AbiVersionMismatch {+                expected: ABI_VERSION,+                observed: version,+            });+        }+        Ok(Self)+    }++    pub fn delaunay(&self, points: &[[f64; 2]]) -> Result<Mesh, MoonlightError> {+        let coordinates = flatten_points(points);+        create_handle(|output, obstruction| unsafe {+            ml_delaunay_f64(coordinates.as_ptr(), points.len(), output, obstruction)+        })+        .map(Mesh::from_handle)+    }++    pub fn region(&self, components: &[PolygonComponent]) -> Result<Region, MoonlightError> {+        let loop_point_counts = components+            .iter()+            .flat_map(|component| std::iter::once(&component.outer).chain(component.holes.iter()))+            .map(Vec::len)+            .collect::<Vec<_>>();+        let component_loop_counts = components+            .iter()+            .map(|component| component.holes.len() + 1)+            .collect::<Vec<_>>();+        let coordinates = components+            .iter()+            .flat_map(|component| std::iter::once(&component.outer).chain(component.holes.iter()))+            .flat_map(|loop_points| loop_points.iter())+            .flat_map(|[x, y]| [*x, *y])+            .collect::<Vec<_>>();+        create_handle(|output, obstruction| unsafe {+            ml_region_create_f64(+                coordinates.as_ptr(),+                coordinates.len() / 2,+                loop_point_counts.as_ptr(),+                loop_point_counts.len(),+                component_loop_counts.as_ptr(),+                components.len(),+                output,+                obstruction,+            )+        })+        .map(Region::from_handle)+    }++    pub fn structuring_element(+        &self,+        points: &[[f64; 2]],+    ) -> Result<StructuringElement, MoonlightError> {+        let coordinates = flatten_points(points);+        create_handle(|output, obstruction| unsafe {+            ml_structuring_element_create_f64(+                coordinates.as_ptr(),+                points.len(),+                output,+                obstruction,+            )+        })+        .map(StructuringElement::from_handle)+    }+}++pub struct Mesh {+    handle: NonNull<NativeMesh>,+    _thread_affinity: PhantomData<Rc<()>>,+}++impl Mesh {+    fn from_handle(handle: NonNull<NativeMesh>) -> Self {+        Self {+            handle,+            _thread_affinity: PhantomData,+        }+    }++    pub fn vertex_count(&self) -> Result<usize, MoonlightError> {+        self.count(|count, obstruction| unsafe {+            ml_mesh_vertex_count(self.handle.as_ptr(), count, obstruction)+        })+    }++    pub fn triangle_count(&self) -> Result<usize, MoonlightError> {+        self.count(|count, obstruction| unsafe {+            ml_mesh_triangle_count(self.handle.as_ptr(), count, obstruction)+        })+    }++    pub fn vertices(&self) -> Result<Vec<[f64; 2]>, MoonlightError> {+        let count = self.vertex_count()?;+        let mut coordinates = vec![0.0; count * 2];+        let mut written = 0;+        let mut obstruction = NativeObstruction::default();+        let status = unsafe {+            ml_mesh_copy_vertices_f64(+                self.handle.as_ptr(),+                coordinates.as_mut_ptr(),+                count,+                &mut written,+                &mut obstruction,+            )+        };+        status_result(status, obstruction)?;+        coordinates.truncate(written * 2);+        coordinate_pairs(&coordinates)+    }++    pub fn triangles(&self) -> Result<Vec<[u32; 3]>, MoonlightError> {+        let count = self.triangle_count()?;+        let mut triangles = vec![0; count * 3];+        let mut written = 0;+        let mut obstruction = NativeObstruction::default();+        let status = unsafe {+            ml_mesh_copy_triangles_u32(+                self.handle.as_ptr(),+                triangles.as_mut_ptr(),+                count,+                &mut written,+                &mut obstruction,+            )+        };+        status_result(status, obstruction)?;+        triangles.truncate(written * 3);+        triangles+            .chunks_exact(3)+            .map(|triangle| {+                Ok([+                    *triangle.first().ok_or_else(projection_shape_error)?,+                    *triangle.get(1).ok_or_else(projection_shape_error)?,+                    *triangle.get(2).ok_or_else(projection_shape_error)?,+                ])+            })+            .collect()+    }++    pub fn insert_many(&self, points: &[[f64; 2]]) -> Result<Self, MoonlightError> {+        let coordinates = flatten_points(points);+        create_handle(|output, obstruction| unsafe {+            ml_mesh_insert_many_f64(+                self.handle.as_ptr(),+                coordinates.as_ptr(),+                points.len(),+                output,+                obstruction,+            )+        })+        .map(Self::from_handle)+    }++    pub fn site_union(&self, other: &Self) -> Result<Self, MoonlightError> {+        self.binary(|output, obstruction| unsafe {+            ml_mesh_site_union(+                self.handle.as_ptr(),+                other.handle.as_ptr(),+                output,+                obstruction,+            )+        })+    }++    pub fn site_intersection(&self, other: &Self) -> Result<Self, MoonlightError> {+        self.binary(|output, obstruction| unsafe {+            ml_mesh_site_intersection(+                self.handle.as_ptr(),+                other.handle.as_ptr(),+                output,+                obstruction,+            )+        })+    }++    pub fn site_difference(&self, other: &Self) -> Result<Self, MoonlightError> {+        self.binary(|output, obstruction| unsafe {+            ml_mesh_site_difference(+                self.handle.as_ptr(),+                other.handle.as_ptr(),+                output,+                obstruction,+            )+        })+    }++    pub fn site_symmetric_difference(&self, other: &Self) -> Result<Self, MoonlightError> {+        self.binary(|output, obstruction| unsafe {+            ml_mesh_site_symmetric_difference(+                self.handle.as_ptr(),+                other.handle.as_ptr(),+                output,+                obstruction,+            )+        })+    }++    fn binary(+        &self,+        operation: impl FnOnce(*mut *mut NativeMesh, *mut NativeObstruction) -> u32,+    ) -> Result<Self, MoonlightError> {+        create_handle(operation).map(Self::from_handle)+    }++    fn count(+        &self,+        operation: impl FnOnce(*mut usize, *mut NativeObstruction) -> u32,+    ) -> Result<usize, MoonlightError> {+        let mut count = 0;+        let mut obstruction = NativeObstruction::default();+        let status = operation(&mut count, &mut obstruction);+        status_result(status, obstruction)?;+        Ok(count)+    }+}++impl Drop for Mesh {+    fn drop(&mut self) {+        unsafe { ml_mesh_free(self.handle.as_ptr()) }+    }+}++pub struct Region {+    handle: NonNull<NativeRegion>,+    _thread_affinity: PhantomData<Rc<()>>,+}++impl Region {+    fn from_handle(handle: NonNull<NativeRegion>) -> Self {+        Self {+            handle,+            _thread_affinity: PhantomData,+        }+    }++    pub fn components(&self) -> Result<Vec<PolygonComponent>, MoonlightError> {+        let (component_count, loop_count, point_count) = self.counts()?;+        let mut coordinates = vec![0.0; point_count * 2];+        let mut loop_point_offsets = vec![0; loop_count + 1];+        let mut component_loop_offsets = vec![0; component_count + 1];+        let mut obstruction = NativeObstruction::default();+        let status = unsafe {+            ml_region_copy_f64(+                self.handle.as_ptr(),+                coordinates.as_mut_ptr(),+                point_count,+                loop_point_offsets.as_mut_ptr(),+                loop_point_offsets.len(),+                component_loop_offsets.as_mut_ptr(),+                component_loop_offsets.len(),+                &mut obstruction,+            )+        };+        status_result(status, obstruction)?;+        let points = coordinate_pairs(&coordinates)?;+        component_loop_offsets+            .windows(2)+            .map(|window| {+                let (start, end) = offset_window(window)?;+                if start >= end {+                    return Err(projection_shape_error());+                }+                let outer = projected_loop(&points, &loop_point_offsets, start)?;+                let holes = (start + 1..end)+                    .map(|index| projected_loop(&points, &loop_point_offsets, index))+                    .collect::<Result<Vec<_>, _>>()?;+                Ok(PolygonComponent { outer, holes })+            })+            .collect()+    }++    pub fn valuations(&self) -> Result<RegionValuations, MoonlightError> {+        self.measure_with_capacity(128)+    }++    pub fn locate(&self, [x, y]: [f64; 2]) -> Result<RegionLocation, MoonlightError> {+        let mut location = 0;+        let mut obstruction = NativeObstruction::default();+        let status = unsafe {+            ml_region_locate_point_f64(self.handle.as_ptr(), x, y, &mut location, &mut obstruction)+        };+        status_result(status, obstruction)?;+        region_location(location)+    }++    pub fn union(&self, other: &Self) -> Result<Self, MoonlightError> {+        self.binary(|output, obstruction| unsafe {+            ml_region_union(+                self.handle.as_ptr(),+                other.handle.as_ptr(),+                output,+                obstruction,+            )+        })+    }++    pub fn intersection(&self, other: &Self) -> Result<Self, MoonlightError> {+        self.binary(|output, obstruction| unsafe {+            ml_region_intersection(+                self.handle.as_ptr(),+                other.handle.as_ptr(),+                output,+                obstruction,+            )+        })+    }++    pub fn difference(&self, other: &Self) -> Result<Self, MoonlightError> {+        self.binary(|output, obstruction| unsafe {+            ml_region_difference(+                self.handle.as_ptr(),+                other.handle.as_ptr(),+                output,+                obstruction,+            )+        })+    }++    pub fn symmetric_difference(&self, other: &Self) -> Result<Self, MoonlightError> {+        self.binary(|output, obstruction| unsafe {+            ml_region_symmetric_difference(+                self.handle.as_ptr(),+                other.handle.as_ptr(),+                output,+                obstruction,+            )+        })+    }++    pub fn minkowski_sum(&self, other: &Self) -> Result<(Self, MinkowskiReceipt), MoonlightError> {+        produce_morphology(|output, receipt, obstruction| unsafe {+            ml_region_minkowski_sum(+                self.handle.as_ptr(),+                other.handle.as_ptr(),+                output,+                receipt,+                obstruction,+            )+        })+    }++    pub fn offset(+        &self,+        element: &StructuringElement,+    ) -> Result<(Self, MinkowskiReceipt), MoonlightError> {+        self.with_element(+            element,+            |element, region, output, receipt, obstruction| unsafe {+                ml_region_offset(element, region, output, receipt, obstruction)+            },+        )+    }++    pub fn inset(+        &self,+        element: &StructuringElement,+    ) -> Result<(Self, MinkowskiReceipt), MoonlightError> {+        self.with_element(+            element,+            |element, region, output, receipt, obstruction| unsafe {+                ml_region_inset(element, region, output, receipt, obstruction)+            },+        )+    }++    pub fn open(+        &self,+        element: &StructuringElement,+    ) -> Result<(Self, MinkowskiReceipt), MoonlightError> {+        self.with_element(+            element,+            |element, region, output, receipt, obstruction| unsafe {+                ml_region_open(element, region, output, receipt, obstruction)+            },+        )+    }++    pub fn close(+        &self,+        element: &StructuringElement,+    ) -> Result<(Self, MinkowskiReceipt), MoonlightError> {+        self.with_element(+            element,+            |element, region, output, receipt, obstruction| unsafe {+                ml_region_close(element, region, output, receipt, obstruction)+            },+        )+    }++    fn binary(+        &self,+        operation: impl FnOnce(*mut *mut NativeRegion, *mut NativeObstruction) -> u32,+    ) -> Result<Self, MoonlightError> {+        create_handle(operation).map(Self::from_handle)+    }++    fn with_element(+        &self,+        element: &StructuringElement,+        operation: impl FnOnce(+            *const NativeStructuringElement,+            *const NativeRegion,+            *mut *mut NativeRegion,+            *mut NativeMinkowskiReceipt,+            *mut NativeObstruction,+        ) -> u32,+    ) -> Result<(Self, MinkowskiReceipt), MoonlightError> {+        produce_morphology(|output, receipt, obstruction| {+            operation(+                element.handle.as_ptr(),+                self.handle.as_ptr(),+                output,+                receipt,+                obstruction,+            )+        })+    }++    fn counts(&self) -> Result<(usize, usize, usize), MoonlightError> {+        let mut component_count = 0;+        let mut loop_count = 0;+        let mut point_count = 0;+        let mut obstruction = NativeObstruction::default();+        let status = unsafe {+            ml_region_counts(+                self.handle.as_ptr(),+                &mut component_count,+                &mut loop_count,+                &mut point_count,+                &mut obstruction,+            )+        };+        status_result(status, obstruction)?;+        Ok((component_count, loop_count, point_count))+    }++    fn measure_with_capacity(&self, capacity: usize) -> Result<RegionValuations, MoonlightError> {+        let mut euler_characteristic = 0;+        let mut area_ratio = vec![0; capacity];+        let mut area_bytes_written = 0;+        let mut perimeter_lower = 0.0;+        let mut perimeter_upper = 0.0;+        let mut obstruction = NativeObstruction::default();+        let status = unsafe {+            ml_region_measure(+                self.handle.as_ptr(),+                &mut euler_characteristic,+                area_ratio.as_mut_ptr(),+                capacity,+                &mut area_bytes_written,+                &mut perimeter_lower,+                &mut perimeter_upper,+                &mut obstruction,+            )+        };+        if status == ML_STATUS_BUFFER_TOO_SMALL+            && obstruction.code == ML_OBSTRUCTION_BUFFER_TOO_SMALL+        {+            return self.measure_with_capacity(area_bytes_written + 1);+        }+        status_result(status, obstruction)?;+        let area_bytes = area_ratio+            .get(..area_bytes_written)+            .ok_or_else(projection_shape_error)?+            .iter()+            .map(|byte| *byte as u8)+            .collect::<Vec<_>>();+        let area_text = String::from_utf8(area_bytes).map_err(|failure| {+            invalid_native_result(format!(+                "Moonlight returned a non-UTF-8 exact-area ratio: {failure}"+            ))+        })?;+        let (numerator, denominator) = area_text.split_once('/').ok_or_else(|| {+            invalid_native_result("Moonlight returned a malformed exact-area ratio")+        })?;+        Ok(RegionValuations {+            euler_characteristic,+            area: ExactRational {+                numerator: numerator.to_owned(),+                denominator: denominator.to_owned(),+            },+            perimeter_bounds: [perimeter_lower, perimeter_upper],+        })+    }+}++impl Drop for Region {+    fn drop(&mut self) {+        unsafe { ml_region_free(self.handle.as_ptr()) }+    }+}++pub struct StructuringElement {+    handle: NonNull<NativeStructuringElement>,+    _thread_affinity: PhantomData<Rc<()>>,+}++impl StructuringElement {+    fn from_handle(handle: NonNull<NativeStructuringElement>) -> Self {+        Self {+            handle,+            _thread_affinity: PhantomData,+        }+    }+}++impl Drop for StructuringElement {+    fn drop(&mut self) {+        unsafe { ml_structuring_element_free(self.handle.as_ptr()) }+    }+}++fn flatten_points(points: &[[f64; 2]]) -> Vec<f64> {+    points.iter().flat_map(|[x, y]| [*x, *y]).collect()+}++fn coordinate_pairs(coordinates: &[f64]) -> Result<Vec<[f64; 2]>, MoonlightError> {+    coordinates+        .chunks_exact(2)+        .map(|point| {+            Ok([+                *point.first().ok_or_else(projection_shape_error)?,+                *point.get(1).ok_or_else(projection_shape_error)?,+            ])+        })+        .collect()+}++fn offset_window(window: &[usize]) -> Result<(usize, usize), MoonlightError> {+    Ok((+        *window.first().ok_or_else(projection_shape_error)?,+        *window.get(1).ok_or_else(projection_shape_error)?,+    ))+}++fn projected_loop(+    points: &[[f64; 2]],+    offsets: &[usize],+    index: usize,+) -> Result<Vec<[f64; 2]>, MoonlightError> {+    let start = *offsets.get(index).ok_or_else(projection_shape_error)?;+    let end = *offsets.get(index + 1).ok_or_else(projection_shape_error)?;+    points+        .get(start..end)+        .map(<[_]>::to_vec)+        .ok_or_else(projection_shape_error)+}++fn create_handle<Native>(+    operation: impl FnOnce(*mut *mut Native, *mut NativeObstruction) -> u32,+) -> Result<NonNull<Native>, MoonlightError> {+    let mut output = std::ptr::null_mut();+    let mut obstruction = NativeObstruction::default();+    let status = operation(&mut output, &mut obstruction);+    status_result(status, obstruction)?;+    NonNull::new(output).ok_or_else(success_without_handle_error)+}++fn produce_morphology(+    operation: impl FnOnce(+        *mut *mut NativeRegion,+        *mut NativeMinkowskiReceipt,+        *mut NativeObstruction,+    ) -> u32,+) -> Result<(Region, MinkowskiReceipt), MoonlightError> {+    let mut output = std::ptr::null_mut();+    let mut receipt = NativeMinkowskiReceipt::default();+    let mut obstruction = NativeObstruction::default();+    let status = operation(&mut output, &mut receipt, &mut obstruction);+    status_result(status, obstruction)?;+    let handle = NonNull::new(output).ok_or_else(success_without_handle_error)?;+    Ok((Region::from_handle(handle), minkowski_receipt(receipt)?))+}++fn minkowski_receipt(receipt: NativeMinkowskiReceipt) -> Result<MinkowskiReceipt, MoonlightError> {+    Ok(MinkowskiReceipt {+        operation: minkowski_operation(receipt.operation)?,+        input_components: receipt.input_components,+        convex_pieces: receipt.convex_pieces,+        generated_pieces: receipt.generated_pieces,+        generated_convolution_edges: receipt.generated_convolution_edges,+        overlay_passes: receipt.overlay_passes,+        exact_crossings: receipt.exact_crossings,+        output_cells: receipt.output_cells,+        exact_coordinate_bit_growth: receipt.exact_coordinate_bit_growth,+    })+}++fn minkowski_operation(code: u32) -> Result<MinkowskiOperation, MoonlightError> {+    match code {+        ML_MINKOWSKI_ADDITION => Ok(MinkowskiOperation::Addition),+        ML_MINKOWSKI_EROSION => Ok(MinkowskiOperation::Erosion),+        ML_MINKOWSKI_OPENING => Ok(MinkowskiOperation::Opening),+        ML_MINKOWSKI_CLOSING => Ok(MinkowskiOperation::Closing),+        _ => Err(MoonlightError::UnknownWireValue {+            vocabulary: WireVocabulary::MinkowskiOperation,+            value: code,+        }),+    }+}++fn region_location(code: u32) -> Result<RegionLocation, MoonlightError> {+    match code {+        ML_REGION_EXTERIOR => Ok(RegionLocation::Exterior),+        ML_REGION_BOUNDARY => Ok(RegionLocation::Boundary),+        ML_REGION_INTERIOR => Ok(RegionLocation::Interior),+        _ => Err(MoonlightError::UnknownWireValue {+            vocabulary: WireVocabulary::RegionLocation,+            value: code,+        }),+    }+}
+ ffi/bindings/rust/src/error.rs view
@@ -0,0 +1,150 @@+use std::error::Error;+use std::fmt::{Display, Formatter};++use crate::raw_generated::{ML_STATUS_OK, NativeObstruction};++#[derive(Debug, Clone, PartialEq)]+pub enum MoonlightError {+    RuntimeInitializationRefused {+        status: u32,+    },+    AbiVersionMismatch {+        expected: u32,+        observed: u32,+    },+    AbiObstruction(AbiObstruction),+    InvalidNativeResult {+        message: String,+    },+    UnknownWireValue {+        vocabulary: WireVocabulary,+        value: u32,+    },+}++#[derive(Debug, Clone, PartialEq)]+pub struct AbiObstruction {+    pub status: u32,+    pub code: u32,+    pub coordinate_error: u32,+    pub input_index: u64,+    pub first_index: u64,+    pub second_index: u64,+    pub first_value: f64,+    pub second_value: f64,+    pub point: [f64; 2],+    pub message: String,+}++#[derive(Debug, Clone, Copy, PartialEq, Eq)]+pub enum WireVocabulary {+    RegionLocation,+    MinkowskiOperation,+}++impl Display for MoonlightError {+    fn fmt(&self, formatter: &mut Formatter<'_>) -> std::fmt::Result {+        match self {+            Self::RuntimeInitializationRefused { status } => {+                write!(+                    formatter,+                    "Moonlight runtime initialization refused with status {status}"+                )+            }+            Self::AbiVersionMismatch { expected, observed } => write!(+                formatter,+                "Moonlight ABI {observed} is incompatible with expected ABI {expected}"+            ),+            Self::AbiObstruction(obstruction) => write!(formatter, "{obstruction}"),+            Self::InvalidNativeResult { message } => write!(formatter, "{message}"),+            Self::UnknownWireValue { vocabulary, value } => {+                write!(+                    formatter,+                    "Moonlight returned unknown {vocabulary} value {value}"+                )+            }+        }+    }+}++impl Display for AbiObstruction {+    fn fmt(&self, formatter: &mut Formatter<'_>) -> std::fmt::Result {+        if self.message.is_empty() {+            write!(+                formatter,+                "Moonlight ABI failure {}:{}",+                self.status, self.code+            )+        } else {+            write!(formatter, "{}", self.message)+        }+    }+}++impl Display for WireVocabulary {+    fn fmt(&self, formatter: &mut Formatter<'_>) -> std::fmt::Result {+        match self {+            Self::RegionLocation => write!(formatter, "region-location"),+            Self::MinkowskiOperation => write!(formatter, "minkowski-operation"),+        }+    }+}++impl Error for MoonlightError {}++pub(crate) fn status_result(+    status: u32,+    obstruction: NativeObstruction,+) -> Result<(), MoonlightError> {+    if status == ML_STATUS_OK {+        Ok(())+    } else {+        Err(MoonlightError::AbiObstruction(AbiObstruction::from_native(+            status,+            obstruction,+        )))+    }+}++impl AbiObstruction {+    fn from_native(status: u32, obstruction: NativeObstruction) -> Self {+        let message_end = obstruction+            .message+            .iter()+            .position(|character| *character == 0)+            .unwrap_or(obstruction.message.len());+        let message_bytes = obstruction+            .message+            .get(..message_end)+            .unwrap_or_default()+            .iter()+            .map(|character| *character as u8)+            .collect::<Vec<_>>();+        Self {+            status,+            code: obstruction.code,+            coordinate_error: obstruction.coordinate_error,+            input_index: obstruction.input_index,+            first_index: obstruction.first_index,+            second_index: obstruction.second_index,+            first_value: obstruction.first_value,+            second_value: obstruction.second_value,+            point: [obstruction.point_x, obstruction.point_y],+            message: String::from_utf8_lossy(&message_bytes).into_owned(),+        }+    }+}++pub(crate) fn projection_shape_error() -> MoonlightError {+    invalid_native_result("Moonlight returned a malformed bulk projection")+}++pub(crate) fn success_without_handle_error() -> MoonlightError {+    invalid_native_result("Moonlight returned success without a handle")+}++pub(crate) fn invalid_native_result(message: impl Into<String>) -> MoonlightError {+    MoonlightError::InvalidNativeResult {+        message: message.into(),+    }+}
+ ffi/bindings/rust/src/lib.rs view
@@ -0,0 +1,11 @@+mod binding;+mod error;+mod raw_generated;+mod values;++pub use binding::{Mesh, Moonlight, Region, StructuringElement};+pub use error::{AbiObstruction, MoonlightError, WireVocabulary};+pub use values::{+    ExactRational, MinkowskiOperation, MinkowskiReceipt, PolygonComponent, RegionLocation,+    RegionValuations,+};
+ ffi/bindings/rust/src/raw_generated.rs view
@@ -0,0 +1,361 @@+// Generated from Moonlight.Triangulation.Foreign.Contract.+// Run moonlight-triangulation-ffi-contract write; do not edit this file.++// This private module is the complete wire projection; wrappers consume a subset.+#![allow(dead_code)]++use std::ffi::{c_char, c_double, c_uint};++pub(crate) const ABI_VERSION: u32 = 2;+pub(crate) const ML_STATUS_OK: u32 = 0;+pub(crate) const ML_STATUS_NULL_POINTER: u32 = 1;+pub(crate) const ML_STATUS_COUNT_OVERFLOW: u32 = 2;+pub(crate) const ML_STATUS_BUFFER_TOO_SMALL: u32 = 3;+pub(crate) const ML_STATUS_GEOMETRY_OBSTRUCTION: u32 = 4;+pub(crate) const ML_STATUS_RUNTIME_FAILURE: u32 = 5;+pub(crate) const ML_OBSTRUCTION_NONE: u32 = 0;+pub(crate) const ML_OBSTRUCTION_INVALID_COORDINATE: u32 = 1;+pub(crate) const ML_OBSTRUCTION_POINT_LOCATION_FAILED: u32 = 2;+pub(crate) const ML_OBSTRUCTION_LOCATION_WALK_EXHAUSTED: u32 = 3;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_INPUT_TOPOLOGY_INVALID: u32 = 4;+pub(crate) const ML_OBSTRUCTION_FRESH_INSERTION_MATCHED_EXISTING_VERTEX: u32 = 5;+pub(crate) const ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_MISSING_OUTGOING: u32 = 6;+pub(crate) const ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_TURN_MISSING: u32 = 7;+pub(crate) const ML_OBSTRUCTION_DEGENERATE_LINE_CONNECTED_VERTEX_MISSING: u32 = 8;+pub(crate) const ML_OBSTRUCTION_HULL_START_NOT_VISIBLE: u32 = 9;+pub(crate) const ML_OBSTRUCTION_OUTER_RANGE_DID_NOT_TERMINATE: u32 = 10;+pub(crate) const ML_OBSTRUCTION_OUTER_RANGE_CONTAINS_INNER_EDGE: u32 = 11;+pub(crate) const ML_OBSTRUCTION_CONSTRAINED_EDGE_FLIP_REFUSED: u32 = 12;+pub(crate) const ML_OBSTRUCTION_REMOVAL_VERTEX_OUT_OF_RANGE: u32 = 13;+pub(crate) const ML_OBSTRUCTION_REMOVAL_EDGE_OUT_OF_RANGE: u32 = 14;+pub(crate) const ML_OBSTRUCTION_REMOVAL_FACE_OUT_OF_RANGE: u32 = 15;+pub(crate) const ML_OBSTRUCTION_REMOVAL_FACE_CYCLE_DID_NOT_TERMINATE: u32 = 16;+pub(crate) const ML_OBSTRUCTION_REMOVAL_EMPTY_TRIANGULATION: u32 = 17;+pub(crate) const ML_OBSTRUCTION_REMOVAL_TWO_POINT_DEGREE_MISMATCH: u32 = 18;+pub(crate) const ML_OBSTRUCTION_REMOVAL_COLLINEAR_DEGREE_MISMATCH: u32 = 19;+pub(crate) const ML_OBSTRUCTION_REMOVAL_BORDER_TOO_SHORT: u32 = 20;+pub(crate) const ML_OBSTRUCTION_REMOVAL_BORDER_ARITY_MISMATCH: u32 = 21;+pub(crate) const ML_OBSTRUCTION_REMOVAL_OUTGOING_CYCLE_DID_NOT_TERMINATE: u32 = 22;+pub(crate) const ML_OBSTRUCTION_CIRCLE_SWEEP_HULL_EMPTY: u32 = 23;+pub(crate) const ML_OBSTRUCTION_OUTER_CYCLE_DID_NOT_TERMINATE: u32 = 24;+pub(crate) const ML_OBSTRUCTION_HIERARCHY_LEVEL_POPULATION_MISMATCH: u32 = 25;+pub(crate) const ML_OBSTRUCTION_HIERARCHY_INSERTION_HANDLE_MISMATCH: u32 = 26;+pub(crate) const ML_OBSTRUCTION_POINT_INDEX_CAPACITY_EXHAUSTED: u32 = 27;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_NOT_FINITE: u32 = 28;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_OUT_OF_RANGE: u32 = 29;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_DERIVED_RATIO_NOT_FINITE: u32 = 30;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_ADDITIONAL_VERTICES_NEGATIVE: u32 = 31;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NOT_FINITE: u32 = 32;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NEGATIVE: u32 = 33;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_FINITE: u32 = 34;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_POSITIVE: u32 = 35;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_FINITE: u32 = 36;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_POSITIVE: u32 = 37;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_EXCEEDS_MAXIMUM: u32 = 38;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_SEED_FACE_NOT_ACTIVE: u32 = 39;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EDGE_NOT_ACTIVE: u32 = 40;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_MISSING: u32 = 41;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EXTRANEOUS: u32 = 42;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_TOPOLOGY_CHANGED: u32 = 43;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONVEX_HULL_PRESERVATION: u32 = 44;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONSTRAINT_PRESERVATION: u32 = 45;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_FORBIDS_OUTER_FACE_EXCLUSION: u32 = 46;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_CROSS_INTERFACE: u32 = 47;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_REWRITE_PROTECTED_FACE: u32 = 48;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_PROTECTED_FACE_CHANGED: u32 = 49;+pub(crate) const ML_OBSTRUCTION_CAPACITY_EXCEEDED: u32 = 50;+pub(crate) const ML_OBSTRUCTION_HALF_EDGE_CAPACITY_EXCEEDED: u32 = 51;+pub(crate) const ML_OBSTRUCTION_FACE_CAPACITY_EXCEEDED: u32 = 52;+pub(crate) const ML_OBSTRUCTION_PAYLOAD_STORAGE_FAILURE: u32 = 53;+pub(crate) const ML_OBSTRUCTION_COORDINATE_PAYLOAD_COUNT_MISMATCH: u32 = 54;+pub(crate) const ML_OBSTRUCTION_CIRCLE_SWEEP_REQUIRES_DENSE_STORAGE: u32 = 55;+pub(crate) const ML_OBSTRUCTION_SEAM_FRONTIER_UNAVAILABLE: u32 = 56;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_FINITE_VERTEX_BUDGET: u32 = 57;+pub(crate) const ML_OBSTRUCTION_SEAM_SOURCE_EDGE_REQUIRES_FLIP: u32 = 58;+pub(crate) const ML_OBSTRUCTION_SEAM_PROTECTED_SOURCE_FACE_CHANGED: u32 = 59;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_FINITE: u32 = 60;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_POSITIVE: u32 = 61;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_OVERSIZED_EDGE: u32 = 62;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_BUDGET_EXCEEDED: u32 = 63;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_MIDPOINT_COLLAPSED: u32 = 64;+pub(crate) const ML_OBSTRUCTION_BOUNDARY_SPLIT_REQUIRES_BOUNDARY_EDGE: u32 = 65;+pub(crate) const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_OPPOSITE_FACE_NOT_PERMITTED: u32 = 66;+pub(crate) const ML_OBSTRUCTION_NULL_POINTER: u32 = 100;+pub(crate) const ML_OBSTRUCTION_COUNT_OVERFLOW: u32 = 101;+pub(crate) const ML_OBSTRUCTION_BUFFER_TOO_SMALL: u32 = 102;+pub(crate) const ML_OBSTRUCTION_RUNTIME_FAILURE: u32 = 103;+pub(crate) const ML_OBSTRUCTION_REGION_LAYOUT_INVALID: u32 = 200;+pub(crate) const ML_OBSTRUCTION_REGION_VALIDATION_FAILED: u32 = 201;+pub(crate) const ML_OBSTRUCTION_OVERLAY_FAILED: u32 = 202;+pub(crate) const ML_OBSTRUCTION_REGION_PUBLICATION_FAILED: u32 = 203;+pub(crate) const ML_OBSTRUCTION_VALUATION_FAILED: u32 = 204;+pub(crate) const ML_OBSTRUCTION_MINKOWSKI_FAILED: u32 = 205;+pub(crate) const ML_OBSTRUCTION_REGION_PROJECTION_FAILED: u32 = 206;+pub(crate) const ML_COORDINATE_ERROR_NONE: u32 = 0;+pub(crate) const ML_COORDINATE_ERROR_NAN: u32 = 1;+pub(crate) const ML_COORDINATE_ERROR_INFINITE: u32 = 2;+pub(crate) const ML_COORDINATE_ERROR_TOO_SMALL: u32 = 3;+pub(crate) const ML_COORDINATE_ERROR_TOO_LARGE: u32 = 4;+pub(crate) const ML_REGION_EXTERIOR: u32 = 0;+pub(crate) const ML_REGION_BOUNDARY: u32 = 1;+pub(crate) const ML_REGION_INTERIOR: u32 = 2;+pub(crate) const ML_MINKOWSKI_ADDITION: u32 = 0;+pub(crate) const ML_MINKOWSKI_EROSION: u32 = 1;+pub(crate) const ML_MINKOWSKI_OPENING: u32 = 2;+pub(crate) const ML_MINKOWSKI_CLOSING: u32 = 3;++#[repr(C)]+pub(crate) struct NativeMesh {+    _private: [u8; 0],+}++#[repr(C)]+pub(crate) struct NativeRegion {+    _private: [u8; 0],+}++#[repr(C)]+pub(crate) struct NativeStructuringElement {+    _private: [u8; 0],+}++#[repr(C)]+pub(crate) struct NativeObstruction {+    pub(crate) code: u32,+    pub(crate) coordinate_error: u32,+    pub(crate) input_index: u64,+    pub(crate) first_index: u64,+    pub(crate) second_index: u64,+    pub(crate) first_value: f64,+    pub(crate) second_value: f64,+    pub(crate) point_x: f64,+    pub(crate) point_y: f64,+    pub(crate) message: [c_char; 256],+}++impl Default for NativeObstruction {+    fn default() -> Self {+        Self {+            code: 0,+            coordinate_error: 0,+            input_index: 0,+            first_index: 0,+            second_index: 0,+            first_value: 0.0,+            second_value: 0.0,+            point_x: 0.0,+            point_y: 0.0,+            message: [0; 256],+        }+    }+}++#[repr(C)]+pub(crate) struct NativeMinkowskiReceipt {+    pub(crate) operation: u32,+    pub(crate) reserved: u32,+    pub(crate) input_components: u64,+    pub(crate) convex_pieces: u64,+    pub(crate) generated_pieces: u64,+    pub(crate) generated_convolution_edges: u64,+    pub(crate) overlay_passes: u64,+    pub(crate) exact_crossings: u64,+    pub(crate) output_cells: u64,+    pub(crate) exact_coordinate_bit_growth: u64,+}++impl Default for NativeMinkowskiReceipt {+    fn default() -> Self {+        Self {+            operation: 0,+            reserved: 0,+            input_components: 0,+            convex_pieces: 0,+            generated_pieces: 0,+            generated_convolution_edges: 0,+            overlay_passes: 0,+            exact_crossings: 0,+            output_cells: 0,+            exact_coordinate_bit_growth: 0,+        }+    }+}++#[link(name = "moonlight-triangulation-c")]+unsafe extern "C" {+    pub(crate) fn ml_abi_version() -> c_uint;+    pub(crate) fn ml_runtime_initialize() -> c_uint;+    pub(crate) fn ml_delaunay_f64(+        coordinates: *const c_double,+        point_count: usize,+        result: *mut *mut NativeMesh,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_mesh_insert_many_f64(+        mesh: *const NativeMesh,+        coordinates: *const c_double,+        point_count: usize,+        result: *mut *mut NativeMesh,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_mesh_site_union(+        left: *const NativeMesh,+        right: *const NativeMesh,+        result: *mut *mut NativeMesh,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_mesh_site_intersection(+        left: *const NativeMesh,+        right: *const NativeMesh,+        result: *mut *mut NativeMesh,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_mesh_site_difference(+        left: *const NativeMesh,+        right: *const NativeMesh,+        result: *mut *mut NativeMesh,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_mesh_site_symmetric_difference(+        left: *const NativeMesh,+        right: *const NativeMesh,+        result: *mut *mut NativeMesh,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_mesh_vertex_count(+        mesh: *const NativeMesh,+        count: *mut usize,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_mesh_triangle_count(+        mesh: *const NativeMesh,+        count: *mut usize,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_mesh_copy_vertices_f64(+        mesh: *const NativeMesh,+        coordinates: *mut c_double,+        point_capacity: usize,+        points_written: *mut usize,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_mesh_copy_triangles_u32(+        mesh: *const NativeMesh,+        triangles: *mut u32,+        triangle_capacity: usize,+        triangles_written: *mut usize,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_mesh_free(mesh: *mut NativeMesh);+    pub(crate) fn ml_region_create_f64(+        coordinates: *const c_double,+        point_count: usize,+        loop_point_counts: *const usize,+        loop_count: usize,+        component_loop_counts: *const usize,+        component_count: usize,+        result: *mut *mut NativeRegion,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_region_counts(+        region: *const NativeRegion,+        component_count: *mut usize,+        loop_count: *mut usize,+        point_count: *mut usize,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_region_copy_f64(+        region: *const NativeRegion,+        coordinates: *mut c_double,+        point_capacity: usize,+        loop_point_offsets: *mut usize,+        loop_offset_capacity: usize,+        component_loop_offsets: *mut usize,+        component_offset_capacity: usize,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_region_union(+        left: *const NativeRegion,+        right: *const NativeRegion,+        result: *mut *mut NativeRegion,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_region_intersection(+        left: *const NativeRegion,+        right: *const NativeRegion,+        result: *mut *mut NativeRegion,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_region_difference(+        left: *const NativeRegion,+        right: *const NativeRegion,+        result: *mut *mut NativeRegion,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_region_symmetric_difference(+        left: *const NativeRegion,+        right: *const NativeRegion,+        result: *mut *mut NativeRegion,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_region_locate_point_f64(+        region: *const NativeRegion,+        x: c_double,+        y: c_double,+        location: *mut u32,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_region_measure(+        region: *const NativeRegion,+        euler_characteristic: *mut i64,+        area_ratio_utf8: *mut c_char,+        area_capacity: usize,+        area_bytes_written: *mut usize,+        perimeter_lower: *mut c_double,+        perimeter_upper: *mut c_double,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_region_free(region: *mut NativeRegion);+    pub(crate) fn ml_structuring_element_create_f64(+        coordinates: *const c_double,+        point_count: usize,+        result: *mut *mut NativeStructuringElement,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_structuring_element_free(element: *mut NativeStructuringElement);+    pub(crate) fn ml_region_minkowski_sum(+        left: *const NativeRegion,+        right: *const NativeRegion,+        result: *mut *mut NativeRegion,+        receipt: *mut NativeMinkowskiReceipt,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_region_offset(+        element: *const NativeStructuringElement,+        region: *const NativeRegion,+        result: *mut *mut NativeRegion,+        receipt: *mut NativeMinkowskiReceipt,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_region_inset(+        element: *const NativeStructuringElement,+        region: *const NativeRegion,+        result: *mut *mut NativeRegion,+        receipt: *mut NativeMinkowskiReceipt,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_region_open(+        element: *const NativeStructuringElement,+        region: *const NativeRegion,+        result: *mut *mut NativeRegion,+        receipt: *mut NativeMinkowskiReceipt,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+    pub(crate) fn ml_region_close(+        element: *const NativeStructuringElement,+        region: *const NativeRegion,+        result: *mut *mut NativeRegion,+        receipt: *mut NativeMinkowskiReceipt,+        obstruction: *mut NativeObstruction,+    ) -> c_uint;+}
+ ffi/bindings/rust/src/values.rs view
@@ -0,0 +1,46 @@+#[derive(Debug, Clone, PartialEq)]+pub struct PolygonComponent {+    pub outer: Vec<[f64; 2]>,+    pub holes: Vec<Vec<[f64; 2]>>,+}++#[derive(Debug, Clone, Copy, PartialEq, Eq)]+pub enum RegionLocation {+    Exterior,+    Boundary,+    Interior,+}++#[derive(Debug, Clone, PartialEq, Eq)]+pub struct ExactRational {+    pub numerator: String,+    pub denominator: String,+}++#[derive(Debug, Clone, PartialEq)]+pub struct RegionValuations {+    pub euler_characteristic: i64,+    pub area: ExactRational,+    pub perimeter_bounds: [f64; 2],+}++#[derive(Debug, Clone, Copy, PartialEq, Eq)]+pub enum MinkowskiOperation {+    Addition,+    Erosion,+    Opening,+    Closing,+}++#[derive(Debug, Clone, PartialEq, Eq)]+pub struct MinkowskiReceipt {+    pub operation: MinkowskiOperation,+    pub input_components: u64,+    pub convex_pieces: u64,+    pub generated_pieces: u64,+    pub generated_convolution_edges: u64,+    pub overlay_passes: u64,+    pub exact_crossings: u64,+    pub output_cells: u64,+    pub exact_coordinate_bit_growth: u64,+}
+ ffi/bindings/rust/tests/binding.rs view
@@ -0,0 +1,119 @@+use moonlight_triangulation::{+    ExactRational, MinkowskiOperation, Moonlight, MoonlightError, PolygonComponent, RegionLocation,+};++#[test]+fn immutable_site_set_algebra_and_dense_projection() {+    let engine = Moonlight::initialize().expect("runtime");+    let left = engine+        .delaunay(&[[0.0, 0.0], [2.0, 0.0], [0.0, 2.0], [2.0, 2.0]])+        .expect("left mesh");+    let right = engine+        .delaunay(&[[2.0, 0.0], [4.0, 0.0], [2.0, 2.0], [4.0, 2.0]])+        .expect("right mesh");+    let union = left.site_union(&right).expect("site union");+    let intersection = left.site_intersection(&right).expect("site intersection");+    let difference = left.site_difference(&right).expect("site difference");+    let symmetric = left+        .site_symmetric_difference(&right)+        .expect("site symmetric difference");+    let extended = left+        .insert_many(&[[1.0, 1.0], [3.0, 1.0]])+        .expect("batch insertion");++    assert_eq!(left.vertex_count().expect("left count"), 4);+    assert_eq!(union.vertex_count().expect("union count"), 6);+    assert_eq!(intersection.vertex_count().expect("intersection count"), 2);+    assert_eq!(difference.vertex_count().expect("difference count"), 2);+    assert_eq!(symmetric.vertex_count().expect("symmetric count"), 4);+    assert_eq!(extended.vertex_count().expect("extended count"), 6);+    assert_eq!(+        left.vertices().expect("vertices").len(),+        left.vertex_count().expect("vertex count")+    );+    assert_eq!(+        left.triangles().expect("triangles").len(),+        left.triangle_count().expect("triangle count")+    );+}++#[test]+fn exact_region_boolean_valuation_and_morphology() {+    let engine = Moonlight::initialize().expect("runtime");+    let left = engine+        .region(&[PolygonComponent {+            outer: vec![[0.0, 0.0], [2.0, 0.0], [2.0, 2.0], [0.0, 2.0]],+            holes: vec![],+        }])+        .expect("left region");+    let right = engine+        .region(&[PolygonComponent {+            outer: vec![[1.0, 0.0], [3.0, 0.0], [3.0, 2.0], [1.0, 2.0]],+            holes: vec![],+        }])+        .expect("right region");+    let intersection = left.intersection(&right).expect("intersection");+    let symmetric = left+        .symmetric_difference(&right)+        .expect("symmetric difference");+    let kernel = engine+        .structuring_element(&[[-0.5, -0.5], [0.5, -0.5], [0.5, 0.5], [-0.5, 0.5]])+        .expect("structuring element");+    let (offset, receipt) = left.offset(&kernel).expect("offset");++    assert_eq!(left.components().expect("components").len(), 1);+    assert_eq!(+        intersection+            .valuations()+            .expect("intersection valuation")+            .area,+        ExactRational {+            numerator: "2".to_owned(),+            denominator: "1".to_owned(),+        }+    );+    assert_eq!(+        symmetric+            .valuations()+            .expect("symmetric valuation")+            .euler_characteristic,+        2+    );+    assert_eq!(+        left.locate([1.0, 1.0]).expect("interior"),+        RegionLocation::Interior+    );+    assert_eq!(+        left.locate([0.0, 1.0]).expect("boundary"),+        RegionLocation::Boundary+    );+    assert_eq!(+        left.locate([3.0, 1.0]).expect("exterior"),+        RegionLocation::Exterior+    );+    assert_eq!(+        offset.valuations().expect("offset valuation").area,+        ExactRational {+            numerator: "9".to_owned(),+            denominator: "1".to_owned(),+        }+    );+    assert_eq!(receipt.operation, MinkowskiOperation::Addition);+    assert!(receipt.generated_pieces >= 1);+}++#[test]+fn invalid_coordinate_preserves_typed_witness() {+    let engine = Moonlight::initialize().expect("runtime");+    let failure = engine+        .delaunay(&[[0.0, 0.0], [f64::NAN, 1.0], [1.0, 0.0]])+        .err()+        .expect("invalid coordinate refusal");+    let MoonlightError::AbiObstruction(obstruction) = failure else {+        panic!("expected an ABI obstruction");+    };+    assert_eq!(obstruction.status, 4);+    assert_eq!(obstruction.code, 1);+    assert_eq!(obstruction.coordinate_error, 1);+    assert_eq!(obstruction.input_index, 1);+}
+ ffi/bindings/typescript/README.md view
@@ -0,0 +1,44 @@+# `@moonlight/triangulation`++[Read the shared ABI contract.](../README.md#abi-version-2)++Typed TypeScript access to Moonlight's immutable Delaunay meshes, exact planar+regions, and polygonal morphology. The package owns JavaScript resource+lifetime and error terms; the generated raw declarations descend from the same+Haskell contract as the C header, Python declarations, and Rust declarations.++This source package does not pretend to contain a native binary. Supply an+explicit path to the ABI-version-2 shared library:++```typescript+import {+  RegionLocation,+  formatMoonlightFailure,+  loadMoonlight,+  type Result,+} from "@moonlight/triangulation";++const moonlight = loadMoonlight({+  kind: "path",+  path: "/absolute/path/to/libmoonlight-triangulation-c.so",+});++if (!moonlight.ok) {+  throw new Error(formatMoonlightFailure(moonlight.error));+}++const region = moonlight.value.region([+  { outer: [[0, 0], [2, 0], [2, 2], [0, 2]] },+]);++if (region.ok) {+  const location: Result<RegionLocation> = region.value.locate([1, 1]);+  region.value.dispose();+}+```++Every operation that can be refused returns `Result<Value, MoonlightFailure>`.+No raw Koffi handle, constructor capability, or numeric status code crosses the+package entrypoint. Owned meshes, regions, and structuring elements implement+both `dispose()` and `Symbol.dispose`; morphology therefore keeps the honest+domain method `region.close(element)`.
+ ffi/bindings/typescript/package.json view
@@ -0,0 +1,34 @@+{+  "name": "@moonlight/triangulation",+  "version": "2.0.0",+  "description": "TypeScript bindings for Moonlight exact regions and immutable Delaunay meshes.",+  "type": "module",+  "main": "./dist/src/index.js",+  "types": "./dist/src/index.d.ts",+  "exports": {+    ".": {+      "types": "./dist/src/index.d.ts",+      "import": "./dist/src/index.js"+    }+  },+  "files": [+    "dist/src",+    "README.md"+  ],+  "scripts": {+    "build": "tsc -p tsconfig.json",+    "test": "node --test dist/test/binding.test.js"+  },+  "engines": {+    "node": ">=20"+  },+  "dependencies": {+    "koffi": "3.1.4"+  },+  "devDependencies": {+    "@types/node": "26.2.0",+    "typescript": "7.0.2"+  },+  "license": "MIT",+  "packageManager": "pnpm@11.21.0"+}
+ ffi/bindings/typescript/pnpm-workspace.yaml view
@@ -0,0 +1,5 @@+packages:+  - .++allowBuilds:+  koffi: true
+ ffi/bindings/typescript/src/failure.ts view
@@ -0,0 +1,111 @@+import type {+  AbiStatus,+  CoordinateError,+  ObstructionCode,+} from "./wire.generated.js";++import type { Point } from "./values.js";++export type Result<Value, Failure = MoonlightFailure> =+  | { readonly ok: true; readonly value: Value }+  | { readonly ok: false; readonly error: Failure };++export interface Obstruction {+  readonly status: AbiStatus;+  readonly code: ObstructionCode;+  readonly coordinateError: CoordinateError;+  readonly inputIndex: bigint;+  readonly firstIndex: bigint;+  readonly secondIndex: bigint;+  readonly firstValue: number;+  readonly secondValue: number;+  readonly point: Point;+  readonly message: string;+}++export type ResourceKind = "mesh" | "region" | "structuring-element";++export type MoonlightFailure =+  | {+      readonly kind: "native-library-unavailable";+      readonly path: string;+      readonly message: string;+    }+  | {+      readonly kind: "runtime-initialization-refused";+      readonly status: AbiStatus;+    }+  | {+      readonly kind: "abi-version-mismatch";+      readonly expected: number;+      readonly observed: number;+    }+  | {+      readonly kind: "abi-obstruction";+      readonly obstruction: Obstruction;+    }+  | {+      readonly kind: "disposed-resource";+      readonly resource: ResourceKind;+    }+  | {+      readonly kind: "foreign-runtime";+      readonly resource: ResourceKind;+    }+  | {+      readonly kind: "unsafe-integer";+      readonly value: bigint;+    }+  | {+      readonly kind: "unknown-wire-value";+      readonly vocabulary: "status" | "obstruction" | "coordinate-error" | "region-location" | "minkowski-operation";+      readonly value: number;+    }+  | {+      readonly kind: "invalid-native-result";+      readonly message: string;+    }+  | {+      readonly kind: "native-call-failed";+      readonly message: string;+    };++export function success<Value>(value: Value): Result<Value> {+  return { ok: true, value };+}++export function failure<Value = never>(error: MoonlightFailure): Result<Value> {+  return { ok: false, error };+}++export function collectResults<Value>(results: readonly Result<Value>[]): Result<readonly Value[]> {+  const refused = results.find((result) => !result.ok);+  return refused?.ok === false+    ? failure(refused.error)+    : success(results.flatMap((result) => (result.ok ? [result.value] : [])));+}++export function formatMoonlightFailure(error: MoonlightFailure): string {+  switch (error.kind) {+    case "native-library-unavailable":+      return `cannot load Moonlight native library at ${error.path}: ${error.message}`;+    case "runtime-initialization-refused":+      return `Moonlight runtime initialization refused with ${error.status}`;+    case "abi-version-mismatch":+      return `Moonlight ABI ${error.observed} is incompatible with expected ABI ${error.expected}`;+    case "abi-obstruction":+      return error.obstruction.message || `${error.obstruction.status}: ${error.obstruction.code}`;+    case "disposed-resource":+      return `${error.resource} is disposed`;+    case "foreign-runtime":+      return `${error.resource} belongs to another Moonlight runtime`;+    case "unsafe-integer":+      return `Moonlight count ${error.value} exceeds JavaScript's safe integer range`;+    case "unknown-wire-value":+      return `Moonlight returned unknown ${error.vocabulary} value ${error.value}`;+    case "invalid-native-result":+      return error.message;+    case "native-call-failed":+      return error.message;+  }+}
+ ffi/bindings/typescript/src/index.ts view
@@ -0,0 +1,28 @@+export type {+  MoonlightFailure,+  Obstruction,+  ResourceKind,+  Result,+} from "./failure.js";+export { formatMoonlightFailure } from "./failure.js";+export type { Mesh } from "./mesh.js";+export type { Moonlight, NativeLibrarySource } from "./moonlight.js";+export { loadMoonlight } from "./moonlight.js";+export type { StructuringElement } from "./morphology.js";+export type { MorphologyResult, Region } from "./region.js";+export type { OwnedResource } from "./resource.js";+export type {+  ExactRational,+  MinkowskiReceipt,+  Point,+  PolygonComponent,+  RegionValuations,+  Triangle,+} from "./values.js";+export {+  AbiStatus,+  CoordinateError,+  MinkowskiOperation,+  ObstructionCode,+  RegionLocation,+} from "./wire.generated.js";
+ ffi/bindings/typescript/src/internal/call.ts view
@@ -0,0 +1,83 @@+import { failure, success, type Result } from "../failure.js";+import type { MinkowskiReceipt, Point } from "../values.js";+import { decodeMinkowskiReceipt, decodeStatus, nativeCallFailure } from "./decode.js";+import type {+  HandleOutput,+  NativeHandle,+  NativeMinkowskiReceipt,+  NativeObstruction,+} from "./native.generated.js";++type HandleOperation = (output: HandleOutput, obstruction: NativeObstruction) => number;+type MorphologyOperation = (+  output: HandleOutput,+  receipt: NativeMinkowskiReceipt,+  obstruction: NativeObstruction,+) => number;++export interface NativeMorphologyResult {+  readonly handle: NativeHandle;+  readonly receipt: MinkowskiReceipt;+}++export function produceHandle(operation: HandleOperation): Result<NativeHandle> {+  return captureNativeCall(() => {+    const output: HandleOutput = [null];+    const obstruction: NativeObstruction = {};+    const status = decodeStatus(operation(output, obstruction), obstruction);+    if (!status.ok) {+      return status;+    }+    return requireHandle(output, "handle");+  });+}++export function produceMorphology(operation: MorphologyOperation): Result<NativeMorphologyResult> {+  return captureNativeCall(() => {+    const output: HandleOutput = [null];+    const receipt: NativeMinkowskiReceipt = {};+    const obstruction: NativeObstruction = {};+    const status = decodeStatus(operation(output, receipt, obstruction), obstruction);+    if (!status.ok) {+      return status;+    }+    const handle = requireHandle(output, "region handle");+    if (!handle.ok) {+      return handle;+    }+    const decodedReceipt = decodeMinkowskiReceipt(receipt);+    return decodedReceipt.ok+      ? success({ handle: handle.value, receipt: decodedReceipt.value })+      : decodedReceipt;+  });+}++export function callStatus(operation: (obstruction: NativeObstruction) => number): Result<void> {+  return captureNativeCall(() => {+    const obstruction: NativeObstruction = {};+    return decodeStatus(operation(obstruction), obstruction);+  });+}++export function captureNativeCall<Value>(operation: () => Result<Value>): Result<Value> {+  try {+    return operation();+  } catch (cause: unknown) {+    return failure(nativeCallFailure(cause));+  }+}++export function flattenPoints(points: readonly Point[]): Float64Array {+  return Float64Array.from(points.flatMap(([x, y]) => [x, y]));+}++export function flattenLoops(loops: readonly (readonly Point[])[]): Float64Array {+  return Float64Array.from(loops.flatMap((loop) => loop.flatMap(([x, y]) => [x, y])));+}++function requireHandle(output: HandleOutput, description: string): Result<NativeHandle> {+  const handle = output[0];+  return handle === null || handle === undefined+    ? failure({ kind: "invalid-native-result", message: `Moonlight returned success without a ${description}` })+    : success(handle);+}
+ ffi/bindings/typescript/src/internal/decode.ts view
@@ -0,0 +1,117 @@+import { failure, success, type MoonlightFailure, type Obstruction, type Result } from "../failure.js";+import type { MinkowskiReceipt, Point } from "../values.js";+import {+  decodeAbiStatus,+  decodeCoordinateError,+  decodeMinkowskiOperation,+  decodeObstructionCode,+  decodeRegionLocation,+  type RegionLocation,+} from "../wire.generated.js";+import {+  ML_COORDINATE_ERROR_NONE,+  ML_OBSTRUCTION_NONE,+  ML_STATUS_OK,+  type NativeInteger,+  type NativeMinkowskiReceipt,+  type NativeObstruction,+} from "./native.generated.js";++export function decodeStatus(status: number, obstruction: NativeObstruction): Result<void> {+  if (status === ML_STATUS_OK) {+    return success(undefined);+  }+  const decodedStatus = decodeAbiStatus(status);+  if (decodedStatus === undefined) {+    return failure({ kind: "unknown-wire-value", vocabulary: "status", value: status });+  }+  const codeValue = obstruction.code ?? ML_OBSTRUCTION_NONE;+  const code = decodeObstructionCode(codeValue);+  if (code === undefined) {+    return failure({ kind: "unknown-wire-value", vocabulary: "obstruction", value: codeValue });+  }+  const coordinateErrorValue = obstruction.coordinate_error ?? ML_COORDINATE_ERROR_NONE;+  const coordinateError = decodeCoordinateError(coordinateErrorValue);+  if (coordinateError === undefined) {+    return failure({ kind: "unknown-wire-value", vocabulary: "coordinate-error", value: coordinateErrorValue });+  }+  const decoded: Obstruction = {+    status: decodedStatus,+    code,+    coordinateError,+    inputIndex: toBigInt(obstruction.input_index),+    firstIndex: toBigInt(obstruction.first_index),+    secondIndex: toBigInt(obstruction.second_index),+    firstValue: obstruction.first_value ?? 0,+    secondValue: obstruction.second_value ?? 0,+    point: [obstruction.point_x ?? 0, obstruction.point_y ?? 0],+    message: obstructionMessage(obstruction),+  };+  return failure({ kind: "abi-obstruction", obstruction: decoded });+}++export function decodeLocation(value: number | undefined): Result<RegionLocation> {+  const wireValue = value ?? -1;+  const location = decodeRegionLocation(wireValue);+  return location === undefined+    ? failure({ kind: "unknown-wire-value", vocabulary: "region-location", value: wireValue })+    : success(location);+}++export function decodeMinkowskiReceipt(receipt: NativeMinkowskiReceipt): Result<MinkowskiReceipt> {+  const operationValue = receipt.operation ?? -1;+  const operation = decodeMinkowskiOperation(operationValue);+  if (operation === undefined) {+    return failure({ kind: "unknown-wire-value", vocabulary: "minkowski-operation", value: operationValue });+  }+  return success({+    operation,+    inputComponents: toBigInt(receipt.input_components),+    convexPieces: toBigInt(receipt.convex_pieces),+    generatedPieces: toBigInt(receipt.generated_pieces),+    generatedConvolutionEdges: toBigInt(receipt.generated_convolution_edges),+    overlayPasses: toBigInt(receipt.overlay_passes),+    exactCrossings: toBigInt(receipt.exact_crossings),+    outputCells: toBigInt(receipt.output_cells),+    exactCoordinateBitGrowth: toBigInt(receipt.exact_coordinate_bit_growth),+  });+}++export function toBigInt(value: NativeInteger | undefined): bigint {+  return value === undefined ? 0n : BigInt(value);+}++export function toSafeNumber(value: NativeInteger | undefined): Result<number> {+  const exact = toBigInt(value);+  const projected = Number(exact);+  return Number.isSafeInteger(projected)+    ? success(projected)+    : failure({ kind: "unsafe-integer", value: exact });+}++export function nativeCallFailure(cause: unknown): MoonlightFailure {+  return {+    kind: "native-call-failed",+    message: cause instanceof Error ? cause.message : String(cause),+  };+}++export function pointsFromCoordinates(coordinates: Float64Array, count: number): readonly Point[] {+  return Array.from({ length: count }, (_unused, index): Point => [+    coordinates[index * 2] ?? 0,+    coordinates[index * 2 + 1] ?? 0,+  ]);+}++function obstructionMessage(obstruction: NativeObstruction): string {+  const message = obstruction.message;+  if (message === undefined) {+    return "Moonlight ABI obstruction";+  }+  if (typeof message === "string") {+    return message.split("\0", 1)[0] ?? "";+  }+  const terminator = message.indexOf(0);+  const length = terminator === -1 ? message.length : terminator;+  return new TextDecoder().decode(Uint8Array.from(message.slice(0, length)));+}
+ ffi/bindings/typescript/src/internal/native.generated.ts view
@@ -0,0 +1,242 @@+// Generated from Moonlight.Triangulation.Foreign.Contract.+// Run moonlight-triangulation-ffi-contract write; do not edit this file.++import koffi from "koffi";++export const ABI_VERSION = 2;+export const ML_STATUS_OK = 0;+export const ML_STATUS_NULL_POINTER = 1;+export const ML_STATUS_COUNT_OVERFLOW = 2;+export const ML_STATUS_BUFFER_TOO_SMALL = 3;+export const ML_STATUS_GEOMETRY_OBSTRUCTION = 4;+export const ML_STATUS_RUNTIME_FAILURE = 5;+export const ML_OBSTRUCTION_NONE = 0;+export const ML_OBSTRUCTION_INVALID_COORDINATE = 1;+export const ML_OBSTRUCTION_POINT_LOCATION_FAILED = 2;+export const ML_OBSTRUCTION_LOCATION_WALK_EXHAUSTED = 3;+export const ML_OBSTRUCTION_REFINEMENT_INPUT_TOPOLOGY_INVALID = 4;+export const ML_OBSTRUCTION_FRESH_INSERTION_MATCHED_EXISTING_VERTEX = 5;+export const ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_MISSING_OUTGOING = 6;+export const ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_TURN_MISSING = 7;+export const ML_OBSTRUCTION_DEGENERATE_LINE_CONNECTED_VERTEX_MISSING = 8;+export const ML_OBSTRUCTION_HULL_START_NOT_VISIBLE = 9;+export const ML_OBSTRUCTION_OUTER_RANGE_DID_NOT_TERMINATE = 10;+export const ML_OBSTRUCTION_OUTER_RANGE_CONTAINS_INNER_EDGE = 11;+export const ML_OBSTRUCTION_CONSTRAINED_EDGE_FLIP_REFUSED = 12;+export const ML_OBSTRUCTION_REMOVAL_VERTEX_OUT_OF_RANGE = 13;+export const ML_OBSTRUCTION_REMOVAL_EDGE_OUT_OF_RANGE = 14;+export const ML_OBSTRUCTION_REMOVAL_FACE_OUT_OF_RANGE = 15;+export const ML_OBSTRUCTION_REMOVAL_FACE_CYCLE_DID_NOT_TERMINATE = 16;+export const ML_OBSTRUCTION_REMOVAL_EMPTY_TRIANGULATION = 17;+export const ML_OBSTRUCTION_REMOVAL_TWO_POINT_DEGREE_MISMATCH = 18;+export const ML_OBSTRUCTION_REMOVAL_COLLINEAR_DEGREE_MISMATCH = 19;+export const ML_OBSTRUCTION_REMOVAL_BORDER_TOO_SHORT = 20;+export const ML_OBSTRUCTION_REMOVAL_BORDER_ARITY_MISMATCH = 21;+export const ML_OBSTRUCTION_REMOVAL_OUTGOING_CYCLE_DID_NOT_TERMINATE = 22;+export const ML_OBSTRUCTION_CIRCLE_SWEEP_HULL_EMPTY = 23;+export const ML_OBSTRUCTION_OUTER_CYCLE_DID_NOT_TERMINATE = 24;+export const ML_OBSTRUCTION_HIERARCHY_LEVEL_POPULATION_MISMATCH = 25;+export const ML_OBSTRUCTION_HIERARCHY_INSERTION_HANDLE_MISMATCH = 26;+export const ML_OBSTRUCTION_POINT_INDEX_CAPACITY_EXHAUSTED = 27;+export const ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_NOT_FINITE = 28;+export const ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_OUT_OF_RANGE = 29;+export const ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_DERIVED_RATIO_NOT_FINITE = 30;+export const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_ADDITIONAL_VERTICES_NEGATIVE = 31;+export const ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NOT_FINITE = 32;+export const ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NEGATIVE = 33;+export const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_FINITE = 34;+export const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_POSITIVE = 35;+export const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_FINITE = 36;+export const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_POSITIVE = 37;+export const ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_EXCEEDS_MAXIMUM = 38;+export const ML_OBSTRUCTION_REFINEMENT_SEED_FACE_NOT_ACTIVE = 39;+export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EDGE_NOT_ACTIVE = 40;+export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_MISSING = 41;+export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EXTRANEOUS = 42;+export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_TOPOLOGY_CHANGED = 43;+export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONVEX_HULL_PRESERVATION = 44;+export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONSTRAINT_PRESERVATION = 45;+export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_FORBIDS_OUTER_FACE_EXCLUSION = 46;+export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_CROSS_INTERFACE = 47;+export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_REWRITE_PROTECTED_FACE = 48;+export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_PROTECTED_FACE_CHANGED = 49;+export const ML_OBSTRUCTION_CAPACITY_EXCEEDED = 50;+export const ML_OBSTRUCTION_HALF_EDGE_CAPACITY_EXCEEDED = 51;+export const ML_OBSTRUCTION_FACE_CAPACITY_EXCEEDED = 52;+export const ML_OBSTRUCTION_PAYLOAD_STORAGE_FAILURE = 53;+export const ML_OBSTRUCTION_COORDINATE_PAYLOAD_COUNT_MISMATCH = 54;+export const ML_OBSTRUCTION_CIRCLE_SWEEP_REQUIRES_DENSE_STORAGE = 55;+export const ML_OBSTRUCTION_SEAM_FRONTIER_UNAVAILABLE = 56;+export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_FINITE_VERTEX_BUDGET = 57;+export const ML_OBSTRUCTION_SEAM_SOURCE_EDGE_REQUIRES_FLIP = 58;+export const ML_OBSTRUCTION_SEAM_PROTECTED_SOURCE_FACE_CHANGED = 59;+export const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_FINITE = 60;+export const ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_POSITIVE = 61;+export const ML_OBSTRUCTION_REFINEMENT_OVERSIZED_EDGE = 62;+export const ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_BUDGET_EXCEEDED = 63;+export const ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_MIDPOINT_COLLAPSED = 64;+export const ML_OBSTRUCTION_BOUNDARY_SPLIT_REQUIRES_BOUNDARY_EDGE = 65;+export const ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_OPPOSITE_FACE_NOT_PERMITTED = 66;+export const ML_OBSTRUCTION_NULL_POINTER = 100;+export const ML_OBSTRUCTION_COUNT_OVERFLOW = 101;+export const ML_OBSTRUCTION_BUFFER_TOO_SMALL = 102;+export const ML_OBSTRUCTION_RUNTIME_FAILURE = 103;+export const ML_OBSTRUCTION_REGION_LAYOUT_INVALID = 200;+export const ML_OBSTRUCTION_REGION_VALIDATION_FAILED = 201;+export const ML_OBSTRUCTION_OVERLAY_FAILED = 202;+export const ML_OBSTRUCTION_REGION_PUBLICATION_FAILED = 203;+export const ML_OBSTRUCTION_VALUATION_FAILED = 204;+export const ML_OBSTRUCTION_MINKOWSKI_FAILED = 205;+export const ML_OBSTRUCTION_REGION_PROJECTION_FAILED = 206;+export const ML_COORDINATE_ERROR_NONE = 0;+export const ML_COORDINATE_ERROR_NAN = 1;+export const ML_COORDINATE_ERROR_INFINITE = 2;+export const ML_COORDINATE_ERROR_TOO_SMALL = 3;+export const ML_COORDINATE_ERROR_TOO_LARGE = 4;+export const ML_REGION_EXTERIOR = 0;+export const ML_REGION_BOUNDARY = 1;+export const ML_REGION_INTERIOR = 2;+export const ML_MINKOWSKI_ADDITION = 0;+export const ML_MINKOWSKI_EROSION = 1;+export const ML_MINKOWSKI_OPENING = 2;+export const ML_MINKOWSKI_CLOSING = 3;++export type NativeHandle = object;+export type NativeInteger = number | bigint;+export type HandleOutput = Array<NativeHandle | null>;++export interface NativeObstruction {+  code?: number;+  coordinate_error?: number;+  input_index?: NativeInteger;+  first_index?: NativeInteger;+  second_index?: NativeInteger;+  first_value?: number;+  second_value?: number;+  point_x?: number;+  point_y?: number;+  message?: string | readonly number[];+}++export interface NativeMinkowskiReceipt {+  operation?: number;+  reserved?: number;+  input_components?: NativeInteger;+  convex_pieces?: NativeInteger;+  generated_pieces?: NativeInteger;+  generated_convolution_edges?: NativeInteger;+  overlay_passes?: NativeInteger;+  exact_crossings?: NativeInteger;+  output_cells?: NativeInteger;+  exact_coordinate_bit_growth?: NativeInteger;+}++export interface NativeApi {+  readonly ml_abi_version: () => number;+  readonly ml_runtime_initialize: () => number;+  readonly ml_delaunay_f64: (coordinates: Float64Array, point_count: number, result: HandleOutput, obstruction: NativeObstruction) => number;+  readonly ml_mesh_insert_many_f64: (mesh: NativeHandle, coordinates: Float64Array, point_count: number, result: HandleOutput, obstruction: NativeObstruction) => number;+  readonly ml_mesh_site_union: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number;+  readonly ml_mesh_site_intersection: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number;+  readonly ml_mesh_site_difference: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number;+  readonly ml_mesh_site_symmetric_difference: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number;+  readonly ml_mesh_vertex_count: (mesh: NativeHandle, count: NativeInteger[], obstruction: NativeObstruction) => number;+  readonly ml_mesh_triangle_count: (mesh: NativeHandle, count: NativeInteger[], obstruction: NativeObstruction) => number;+  readonly ml_mesh_copy_vertices_f64: (mesh: NativeHandle, coordinates: Float64Array, point_capacity: number, points_written: NativeInteger[], obstruction: NativeObstruction) => number;+  readonly ml_mesh_copy_triangles_u32: (mesh: NativeHandle, triangles: Uint32Array, triangle_capacity: number, triangles_written: NativeInteger[], obstruction: NativeObstruction) => number;+  readonly ml_mesh_free: (mesh: NativeHandle) => void;+  readonly ml_region_create_f64: (coordinates: Float64Array, point_count: number, loop_point_counts: BigUint64Array, loop_count: number, component_loop_counts: BigUint64Array, component_count: number, result: HandleOutput, obstruction: NativeObstruction) => number;+  readonly ml_region_counts: (region: NativeHandle, component_count: NativeInteger[], loop_count: NativeInteger[], point_count: NativeInteger[], obstruction: NativeObstruction) => number;+  readonly ml_region_copy_f64: (region: NativeHandle, coordinates: Float64Array, point_capacity: number, loop_point_offsets: BigUint64Array, loop_offset_capacity: number, component_loop_offsets: BigUint64Array, component_offset_capacity: number, obstruction: NativeObstruction) => number;+  readonly ml_region_union: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number;+  readonly ml_region_intersection: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number;+  readonly ml_region_difference: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number;+  readonly ml_region_symmetric_difference: (left: NativeHandle, right: NativeHandle, result: HandleOutput, obstruction: NativeObstruction) => number;+  readonly ml_region_locate_point_f64: (region: NativeHandle, x: number, y: number, location: number[], obstruction: NativeObstruction) => number;+  readonly ml_region_measure: (region: NativeHandle, euler_characteristic: NativeInteger[], area_ratio_utf8: Buffer, area_capacity: number, area_bytes_written: NativeInteger[], perimeter_lower: number[], perimeter_upper: number[], obstruction: NativeObstruction) => number;+  readonly ml_region_free: (region: NativeHandle) => void;+  readonly ml_structuring_element_create_f64: (coordinates: Float64Array, point_count: number, result: HandleOutput, obstruction: NativeObstruction) => number;+  readonly ml_structuring_element_free: (element: NativeHandle) => void;+  readonly ml_region_minkowski_sum: (left: NativeHandle, right: NativeHandle, result: HandleOutput, receipt: NativeMinkowskiReceipt, obstruction: NativeObstruction) => number;+  readonly ml_region_offset: (element: NativeHandle, region: NativeHandle, result: HandleOutput, receipt: NativeMinkowskiReceipt, obstruction: NativeObstruction) => number;+  readonly ml_region_inset: (element: NativeHandle, region: NativeHandle, result: HandleOutput, receipt: NativeMinkowskiReceipt, obstruction: NativeObstruction) => number;+  readonly ml_region_open: (element: NativeHandle, region: NativeHandle, result: HandleOutput, receipt: NativeMinkowskiReceipt, obstruction: NativeObstruction) => number;+  readonly ml_region_close: (element: NativeHandle, region: NativeHandle, result: HandleOutput, receipt: NativeMinkowskiReceipt, obstruction: NativeObstruction) => number;+}++export function loadNativeApi(libraryPath: string): NativeApi {+  const library = koffi.load(libraryPath);+  const mesh = koffi.opaque();+  const meshPointer = koffi.pointer(mesh);+  const meshOutput = koffi.out(koffi.pointer(mesh, 2));+  const region = koffi.opaque();+  const regionPointer = koffi.pointer(region);+  const regionOutput = koffi.out(koffi.pointer(region, 2));+  const structuringElement = koffi.opaque();+  const structuringElementPointer = koffi.pointer(structuringElement);+  const structuringElementOutput = koffi.out(koffi.pointer(structuringElement, 2));++  const obstruction = koffi.struct({+    code: "uint32_t",+    coordinate_error: "uint32_t",+    input_index: "uint64_t",+    first_index: "uint64_t",+    second_index: "uint64_t",+    first_value: "double",+    second_value: "double",+    point_x: "double",+    point_y: "double",+    message: koffi.array("char", 256),+  });+  const receipt = koffi.struct({+    operation: "uint32_t",+    reserved: "uint32_t",+    input_components: "uint64_t",+    convex_pieces: "uint64_t",+    generated_pieces: "uint64_t",+    generated_convolution_edges: "uint64_t",+    overlay_passes: "uint64_t",+    exact_crossings: "uint64_t",+    output_cells: "uint64_t",+    exact_coordinate_bit_growth: "uint64_t",+  });+  const obstructionOutput = koffi.out(koffi.pointer(obstruction));+  const receiptOutput = koffi.out(koffi.pointer(receipt));+  const sizeOutput = koffi.out(koffi.pointer("size_t"));+  const uint32Output = koffi.out(koffi.pointer("uint32_t"));+  const int64Output = koffi.out(koffi.pointer("int64_t"));+  const doubleOutput = koffi.out(koffi.pointer("double"));+  const sizeArray = koffi.pointer("size_t");+  return {+    ml_abi_version: library.func("ml_abi_version", "uint32_t", []),+    ml_runtime_initialize: library.func("ml_runtime_initialize", "uint32_t", []),+    ml_delaunay_f64: library.func("ml_delaunay_f64", "uint32_t", [koffi.pointer("double"), "size_t", meshOutput, obstructionOutput]),+    ml_mesh_insert_many_f64: library.func("ml_mesh_insert_many_f64", "uint32_t", [meshPointer, koffi.pointer("double"), "size_t", meshOutput, obstructionOutput]),+    ml_mesh_site_union: library.func("ml_mesh_site_union", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]),+    ml_mesh_site_intersection: library.func("ml_mesh_site_intersection", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]),+    ml_mesh_site_difference: library.func("ml_mesh_site_difference", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]),+    ml_mesh_site_symmetric_difference: library.func("ml_mesh_site_symmetric_difference", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]),+    ml_mesh_vertex_count: library.func("ml_mesh_vertex_count", "uint32_t", [meshPointer, sizeOutput, obstructionOutput]),+    ml_mesh_triangle_count: library.func("ml_mesh_triangle_count", "uint32_t", [meshPointer, sizeOutput, obstructionOutput]),+    ml_mesh_copy_vertices_f64: library.func("ml_mesh_copy_vertices_f64", "uint32_t", [meshPointer, koffi.out(koffi.pointer("double")), "size_t", sizeOutput, obstructionOutput]),+    ml_mesh_copy_triangles_u32: library.func("ml_mesh_copy_triangles_u32", "uint32_t", [meshPointer, koffi.out(koffi.pointer("uint32_t")), "size_t", sizeOutput, obstructionOutput]),+    ml_mesh_free: library.func("ml_mesh_free", "void", [meshPointer]),+    ml_region_create_f64: library.func("ml_region_create_f64", "uint32_t", [koffi.pointer("double"), "size_t", sizeArray, "size_t", sizeArray, "size_t", regionOutput, obstructionOutput]),+    ml_region_counts: library.func("ml_region_counts", "uint32_t", [regionPointer, sizeOutput, sizeOutput, sizeOutput, obstructionOutput]),+    ml_region_copy_f64: library.func("ml_region_copy_f64", "uint32_t", [regionPointer, koffi.out(koffi.pointer("double")), "size_t", koffi.out(sizeArray), "size_t", koffi.out(sizeArray), "size_t", obstructionOutput]),+    ml_region_union: library.func("ml_region_union", "uint32_t", [regionPointer, regionPointer, regionOutput, obstructionOutput]),+    ml_region_intersection: library.func("ml_region_intersection", "uint32_t", [regionPointer, regionPointer, regionOutput, obstructionOutput]),+    ml_region_difference: library.func("ml_region_difference", "uint32_t", [regionPointer, regionPointer, regionOutput, obstructionOutput]),+    ml_region_symmetric_difference: library.func("ml_region_symmetric_difference", "uint32_t", [regionPointer, regionPointer, regionOutput, obstructionOutput]),+    ml_region_locate_point_f64: library.func("ml_region_locate_point_f64", "uint32_t", [regionPointer, "double", "double", uint32Output, obstructionOutput]),+    ml_region_measure: library.func("ml_region_measure", "uint32_t", [regionPointer, int64Output, koffi.out(koffi.pointer("char")), "size_t", sizeOutput, doubleOutput, doubleOutput, obstructionOutput]),+    ml_region_free: library.func("ml_region_free", "void", [regionPointer]),+    ml_structuring_element_create_f64: library.func("ml_structuring_element_create_f64", "uint32_t", [koffi.pointer("double"), "size_t", structuringElementOutput, obstructionOutput]),+    ml_structuring_element_free: library.func("ml_structuring_element_free", "void", [structuringElementPointer]),+    ml_region_minkowski_sum: library.func("ml_region_minkowski_sum", "uint32_t", [regionPointer, regionPointer, regionOutput, receiptOutput, obstructionOutput]),+    ml_region_offset: library.func("ml_region_offset", "uint32_t", [structuringElementPointer, regionPointer, regionOutput, receiptOutput, obstructionOutput]),+    ml_region_inset: library.func("ml_region_inset", "uint32_t", [structuringElementPointer, regionPointer, regionOutput, receiptOutput, obstructionOutput]),+    ml_region_open: library.func("ml_region_open", "uint32_t", [structuringElementPointer, regionPointer, regionOutput, receiptOutput, obstructionOutput]),+    ml_region_close: library.func("ml_region_close", "uint32_t", [structuringElementPointer, regionPointer, regionOutput, receiptOutput, obstructionOutput]),+  };+}
+ ffi/bindings/typescript/src/internal/resource.ts view
@@ -0,0 +1,113 @@+import { failure, success, type ResourceKind, type Result } from "../failure.js";+import type { OwnedResource } from "../resource.js";+import type { NativeApi, NativeHandle } from "./native.generated.js";++export interface RuntimeContext {+  readonly native: NativeApi;+  readonly identity: symbol;+}++interface FinalizerState {+  readonly free: (handle: NativeHandle) => void;+  readonly handle: NativeHandle;+}++const handleFinalizer = new FinalizationRegistry<FinalizerState>(({ free, handle }) => free(handle));+export const resourceAccess: unique symbol = Symbol("moonlight resource access");++export interface InternalResource {+  readonly [resourceAccess]: () => ResourceProjection;+}++interface OpenResource {+  readonly kind: "open";+  readonly handle: NativeHandle;+}++interface DisposedResource {+  readonly kind: "disposed";+}++type ResourceState = OpenResource | DisposedResource;++export interface ResourceProjection {+  readonly context: RuntimeContext;+  readonly resource: ResourceKind;+  readonly state: ResourceState;+}++export abstract class OwnedNativeResource implements InternalResource, OwnedResource {+  readonly #context: RuntimeContext;+  readonly #free: (handle: NativeHandle) => void;+  readonly #resource: ResourceKind;+  #state: ResourceState;++  protected constructor(+    context: RuntimeContext,+    handle: NativeHandle,+    free: (handle: NativeHandle) => void,+    resource: ResourceKind,+  ) {+    this.#context = context;+    this.#free = free;+    this.#resource = resource;+    this.#state = { kind: "open", handle };+    handleFinalizer.register(this, { free, handle }, this);+  }++  get disposed(): boolean {+    return this.#state.kind === "disposed";+  }++  dispose(): void {+    const state = this.#state;+    if (state.kind === "open") {+      handleFinalizer.unregister(this);+      this.#free(state.handle);+      this.#state = { kind: "disposed" };+    }+  }++  [Symbol.dispose](): void {+    this.dispose();+  }++  [resourceAccess](): ResourceProjection {+    return {+      context: this.#context,+      resource: this.#resource,+      state: this.#state,+    };+  }++  protected context(): RuntimeContext {+    return this.#context;+  }++  protected handle(): Result<NativeHandle> {+    return this.#state.kind === "open"+      ? success(this.#state.handle)+      : failure({ kind: "disposed-resource", resource: this.#resource });+  }+}++export function borrowResource(+  value: unknown,+  expectedContext: RuntimeContext,+  expectedResource: ResourceKind,+): Result<NativeHandle> {+  if (!isInternalResource(value)) {+    return failure({ kind: "foreign-runtime", resource: expectedResource });+  }+  const projection = value[resourceAccess]();+  if (projection.context.identity !== expectedContext.identity || projection.resource !== expectedResource) {+    return failure({ kind: "foreign-runtime", resource: expectedResource });+  }+  return projection.state.kind === "open"+    ? success(projection.state.handle)+    : failure({ kind: "disposed-resource", resource: expectedResource });+}++function isInternalResource(value: unknown): value is InternalResource {+  return typeof value === "object" && value !== null && resourceAccess in value;+}
+ ffi/bindings/typescript/src/mesh.ts view
@@ -0,0 +1,161 @@+import { success, type Result } from "./failure.js";+import { callStatus, flattenPoints, produceHandle } from "./internal/call.js";+import { pointsFromCoordinates, toSafeNumber } from "./internal/decode.js";+import type { NativeApi, NativeHandle, NativeInteger } from "./internal/native.generated.js";+import { borrowResource, OwnedNativeResource, type RuntimeContext } from "./internal/resource.js";+import type { OwnedResource } from "./resource.js";+import type { Point, Triangle } from "./values.js";++export interface Mesh extends OwnedResource {+  vertexCount(): Result<number>;+  triangleCount(): Result<number>;+  vertices(): Result<readonly Point[]>;+  triangles(): Result<readonly Triangle[]>;+  insertMany(points: readonly Point[]): Result<Mesh>;+  siteUnion(other: Mesh): Result<Mesh>;+  siteIntersection(other: Mesh): Result<Mesh>;+  siteDifference(other: Mesh): Result<Mesh>;+  siteSymmetricDifference(other: Mesh): Result<Mesh>;+}++/** @internal */+export function createMesh(context: RuntimeContext, handle: NativeHandle): Mesh {+  return new MeshResource(context, handle);+}++class MeshResource extends OwnedNativeResource implements Mesh {+  constructor(context: RuntimeContext, handle: NativeHandle) {+    super(context, handle, context.native.ml_mesh_free, "mesh");+  }++  vertexCount(): Result<number> {+    return this.count(this.context().native.ml_mesh_vertex_count);+  }++  triangleCount(): Result<number> {+    return this.count(this.context().native.ml_mesh_triangle_count);+  }++  vertices(): Result<readonly Point[]> {+    const handle = this.handle();+    if (!handle.ok) {+      return handle;+    }+    const count = this.vertexCount();+    if (!count.ok) {+      return count;+    }+    const coordinates = new Float64Array(count.value * 2);+    const written: NativeInteger[] = [0];+    const copied = callStatus((obstruction) =>+      this.context().native.ml_mesh_copy_vertices_f64(+        handle.value,+        coordinates,+        count.value,+        written,+        obstruction,+      ),+    );+    if (!copied.ok) {+      return copied;+    }+    const writtenCount = toSafeNumber(written[0]);+    return writtenCount.ok+      ? success(pointsFromCoordinates(coordinates, writtenCount.value))+      : writtenCount;+  }++  triangles(): Result<readonly Triangle[]> {+    const handle = this.handle();+    if (!handle.ok) {+      return handle;+    }+    const count = this.triangleCount();+    if (!count.ok) {+      return count;+    }+    const triangles = new Uint32Array(count.value * 3);+    const written: NativeInteger[] = [0];+    const copied = callStatus((obstruction) =>+      this.context().native.ml_mesh_copy_triangles_u32(+        handle.value,+        triangles,+        count.value,+        written,+        obstruction,+      ),+    );+    if (!copied.ok) {+      return copied;+    }+    const writtenCount = toSafeNumber(written[0]);+    return writtenCount.ok+      ? success(+          Array.from({ length: writtenCount.value }, (_unused, index): Triangle => [+            triangles[index * 3] ?? 0,+            triangles[index * 3 + 1] ?? 0,+            triangles[index * 3 + 2] ?? 0,+          ]),+        )+      : writtenCount;+  }++  insertMany(points: readonly Point[]): Result<Mesh> {+    const handle = this.handle();+    if (!handle.ok) {+      return handle;+    }+    const coordinates = flattenPoints(points);+    const produced = produceHandle((output, obstruction) =>+      this.context().native.ml_mesh_insert_many_f64(+        handle.value,+        coordinates,+        coordinates.length / 2,+        output,+        obstruction,+      ),+    );+    return produced.ok ? success(createMesh(this.context(), produced.value)) : produced;+  }++  siteUnion(other: Mesh): Result<Mesh> {+    return this.binary(other, this.context().native.ml_mesh_site_union);+  }++  siteIntersection(other: Mesh): Result<Mesh> {+    return this.binary(other, this.context().native.ml_mesh_site_intersection);+  }++  siteDifference(other: Mesh): Result<Mesh> {+    return this.binary(other, this.context().native.ml_mesh_site_difference);+  }++  siteSymmetricDifference(other: Mesh): Result<Mesh> {+    return this.binary(other, this.context().native.ml_mesh_site_symmetric_difference);+  }++  private binary(other: Mesh, operation: NativeApi["ml_mesh_site_union"]): Result<Mesh> {+    const left = this.handle();+    if (!left.ok) {+      return left;+    }+    const right = borrowResource(other, this.context(), "mesh");+    if (!right.ok) {+      return right;+    }+    const produced = produceHandle((output, obstruction) =>+      operation(left.value, right.value, output, obstruction),+    );+    return produced.ok ? success(createMesh(this.context(), produced.value)) : produced;+  }++  private count(operation: NativeApi["ml_mesh_vertex_count"]): Result<number> {+    const handle = this.handle();+    if (!handle.ok) {+      return handle;+    }+    const output: NativeInteger[] = [0];+    const counted = callStatus((obstruction) => operation(handle.value, output, obstruction));+    return counted.ok ? toSafeNumber(output[0]) : counted;+  }+}
+ ffi/bindings/typescript/src/moonlight.ts view
@@ -0,0 +1,120 @@+import { failure, success, type Result } from "./failure.js";+import { flattenLoops, flattenPoints, produceHandle } from "./internal/call.js";+import {+  ABI_VERSION,+  ML_STATUS_OK,+  loadNativeApi,+} from "./internal/native.generated.js";+import type { RuntimeContext } from "./internal/resource.js";+import { createMesh, type Mesh } from "./mesh.js";+import { createStructuringElement, type StructuringElement } from "./morphology.js";+import { createRegion, type Region } from "./region.js";+import type { Point, PolygonComponent } from "./values.js";+import { decodeAbiStatus } from "./wire.generated.js";++export type NativeLibrarySource = {+  readonly kind: "path";+  readonly path: string;+};++export interface Moonlight {+  readonly abiVersion: number;+  delaunay(points: readonly Point[]): Result<Mesh>;+  region(components: readonly PolygonComponent[]): Result<Region>;+  structuringElement(points: readonly Point[]): Result<StructuringElement>;+}++export function loadMoonlight(source: NativeLibrarySource): Result<Moonlight> {+  if (source.path.length === 0) {+    return failure({+      kind: "native-library-unavailable",+      path: source.path,+      message: "native library path must not be empty",+    });+  }+  try {+    const native = loadNativeApi(source.path);+    const initializationStatus = native.ml_runtime_initialize();+    if (initializationStatus !== ML_STATUS_OK) {+      const status = decodeAbiStatus(initializationStatus);+      return status === undefined+        ? failure({ kind: "unknown-wire-value", vocabulary: "status", value: initializationStatus })+        : failure({ kind: "runtime-initialization-refused", status });+    }+    const observedVersion = native.ml_abi_version();+    if (observedVersion !== ABI_VERSION) {+      return failure({+        kind: "abi-version-mismatch",+        expected: ABI_VERSION,+        observed: observedVersion,+      });+    }+    const context: RuntimeContext = { native, identity: Symbol("moonlight runtime") };+    return success(new MoonlightRuntime(context));+  } catch (cause: unknown) {+    return failure({+      kind: "native-library-unavailable",+      path: source.path,+      message: cause instanceof Error ? cause.message : String(cause),+    });+  }+}++class MoonlightRuntime implements Moonlight {+  readonly abiVersion = ABI_VERSION;+  readonly #context: RuntimeContext;++  constructor(context: RuntimeContext) {+    this.#context = context;+  }++  delaunay(points: readonly Point[]): Result<Mesh> {+    const coordinates = flattenPoints(points);+    const produced = produceHandle((output, obstruction) =>+      this.#context.native.ml_delaunay_f64(+        coordinates,+        coordinates.length / 2,+        output,+        obstruction,+      ),+    );+    return produced.ok ? success(createMesh(this.#context, produced.value)) : produced;+  }++  region(components: readonly PolygonComponent[]): Result<Region> {+    const loops = components.flatMap(({ outer, holes = [] }) => [outer, ...holes]);+    const loopPointCounts = BigUint64Array.from(loops.map((loop) => BigInt(loop.length)));+    const componentLoopCounts = BigUint64Array.from(+      components.map(({ holes = [] }) => BigInt(holes.length + 1)),+    );+    const coordinates = flattenLoops(loops);+    const produced = produceHandle((output, obstruction) =>+      this.#context.native.ml_region_create_f64(+        coordinates,+        coordinates.length / 2,+        loopPointCounts,+        loopPointCounts.length,+        componentLoopCounts,+        componentLoopCounts.length,+        output,+        obstruction,+      ),+    );+    return produced.ok ? success(createRegion(this.#context, produced.value)) : produced;+  }++  structuringElement(points: readonly Point[]): Result<StructuringElement> {+    const coordinates = flattenPoints(points);+    const produced = produceHandle((output, obstruction) =>+      this.#context.native.ml_structuring_element_create_f64(+        coordinates,+        coordinates.length / 2,+        output,+        obstruction,+      ),+    );+    return produced.ok+      ? success(createStructuringElement(this.#context, produced.value))+      : produced;+  }+}
+ ffi/bindings/typescript/src/morphology.ts view
@@ -0,0 +1,25 @@+import type { NativeHandle } from "./internal/native.generated.js";+import { OwnedNativeResource, type RuntimeContext } from "./internal/resource.js";+import type { OwnedResource } from "./resource.js";++declare const structuringElementBrand: unique symbol;++export interface StructuringElement extends OwnedResource {+  readonly [structuringElementBrand]: "structuring-element";+}++/** @internal */+export function createStructuringElement(+  context: RuntimeContext,+  handle: NativeHandle,+): StructuringElement {+  return new StructuringElementResource(context, handle);+}++class StructuringElementResource extends OwnedNativeResource implements StructuringElement {+  declare readonly [structuringElementBrand]: "structuring-element";++  constructor(context: RuntimeContext, handle: NativeHandle) {+    super(context, handle, context.native.ml_structuring_element_free, "structuring-element");+  }+}
+ ffi/bindings/typescript/src/region.ts view
@@ -0,0 +1,281 @@+import { Buffer } from "node:buffer";++import { collectResults, failure, success, type Result } from "./failure.js";+import { captureNativeCall, callStatus, produceHandle, produceMorphology } from "./internal/call.js";+import { decodeLocation, decodeStatus, pointsFromCoordinates, toBigInt, toSafeNumber } from "./internal/decode.js";+import {+  ML_OBSTRUCTION_BUFFER_TOO_SMALL,+  ML_STATUS_BUFFER_TOO_SMALL,+  type NativeApi,+  type NativeHandle,+  type NativeInteger,+  type NativeObstruction,+} from "./internal/native.generated.js";+import { borrowResource, OwnedNativeResource, type RuntimeContext } from "./internal/resource.js";+import type { StructuringElement } from "./morphology.js";+import type { OwnedResource } from "./resource.js";+import type { MinkowskiReceipt, Point, PolygonComponent, RegionValuations } from "./values.js";+import type { RegionLocation } from "./wire.generated.js";++export interface MorphologyResult {+  readonly region: Region;+  readonly receipt: MinkowskiReceipt;+}++export interface Region extends OwnedResource {+  components(): Result<readonly PolygonComponent[]>;+  valuations(): Result<RegionValuations>;+  locate(point: Point): Result<RegionLocation>;+  union(other: Region): Result<Region>;+  intersection(other: Region): Result<Region>;+  difference(other: Region): Result<Region>;+  symmetricDifference(other: Region): Result<Region>;+  minkowskiSum(other: Region): Result<MorphologyResult>;+  offset(element: StructuringElement): Result<MorphologyResult>;+  inset(element: StructuringElement): Result<MorphologyResult>;+  open(element: StructuringElement): Result<MorphologyResult>;+  close(element: StructuringElement): Result<MorphologyResult>;+}++/** @internal */+export function createRegion(context: RuntimeContext, handle: NativeHandle): Region {+  return new RegionResource(context, handle);+}++class RegionResource extends OwnedNativeResource implements Region {+  constructor(context: RuntimeContext, handle: NativeHandle) {+    super(context, handle, context.native.ml_region_free, "region");+  }++  components(): Result<readonly PolygonComponent[]> {+    const handle = this.handle();+    if (!handle.ok) {+      return handle;+    }+    const counts = this.counts(handle.value);+    if (!counts.ok) {+      return counts;+    }+    const [componentCount, loopCount, pointCount] = counts.value;+    const coordinates = new Float64Array(pointCount * 2);+    const loopPointOffsets = new BigUint64Array(loopCount + 1);+    const componentLoopOffsets = new BigUint64Array(componentCount + 1);+    const copied = callStatus((obstruction) =>+      this.context().native.ml_region_copy_f64(+        handle.value,+        coordinates,+        pointCount,+        loopPointOffsets,+        loopCount + 1,+        componentLoopOffsets,+        componentCount + 1,+        obstruction,+      ),+    );+    if (!copied.ok) {+      return copied;+    }+    const points = pointsFromCoordinates(coordinates, pointCount);+    const loopOffsets = collectResults(+      Array.from({ length: loopCount + 1 }, (_unused, index) => toSafeNumber(loopPointOffsets[index])),+    );+    if (!loopOffsets.ok) {+      return loopOffsets;+    }+    const componentOffsets = collectResults(+      Array.from({ length: componentCount + 1 }, (_unused, index) => toSafeNumber(componentLoopOffsets[index])),+    );+    if (!componentOffsets.ok) {+      return componentOffsets;+    }+    const loops = Array.from({ length: loopCount }, (_unused, index) =>+      points.slice(loopOffsets.value[index] ?? 0, loopOffsets.value[index + 1] ?? 0),+    );+    return collectResults(+      Array.from({ length: componentCount }, (_unused, index): Result<PolygonComponent> => {+        const start = componentOffsets.value[index] ?? 0;+        const end = componentOffsets.value[index + 1] ?? 0;+        const outer = loops[start];+        return outer === undefined || start >= end+          ? failure({ kind: "invalid-native-result", message: "Moonlight returned a component without an outer loop" })+          : success({ outer, holes: loops.slice(start + 1, end) });+      }),+    );+  }++  valuations(): Result<RegionValuations> {+    const handle = this.handle();+    return handle.ok ? this.measureWithCapacity(handle.value, 128) : handle;+  }++  locate([x, y]: Point): Result<RegionLocation> {+    const handle = this.handle();+    if (!handle.ok) {+      return handle;+    }+    const location = [0];+    const located = callStatus((obstruction) =>+      this.context().native.ml_region_locate_point_f64(handle.value, x, y, location, obstruction),+    );+    return located.ok ? decodeLocation(location[0]) : located;+  }++  union(other: Region): Result<Region> {+    return this.binary(other, this.context().native.ml_region_union);+  }++  intersection(other: Region): Result<Region> {+    return this.binary(other, this.context().native.ml_region_intersection);+  }++  difference(other: Region): Result<Region> {+    return this.binary(other, this.context().native.ml_region_difference);+  }++  symmetricDifference(other: Region): Result<Region> {+    return this.binary(other, this.context().native.ml_region_symmetric_difference);+  }++  minkowskiSum(other: Region): Result<MorphologyResult> {+    const left = this.handle();+    if (!left.ok) {+      return left;+    }+    const right = borrowResource(other, this.context(), "region");+    return right.ok+      ? this.morphology(this.context().native.ml_region_minkowski_sum, left.value, right.value)+      : right;+  }++  offset(element: StructuringElement): Result<MorphologyResult> {+    return this.withElement(element, this.context().native.ml_region_offset);+  }++  inset(element: StructuringElement): Result<MorphologyResult> {+    return this.withElement(element, this.context().native.ml_region_inset);+  }++  open(element: StructuringElement): Result<MorphologyResult> {+    return this.withElement(element, this.context().native.ml_region_open);+  }++  close(element: StructuringElement): Result<MorphologyResult> {+    return this.withElement(element, this.context().native.ml_region_close);+  }++  private binary(other: Region, operation: NativeApi["ml_region_union"]): Result<Region> {+    const left = this.handle();+    if (!left.ok) {+      return left;+    }+    const right = borrowResource(other, this.context(), "region");+    if (!right.ok) {+      return right;+    }+    const produced = produceHandle((output, obstruction) =>+      operation(left.value, right.value, output, obstruction),+    );+    return produced.ok ? success(createRegion(this.context(), produced.value)) : produced;+  }++  private withElement(+    element: StructuringElement,+    operation: NativeApi["ml_region_offset"],+  ): Result<MorphologyResult> {+    const region = this.handle();+    if (!region.ok) {+      return region;+    }+    const structuringElement = borrowResource(element, this.context(), "structuring-element");+    return structuringElement.ok+      ? this.morphology(operation, structuringElement.value, region.value)+      : structuringElement;+  }++  private morphology(+    operation: NativeApi["ml_region_minkowski_sum"],+    first: NativeHandle,+    second: NativeHandle,+  ): Result<MorphologyResult> {+    const produced = produceMorphology((output, receipt, obstruction) =>+      operation(first, second, output, receipt, obstruction),+    );+    return produced.ok+      ? success({ region: createRegion(this.context(), produced.value.handle), receipt: produced.value.receipt })+      : produced;+  }++  private counts(handle: NativeHandle): Result<readonly [number, number, number]> {+    const componentCount: NativeInteger[] = [0];+    const loopCount: NativeInteger[] = [0];+    const pointCount: NativeInteger[] = [0];+    const counted = callStatus((obstruction) =>+      this.context().native.ml_region_counts(+        handle,+        componentCount,+        loopCount,+        pointCount,+        obstruction,+      ),+    );+    if (!counted.ok) {+      return counted;+    }+    const components = toSafeNumber(componentCount[0]);+    const loops = toSafeNumber(loopCount[0]);+    const points = toSafeNumber(pointCount[0]);+    if (!components.ok) {+      return failure(components.error);+    }+    if (!loops.ok) {+      return failure(loops.error);+    }+    if (!points.ok) {+      return failure(points.error);+    }+    return success([components.value, loops.value, points.value]);+  }++  private measureWithCapacity(handle: NativeHandle, capacity: number): Result<RegionValuations> {+    return captureNativeCall(() => {+      const euler: NativeInteger[] = [0];+      const areaRatio = Buffer.alloc(capacity);+      const areaBytes: NativeInteger[] = [0];+      const perimeterLower = [0];+      const perimeterUpper = [0];+      const obstruction: NativeObstruction = {};+      const status = this.context().native.ml_region_measure(+        handle,+        euler,+        areaRatio,+        capacity,+        areaBytes,+        perimeterLower,+        perimeterUpper,+        obstruction,+      );+      if (status === ML_STATUS_BUFFER_TOO_SMALL && obstruction.code === ML_OBSTRUCTION_BUFFER_TOO_SMALL) {+        const required = toSafeNumber(areaBytes[0]);+        return required.ok ? this.measureWithCapacity(handle, required.value + 1) : required;+      }+      const measured = decodeStatus(status, obstruction);+      if (!measured.ok) {+        return measured;+      }+      const byteCount = toSafeNumber(areaBytes[0]);+      if (!byteCount.ok) {+        return byteCount;+      }+      const ratio = areaRatio.subarray(0, byteCount.value).toString("ascii");+      const [numerator, denominator, remainder] = ratio.split("/");+      if (numerator === undefined || denominator === undefined || remainder !== undefined) {+        return failure({ kind: "invalid-native-result", message: "Moonlight returned a malformed exact-area ratio" });+      }+      return success({+        eulerCharacteristic: toBigInt(euler[0]),+        area: { numerator: BigInt(numerator), denominator: BigInt(denominator) },+        perimeterBounds: [perimeterLower[0] ?? 0, perimeterUpper[0] ?? 0],+      });+    });+  }+}
+ ffi/bindings/typescript/src/resource.ts view
@@ -0,0 +1,4 @@+export interface OwnedResource extends Disposable {+  readonly disposed: boolean;+  dispose(): void;+}
+ ffi/bindings/typescript/src/values.ts view
@@ -0,0 +1,32 @@+import type { MinkowskiOperation } from "./wire.generated.js";++export type Point = readonly [x: number, y: number];+export type Triangle = readonly [first: number, second: number, third: number];++export interface PolygonComponent {+  readonly outer: readonly Point[];+  readonly holes?: readonly (readonly Point[])[];+}++export interface ExactRational {+  readonly numerator: bigint;+  readonly denominator: bigint;+}++export interface RegionValuations {+  readonly eulerCharacteristic: bigint;+  readonly area: ExactRational;+  readonly perimeterBounds: readonly [lower: number, upper: number];+}++export interface MinkowskiReceipt {+  readonly operation: MinkowskiOperation;+  readonly inputComponents: bigint;+  readonly convexPieces: bigint;+  readonly generatedPieces: bigint;+  readonly generatedConvolutionEdges: bigint;+  readonly overlayPasses: bigint;+  readonly exactCrossings: bigint;+  readonly outputCells: bigint;+  readonly exactCoordinateBitGrowth: bigint;+}
+ ffi/bindings/typescript/src/wire.generated.ts view
@@ -0,0 +1,239 @@+// Generated from Moonlight.Triangulation.Foreign.Contract.+// Run moonlight-triangulation-ffi-contract write; do not edit this file.++export const AbiStatus = {+  Ok: "ok",+  NullPointer: "null-pointer",+  CountOverflow: "count-overflow",+  BufferTooSmall: "buffer-too-small",+  GeometryObstruction: "geometry-obstruction",+  RuntimeFailure: "runtime-failure",+} as const;+export type AbiStatus = (typeof AbiStatus)[keyof typeof AbiStatus];+const abiStatusByWire: Readonly<Record<number, AbiStatus>> = {+  0: AbiStatus.Ok,+  1: AbiStatus.NullPointer,+  2: AbiStatus.CountOverflow,+  3: AbiStatus.BufferTooSmall,+  4: AbiStatus.GeometryObstruction,+  5: AbiStatus.RuntimeFailure,+};+export function decodeAbiStatus(value: number): AbiStatus | undefined {+  return abiStatusByWire[value];+}++export const ObstructionCode = {+  None: "none",+  InvalidCoordinate: "invalid-coordinate",+  PointLocationFailed: "point-location-failed",+  LocationWalkExhausted: "location-walk-exhausted",+  RefinementInputTopologyInvalid: "refinement-input-topology-invalid",+  FreshInsertionMatchedExistingVertex: "fresh-insertion-matched-existing-vertex",+  DegenerateLineEndpointMissingOutgoing: "degenerate-line-endpoint-missing-outgoing",+  DegenerateLineEndpointTurnMissing: "degenerate-line-endpoint-turn-missing",+  DegenerateLineConnectedVertexMissing: "degenerate-line-connected-vertex-missing",+  HullStartNotVisible: "hull-start-not-visible",+  OuterRangeDidNotTerminate: "outer-range-did-not-terminate",+  OuterRangeContainsInnerEdge: "outer-range-contains-inner-edge",+  ConstrainedEdgeFlipRefused: "constrained-edge-flip-refused",+  RemovalVertexOutOfRange: "removal-vertex-out-of-range",+  RemovalEdgeOutOfRange: "removal-edge-out-of-range",+  RemovalFaceOutOfRange: "removal-face-out-of-range",+  RemovalFaceCycleDidNotTerminate: "removal-face-cycle-did-not-terminate",+  RemovalEmptyTriangulation: "removal-empty-triangulation",+  RemovalTwoPointDegreeMismatch: "removal-two-point-degree-mismatch",+  RemovalCollinearDegreeMismatch: "removal-collinear-degree-mismatch",+  RemovalBorderTooShort: "removal-border-too-short",+  RemovalBorderArityMismatch: "removal-border-arity-mismatch",+  RemovalOutgoingCycleDidNotTerminate: "removal-outgoing-cycle-did-not-terminate",+  CircleSweepHullEmpty: "circle-sweep-hull-empty",+  OuterCycleDidNotTerminate: "outer-cycle-did-not-terminate",+  HierarchyLevelPopulationMismatch: "hierarchy-level-population-mismatch",+  HierarchyInsertionHandleMismatch: "hierarchy-insertion-handle-mismatch",+  PointIndexCapacityExhausted: "point-index-capacity-exhausted",+  RefinementMinimumAngleNotFinite: "refinement-minimum-angle-not-finite",+  RefinementMinimumAngleOutOfRange: "refinement-minimum-angle-out-of-range",+  RefinementMinimumAngleDerivedRatioNotFinite: "refinement-minimum-angle-derived-ratio-not-finite",+  RefinementMaximumAdditionalVerticesNegative: "refinement-maximum-additional-vertices-negative",+  RefinementMinimumAreaNotFinite: "refinement-minimum-area-not-finite",+  RefinementMinimumAreaNegative: "refinement-minimum-area-negative",+  RefinementMaximumAreaNotFinite: "refinement-maximum-area-not-finite",+  RefinementMaximumAreaNotPositive: "refinement-maximum-area-not-positive",+  RefinementMaximumRadiusEdgeRatioNotFinite: "refinement-maximum-radius-edge-ratio-not-finite",+  RefinementMaximumRadiusEdgeRatioNotPositive: "refinement-maximum-radius-edge-ratio-not-positive",+  RefinementMinimumAreaExceedsMaximum: "refinement-minimum-area-exceeds-maximum",+  RefinementSeedFaceNotActive: "refinement-seed-face-not-active",+  RefinementDomainInterfaceEdgeNotActive: "refinement-domain-interface-edge-not-active",+  RefinementDomainInterfaceMissing: "refinement-domain-interface-missing",+  RefinementDomainInterfaceExtraneous: "refinement-domain-interface-extraneous",+  RefinementDomainTopologyChanged: "refinement-domain-topology-changed",+  RefinementDomainRequiresConvexHullPreservation: "refinement-domain-requires-convex-hull-preservation",+  RefinementDomainRequiresConstraintPreservation: "refinement-domain-requires-constraint-preservation",+  RefinementDomainForbidsOuterFaceExclusion: "refinement-domain-forbids-outer-face-exclusion",+  RefinementDomainWouldCrossInterface: "refinement-domain-would-cross-interface",+  RefinementDomainWouldRewriteProtectedFace: "refinement-domain-would-rewrite-protected-face",+  RefinementDomainProtectedFaceChanged: "refinement-domain-protected-face-changed",+  CapacityExceeded: "capacity-exceeded",+  HalfEdgeCapacityExceeded: "half-edge-capacity-exceeded",+  FaceCapacityExceeded: "face-capacity-exceeded",+  PayloadStorageFailure: "payload-storage-failure",+  CoordinatePayloadCountMismatch: "coordinate-payload-count-mismatch",+  CircleSweepRequiresDenseStorage: "circle-sweep-requires-dense-storage",+  SeamFrontierUnavailable: "seam-frontier-unavailable",+  RefinementDomainRequiresFiniteVertexBudget: "refinement-domain-requires-finite-vertex-budget",+  SeamSourceEdgeRequiresFlip: "seam-source-edge-requires-flip",+  SeamProtectedSourceFaceChanged: "seam-protected-source-face-changed",+  RefinementMaximumEdgeLengthNotFinite: "refinement-maximum-edge-length-not-finite",+  RefinementMaximumEdgeLengthNotPositive: "refinement-maximum-edge-length-not-positive",+  RefinementOversizedEdge: "refinement-oversized-edge",+  RefinementSeamBridgeBudgetExceeded: "refinement-seam-bridge-budget-exceeded",+  RefinementSeamBridgeMidpointCollapsed: "refinement-seam-bridge-midpoint-collapsed",+  BoundarySplitRequiresBoundaryEdge: "boundary-split-requires-boundary-edge",+  RefinementDomainInterfaceOppositeFaceNotPermitted: "refinement-domain-interface-opposite-face-not-permitted",+  NullPointer: "null-pointer",+  CountOverflow: "count-overflow",+  BufferTooSmall: "buffer-too-small",+  RuntimeFailure: "runtime-failure",+  RegionLayoutInvalid: "region-layout-invalid",+  RegionValidationFailed: "region-validation-failed",+  OverlayFailed: "overlay-failed",+  RegionPublicationFailed: "region-publication-failed",+  ValuationFailed: "valuation-failed",+  MinkowskiFailed: "minkowski-failed",+  RegionProjectionFailed: "region-projection-failed",+} as const;+export type ObstructionCode = (typeof ObstructionCode)[keyof typeof ObstructionCode];+const obstructionCodeByWire: Readonly<Record<number, ObstructionCode>> = {+  0: ObstructionCode.None,+  1: ObstructionCode.InvalidCoordinate,+  2: ObstructionCode.PointLocationFailed,+  3: ObstructionCode.LocationWalkExhausted,+  4: ObstructionCode.RefinementInputTopologyInvalid,+  5: ObstructionCode.FreshInsertionMatchedExistingVertex,+  6: ObstructionCode.DegenerateLineEndpointMissingOutgoing,+  7: ObstructionCode.DegenerateLineEndpointTurnMissing,+  8: ObstructionCode.DegenerateLineConnectedVertexMissing,+  9: ObstructionCode.HullStartNotVisible,+  10: ObstructionCode.OuterRangeDidNotTerminate,+  11: ObstructionCode.OuterRangeContainsInnerEdge,+  12: ObstructionCode.ConstrainedEdgeFlipRefused,+  13: ObstructionCode.RemovalVertexOutOfRange,+  14: ObstructionCode.RemovalEdgeOutOfRange,+  15: ObstructionCode.RemovalFaceOutOfRange,+  16: ObstructionCode.RemovalFaceCycleDidNotTerminate,+  17: ObstructionCode.RemovalEmptyTriangulation,+  18: ObstructionCode.RemovalTwoPointDegreeMismatch,+  19: ObstructionCode.RemovalCollinearDegreeMismatch,+  20: ObstructionCode.RemovalBorderTooShort,+  21: ObstructionCode.RemovalBorderArityMismatch,+  22: ObstructionCode.RemovalOutgoingCycleDidNotTerminate,+  23: ObstructionCode.CircleSweepHullEmpty,+  24: ObstructionCode.OuterCycleDidNotTerminate,+  25: ObstructionCode.HierarchyLevelPopulationMismatch,+  26: ObstructionCode.HierarchyInsertionHandleMismatch,+  27: ObstructionCode.PointIndexCapacityExhausted,+  28: ObstructionCode.RefinementMinimumAngleNotFinite,+  29: ObstructionCode.RefinementMinimumAngleOutOfRange,+  30: ObstructionCode.RefinementMinimumAngleDerivedRatioNotFinite,+  31: ObstructionCode.RefinementMaximumAdditionalVerticesNegative,+  32: ObstructionCode.RefinementMinimumAreaNotFinite,+  33: ObstructionCode.RefinementMinimumAreaNegative,+  34: ObstructionCode.RefinementMaximumAreaNotFinite,+  35: ObstructionCode.RefinementMaximumAreaNotPositive,+  36: ObstructionCode.RefinementMaximumRadiusEdgeRatioNotFinite,+  37: ObstructionCode.RefinementMaximumRadiusEdgeRatioNotPositive,+  38: ObstructionCode.RefinementMinimumAreaExceedsMaximum,+  39: ObstructionCode.RefinementSeedFaceNotActive,+  40: ObstructionCode.RefinementDomainInterfaceEdgeNotActive,+  41: ObstructionCode.RefinementDomainInterfaceMissing,+  42: ObstructionCode.RefinementDomainInterfaceExtraneous,+  43: ObstructionCode.RefinementDomainTopologyChanged,+  44: ObstructionCode.RefinementDomainRequiresConvexHullPreservation,+  45: ObstructionCode.RefinementDomainRequiresConstraintPreservation,+  46: ObstructionCode.RefinementDomainForbidsOuterFaceExclusion,+  47: ObstructionCode.RefinementDomainWouldCrossInterface,+  48: ObstructionCode.RefinementDomainWouldRewriteProtectedFace,+  49: ObstructionCode.RefinementDomainProtectedFaceChanged,+  50: ObstructionCode.CapacityExceeded,+  51: ObstructionCode.HalfEdgeCapacityExceeded,+  52: ObstructionCode.FaceCapacityExceeded,+  53: ObstructionCode.PayloadStorageFailure,+  54: ObstructionCode.CoordinatePayloadCountMismatch,+  55: ObstructionCode.CircleSweepRequiresDenseStorage,+  56: ObstructionCode.SeamFrontierUnavailable,+  57: ObstructionCode.RefinementDomainRequiresFiniteVertexBudget,+  58: ObstructionCode.SeamSourceEdgeRequiresFlip,+  59: ObstructionCode.SeamProtectedSourceFaceChanged,+  60: ObstructionCode.RefinementMaximumEdgeLengthNotFinite,+  61: ObstructionCode.RefinementMaximumEdgeLengthNotPositive,+  62: ObstructionCode.RefinementOversizedEdge,+  63: ObstructionCode.RefinementSeamBridgeBudgetExceeded,+  64: ObstructionCode.RefinementSeamBridgeMidpointCollapsed,+  65: ObstructionCode.BoundarySplitRequiresBoundaryEdge,+  66: ObstructionCode.RefinementDomainInterfaceOppositeFaceNotPermitted,+  100: ObstructionCode.NullPointer,+  101: ObstructionCode.CountOverflow,+  102: ObstructionCode.BufferTooSmall,+  103: ObstructionCode.RuntimeFailure,+  200: ObstructionCode.RegionLayoutInvalid,+  201: ObstructionCode.RegionValidationFailed,+  202: ObstructionCode.OverlayFailed,+  203: ObstructionCode.RegionPublicationFailed,+  204: ObstructionCode.ValuationFailed,+  205: ObstructionCode.MinkowskiFailed,+  206: ObstructionCode.RegionProjectionFailed,+};+export function decodeObstructionCode(value: number): ObstructionCode | undefined {+  return obstructionCodeByWire[value];+}++export const CoordinateError = {+  None: "none",+  Nan: "nan",+  Infinite: "infinite",+  TooSmall: "too-small",+  TooLarge: "too-large",+} as const;+export type CoordinateError = (typeof CoordinateError)[keyof typeof CoordinateError];+const coordinateErrorByWire: Readonly<Record<number, CoordinateError>> = {+  0: CoordinateError.None,+  1: CoordinateError.Nan,+  2: CoordinateError.Infinite,+  3: CoordinateError.TooSmall,+  4: CoordinateError.TooLarge,+};+export function decodeCoordinateError(value: number): CoordinateError | undefined {+  return coordinateErrorByWire[value];+}++export const RegionLocation = {+  Exterior: "exterior",+  Boundary: "boundary",+  Interior: "interior",+} as const;+export type RegionLocation = (typeof RegionLocation)[keyof typeof RegionLocation];+const regionLocationByWire: Readonly<Record<number, RegionLocation>> = {+  0: RegionLocation.Exterior,+  1: RegionLocation.Boundary,+  2: RegionLocation.Interior,+};+export function decodeRegionLocation(value: number): RegionLocation | undefined {+  return regionLocationByWire[value];+}++export const MinkowskiOperation = {+  Addition: "addition",+  Erosion: "erosion",+  Opening: "opening",+  Closing: "closing",+} as const;+export type MinkowskiOperation = (typeof MinkowskiOperation)[keyof typeof MinkowskiOperation];+const minkowskiOperationByWire: Readonly<Record<number, MinkowskiOperation>> = {+  0: MinkowskiOperation.Addition,+  1: MinkowskiOperation.Erosion,+  2: MinkowskiOperation.Opening,+  3: MinkowskiOperation.Closing,+};+export function decodeMinkowskiOperation(value: number): MinkowskiOperation | undefined {+  return minkowskiOperationByWire[value];+}
+ ffi/bindings/typescript/test/binding.test.ts view
@@ -0,0 +1,136 @@+import assert from "node:assert/strict";+import test from "node:test";++import {+  AbiStatus,+  CoordinateError,+  MinkowskiOperation,+  ObstructionCode,+  RegionLocation,+  formatMoonlightFailure,+  loadMoonlight,+  type Moonlight,+  type Result,+} from "../src/index.js";++function expectSuccess<Value>(result: Result<Value>): Value {+  if (!result.ok) {+    assert.fail(formatMoonlightFailure(result.error));+  }+  return result.value;+}++function libraryPath(): string {+  const path = process.env.MOONLIGHT_TRIANGULATION_LIBRARY;+  assert.notEqual(path, undefined, "MOONLIGHT_TRIANGULATION_LIBRARY is required");+  return path ?? "";+}++function runtime(): Moonlight {+  return expectSuccess(loadMoonlight({ kind: "path", path: libraryPath() }));+}++test("immutable site-set algebra and dense projection", () => {+  const engine = runtime();+  using left = expectSuccess(engine.delaunay([[0, 0], [2, 0], [0, 2], [2, 2]]));+  using right = expectSuccess(engine.delaunay([[2, 0], [4, 0], [2, 2], [4, 2]]));+  using union = expectSuccess(left.siteUnion(right));+  using intersection = expectSuccess(left.siteIntersection(right));+  using difference = expectSuccess(left.siteDifference(right));+  using symmetric = expectSuccess(left.siteSymmetricDifference(right));+  using extended = expectSuccess(left.insertMany([[1, 1], [3, 1]]));++  assert.equal(expectSuccess(left.vertexCount()), 4);+  assert.equal(expectSuccess(union.vertexCount()), 6);+  assert.equal(expectSuccess(intersection.vertexCount()), 2);+  assert.equal(expectSuccess(difference.vertexCount()), 2);+  assert.equal(expectSuccess(symmetric.vertexCount()), 4);+  assert.equal(expectSuccess(extended.vertexCount()), 6);+  assert.equal(expectSuccess(left.vertices()).length, expectSuccess(left.vertexCount()));+  assert.equal(expectSuccess(left.triangles()).length, expectSuccess(left.triangleCount()));++});++test("exact regions expose Boolean, valuation, location, and all morphology operations", () => {+  const engine = runtime();+  using left = expectSuccess(engine.region([{ outer: [[0, 0], [2, 0], [2, 2], [0, 2]] }]));+  using right = expectSuccess(engine.region([{ outer: [[1, 0], [3, 0], [3, 2], [1, 2]] }]));+  using intersection = expectSuccess(left.intersection(right));+  using symmetric = expectSuccess(left.symmetricDifference(right));+  using kernel = expectSuccess(+    engine.structuringElement([[-0.25, -0.25], [0.25, -0.25], [0.25, 0.25], [-0.25, 0.25]]),+  );+  const sum = expectSuccess(left.minkowskiSum(right));+  const offset = expectSuccess(left.offset(kernel));+  const inset = expectSuccess(left.inset(kernel));+  const opened = expectSuccess(left.open(kernel));+  const closed = expectSuccess(left.close(kernel));+  using sumRegion = sum.region;+  using offsetRegion = offset.region;+  using insetRegion = inset.region;+  using openedRegion = opened.region;+  using closedRegion = closed.region;++  assert.equal(expectSuccess(left.components()).length, 1);+  assert.equal(expectSuccess(left.components())[0]?.outer.length, 4);+  assert.deepEqual(expectSuccess(intersection.valuations()).area, { numerator: 2n, denominator: 1n });+  assert.equal(expectSuccess(symmetric.valuations()).eulerCharacteristic, 2n);+  assert.equal(expectSuccess(left.locate([1, 1])), RegionLocation.Interior);+  assert.equal(expectSuccess(left.locate([0, 1])), RegionLocation.Boundary);+  assert.equal(expectSuccess(left.locate([3, 1])), RegionLocation.Exterior);+  assert.equal(offset.receipt.operation, MinkowskiOperation.Addition);+  assert.equal(inset.receipt.operation, MinkowskiOperation.Erosion);+  assert.equal(opened.receipt.operation, MinkowskiOperation.Opening);+  assert.equal(closed.receipt.operation, MinkowskiOperation.Closing);+  assert(sum.receipt.generatedPieces >= 1n);++});++test("invalid coordinates return a typed obstruction", () => {+  const result = runtime().delaunay([[0, 0], [Number.NaN, 1], [1, 0]]);+  assert.equal(result.ok, false);+  if (result.ok || result.error.kind !== "abi-obstruction") {+    throw new Error("expected an ABI obstruction");+  }+  assert.equal(result.error.obstruction.status, AbiStatus.GeometryObstruction);+  assert.equal(result.error.obstruction.code, ObstructionCode.InvalidCoordinate);+  assert.equal(result.error.obstruction.coordinateError, CoordinateError.Nan);+  assert.equal(result.error.obstruction.inputIndex, 1n);+});++test("materialized coordinates own native counts", () => {+  const points = new Proxy<readonly (readonly [number, number])[]>([[0, 0]], {+    get(target, property, receiver) {+      return property === "length" ? 1_000 : Reflect.get(target, property, receiver);+    },+  });+  using mesh = expectSuccess(runtime().delaunay(points));+  assert.equal(expectSuccess(mesh.vertexCount()), 1);+});++test("loading, runtime descent, and disposal are explicit", () => {+  const unavailable = loadMoonlight({ kind: "path", path: "" });+  assert.equal(unavailable.ok, false);+  if (!unavailable.ok) {+    assert.equal(unavailable.error.kind, "native-library-unavailable");+  }++  const firstRuntime = runtime();+  const secondRuntime = runtime();+  const first = expectSuccess(firstRuntime.delaunay([[0, 0]]));+  const second = expectSuccess(secondRuntime.delaunay([[1, 1]]));+  const mixed = first.siteUnion(second);+  assert.equal(mixed.ok, false);+  if (!mixed.ok) {+    assert.equal(mixed.error.kind, "foreign-runtime");+  }++  first[Symbol.dispose]();+  assert.equal(first.disposed, true);+  const afterDispose = first.vertexCount();+  assert.equal(afterDispose.ok, false);+  if (!afterDispose.ok) {+    assert.equal(afterDispose.error.kind, "disposed-resource");+  }+  second.dispose();+});
+ ffi/bindings/typescript/tsconfig.json view
@@ -0,0 +1,28 @@+{+  "compilerOptions": {+    "target": "ES2023",+    "lib": [+      "ES2023",+      "ESNext.Disposable"+    ],+    "module": "NodeNext",+    "moduleResolution": "NodeNext",+    "strict": true,+    "noImplicitAny": true,+    "strictNullChecks": true,+    "noUncheckedIndexedAccess": true,+    "exactOptionalPropertyTypes": true,+    "types": [+      "node"+    ],+    "declaration": true,+    "stripInternal": true,+    "rootDir": ".",+    "outDir": "dist",+    "skipLibCheck": false+  },+  "include": [+    "src/**/*.ts",+    "test/**/*.ts"+  ]+}
+ ffi/cbits/moonlight-triangulation.def view
@@ -0,0 +1,35 @@+; Generated from Moonlight.Triangulation.Foreign.Contract.+; Run moonlight-triangulation-ffi-contract write; do not edit this file.++LIBRARY moonlight-triangulation-c+EXPORTS+  ml_abi_version+  ml_runtime_initialize+  ml_delaunay_f64+  ml_mesh_insert_many_f64+  ml_mesh_site_union+  ml_mesh_site_intersection+  ml_mesh_site_difference+  ml_mesh_site_symmetric_difference+  ml_mesh_vertex_count+  ml_mesh_triangle_count+  ml_mesh_copy_vertices_f64+  ml_mesh_copy_triangles_u32+  ml_mesh_free+  ml_region_create_f64+  ml_region_counts+  ml_region_copy_f64+  ml_region_union+  ml_region_intersection+  ml_region_difference+  ml_region_symmetric_difference+  ml_region_locate_point_f64+  ml_region_measure+  ml_region_free+  ml_structuring_element_create_f64+  ml_structuring_element_free+  ml_region_minkowski_sum+  ml_region_offset+  ml_region_inset+  ml_region_open+  ml_region_close
+ ffi/cbits/moonlight_runtime.c view
@@ -0,0 +1,48 @@+#include "moonlight_triangulation.h"+#include "HsFFI.h"++#if defined(_WIN32)+#include <windows.h>++static INIT_ONCE moonlight_runtime_once = INIT_ONCE_STATIC_INIT;++static BOOL CALLBACK moonlight_initialize_runtime(PINIT_ONCE once, PVOID parameter, PVOID *context) {+  int argc = 1;+  char program_name[] = "moonlight-triangulation";+  char *argv[] = {program_name, NULL};+  char **argv_pointer = argv;+  (void)once;+  (void)parameter;+  (void)context;+  hs_init(&argc, &argv_pointer);+  return TRUE;+}++ML_API ml_status ml_runtime_initialize(void) {+  return InitOnceExecuteOnce(&moonlight_runtime_once, moonlight_initialize_runtime, NULL, NULL)+    ? ML_STATUS_OK+    : ML_STATUS_RUNTIME_FAILURE;+}+#else+#include <pthread.h>++static pthread_once_t moonlight_runtime_once = PTHREAD_ONCE_INIT;++static void moonlight_initialize_runtime(void) {+  int argc = 1;+  char program_name[] = "moonlight-triangulation";+  char *argv[] = {program_name, NULL};+  char **argv_pointer = argv;+  hs_init(&argc, &argv_pointer);+}++ML_API ml_status ml_runtime_initialize(void) {+  return pthread_once(&moonlight_runtime_once, moonlight_initialize_runtime) == 0+    ? ML_STATUS_OK+    : ML_STATUS_RUNTIME_FAILURE;+}+#endif++ML_API uint32_t ml_abi_version(void) {+  return ML_ABI_VERSION;+}
+ ffi/exports/Moonlight/Triangulation/Foreign/Exports.hs view
@@ -0,0 +1,80 @@+-- Generated from Moonlight.Triangulation.Foreign.Contract.+-- Run moonlight-triangulation-ffi-contract write; do not edit this file.++{-# LANGUAGE ForeignFunctionInterface #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}++module Moonlight.Triangulation.Foreign.Exports where++import Data.Int (Int64)+import Data.Word (Word32)+import Foreign.C.Types (CChar, CDouble (..), CSize (..), CUInt (..))+import Foreign.Ptr (Ptr)+import Moonlight.Triangulation.Foreign.Contract+  ( CMesh+  , CMinkowskiReceipt+  , CObstruction+  , CRegion+  , CStructuringElement+  )+import qualified Moonlight.Triangulation.Foreign.Mesh as Mesh+import qualified Moonlight.Triangulation.Foreign.Morphology as Morphology+import qualified Moonlight.Triangulation.Foreign.Region as Region++delaunayF64 = Mesh.delaunayF64+meshInsertManyF64 = Mesh.meshInsertManyF64+meshSiteUnion = Mesh.meshSiteUnion+meshSiteIntersection = Mesh.meshSiteIntersection+meshSiteDifference = Mesh.meshSiteDifference+meshSiteSymmetricDifference = Mesh.meshSiteSymmetricDifference+meshVertexCount = Mesh.meshVertexCount+meshTriangleCount = Mesh.meshTriangleCount+meshCopyVerticesF64 = Mesh.meshCopyVerticesF64+meshCopyTrianglesU32 = Mesh.meshCopyTrianglesU32+meshFree = Mesh.meshFree+regionCreateF64 = Region.regionCreateF64+regionCounts = Region.regionCounts+regionCopyF64 = Region.regionCopyF64+regionUnion = Region.regionUnion+regionIntersection = Region.regionIntersection+regionDifference = Region.regionDifference+regionSymmetricDifference = Region.regionSymmetricDifference+regionLocatePointF64 = Region.regionLocatePointF64+regionMeasure = Region.regionMeasure+regionFree = Region.regionFree+structuringElementCreateF64 = Morphology.structuringElementCreateF64+structuringElementFree = Morphology.structuringElementFree+regionMinkowskiSum = Morphology.regionMinkowskiSum+regionOffset = Morphology.regionOffset+regionInset = Morphology.regionInset+regionOpen = Morphology.regionOpen+regionClose = Morphology.regionClose++foreign export ccall "ml_delaunay_f64" delaunayF64 :: Ptr CDouble -> CSize -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_mesh_insert_many_f64" meshInsertManyF64 :: Ptr CMesh -> Ptr CDouble -> CSize -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_mesh_site_union" meshSiteUnion :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_mesh_site_intersection" meshSiteIntersection :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_mesh_site_difference" meshSiteDifference :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_mesh_site_symmetric_difference" meshSiteSymmetricDifference :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_mesh_vertex_count" meshVertexCount :: Ptr CMesh -> Ptr CSize -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_mesh_triangle_count" meshTriangleCount :: Ptr CMesh -> Ptr CSize -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_mesh_copy_vertices_f64" meshCopyVerticesF64 :: Ptr CMesh -> Ptr CDouble -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_mesh_copy_triangles_u32" meshCopyTrianglesU32 :: Ptr CMesh -> Ptr Word32 -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_mesh_free" meshFree :: Ptr CMesh -> IO ()+foreign export ccall "ml_region_create_f64" regionCreateF64 :: Ptr CDouble -> CSize -> Ptr CSize -> CSize -> Ptr CSize -> CSize -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_region_counts" regionCounts :: Ptr CRegion -> Ptr CSize -> Ptr CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_region_copy_f64" regionCopyF64 :: Ptr CRegion -> Ptr CDouble -> CSize -> Ptr CSize -> CSize -> Ptr CSize -> CSize -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_region_union" regionUnion :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_region_intersection" regionIntersection :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_region_difference" regionDifference :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_region_symmetric_difference" regionSymmetricDifference :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_region_locate_point_f64" regionLocatePointF64 :: Ptr CRegion -> CDouble -> CDouble -> Ptr CUInt -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_region_measure" regionMeasure :: Ptr CRegion -> Ptr Int64 -> Ptr CChar -> CSize -> Ptr CSize -> Ptr CDouble -> Ptr CDouble -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_region_free" regionFree :: Ptr CRegion -> IO ()+foreign export ccall "ml_structuring_element_create_f64" structuringElementCreateF64 :: Ptr CDouble -> CSize -> Ptr (Ptr CStructuringElement) -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_structuring_element_free" structuringElementFree :: Ptr CStructuringElement -> IO ()+foreign export ccall "ml_region_minkowski_sum" regionMinkowskiSum :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_region_offset" regionOffset :: Ptr CStructuringElement -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_region_inset" regionInset :: Ptr CStructuringElement -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_region_open" regionOpen :: Ptr CStructuringElement -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt+foreign export ccall "ml_region_close" regionClose :: Ptr CStructuringElement -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt
+ ffi/generator/Main.hs view
@@ -0,0 +1,116 @@+module Main (main) where++import Data.Either (partitionEithers)+import Data.Foldable (traverse_)+import Data.Bifunctor (first)+import Moonlight.Triangulation.Foreign.Contract.Render+  ( GeneratedFile (..)+  , generatedFiles+  )+import System.Directory (createDirectoryIfMissing, doesFileExist)+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.FilePath ((</>), takeDirectory)+import System.IO (readFile')+import System.IO.Error (ioeGetErrorString, tryIOError)++data Command+  = WriteGenerated !FilePath+  | CheckGenerated !FilePath+  deriving stock (Eq, Show)++data GeneratorObstruction+  = InvalidArguments+  | GeneratedFileMissing !FilePath+  | GeneratedFileStale !FilePath+  | GeneratedFileReadFailed !FilePath !String+  | GeneratedFileWriteFailed !FilePath !String+  deriving stock (Eq, Show)++main :: IO ()+main = do+  arguments <- getArgs+  case parseCommand arguments of+    Left obstruction -> reportObstructions [obstruction]+    Right command -> runCommand command >>= either reportObstructions (const (pure ()))++parseCommand :: [String] -> Either GeneratorObstruction Command+parseCommand arguments =+  case arguments of+    ["write", packageRoot] -> Right (WriteGenerated packageRoot)+    ["check", packageRoot] -> Right (CheckGenerated packageRoot)+    _ -> Left InvalidArguments++runCommand :: Command -> IO (Either [GeneratorObstruction] ())+runCommand command =+  case command of+    WriteGenerated packageRoot -> do+      outcomes <- traverse (writeGeneratedFile packageRoot) generatedFiles+      pure (collectObstructions outcomes)+    CheckGenerated packageRoot -> do+      comparisons <- traverse (checkGeneratedFile packageRoot) generatedFiles+      pure (collectObstructions comparisons)++collectObstructions :: [Either GeneratorObstruction ()] -> Either [GeneratorObstruction] ()+collectObstructions outcomes =+  case partitionEithers outcomes of+    ([], _) -> Right ()+    (obstructions, _) -> Left obstructions++writeGeneratedFile :: FilePath -> GeneratedFile -> IO (Either GeneratorObstruction ())+writeGeneratedFile packageRoot generated@GeneratedFile {generatedFilePath, generatedFileContents} = do+  let destination = packageRoot </> generatedFilePath+  comparison <- checkGeneratedFile packageRoot generated+  case comparison of+    Right () -> putStrLn ("current " <> destination) >> pure (Right ())+    Left (GeneratedFileMissing _) -> replaceGeneratedFile destination generatedFileContents+    Left (GeneratedFileStale _) -> replaceGeneratedFile destination generatedFileContents+    Left obstruction -> pure (Left obstruction)++replaceGeneratedFile :: FilePath -> String -> IO (Either GeneratorObstruction ())+replaceGeneratedFile destination contents = do+  outcome <-+    captureFileFailure GeneratedFileWriteFailed destination $ do+      createDirectoryIfMissing True (takeDirectory destination)+      writeFile destination contents+  case outcome of+    Left obstruction -> pure (Left obstruction)+    Right () -> putStrLn ("wrote " <> destination) >> pure (Right ())++checkGeneratedFile :: FilePath -> GeneratedFile -> IO (Either GeneratorObstruction ())+checkGeneratedFile packageRoot GeneratedFile {generatedFilePath, generatedFileContents} = do+  let destination = packageRoot </> generatedFilePath+  existence <- captureFileFailure GeneratedFileReadFailed destination (doesFileExist destination)+  case existence of+    Left obstruction -> pure (Left obstruction)+    Right False -> pure (Left (GeneratedFileMissing destination))+    Right True -> do+      observed <- captureFileFailure GeneratedFileReadFailed destination (readFile' destination)+      pure $ do+        contents <- observed+        if contents == generatedFileContents+          then Right ()+          else Left (GeneratedFileStale destination)++captureFileFailure+  :: (FilePath -> String -> GeneratorObstruction)+  -> FilePath+  -> IO value+  -> IO (Either GeneratorObstruction value)+captureFileFailure obstruction path action =+  first (obstruction path . ioeGetErrorString) <$> tryIOError action++reportObstructions :: [GeneratorObstruction] -> IO ()+reportObstructions obstructions = do+  traverse_ (putStrLn . renderObstruction) obstructions+  exitFailure++renderObstruction :: GeneratorObstruction -> String+renderObstruction obstruction =+  case obstruction of+    InvalidArguments ->+      "usage: moonlight-triangulation-ffi-contract (write|check) PACKAGE_ROOT"+    GeneratedFileMissing path -> "missing generated file: " <> path+    GeneratedFileStale path -> "stale generated file: " <> path+    GeneratedFileReadFailed path message -> "cannot read generated file " <> path <> ": " <> message+    GeneratedFileWriteFailed path message -> "cannot write generated file " <> path <> ": " <> message
+ ffi/include/moonlight_triangulation.h view
@@ -0,0 +1,204 @@+// Generated from Moonlight.Triangulation.Foreign.Contract.+// Run moonlight-triangulation-ffi-contract write; do not edit this file.++#ifndef MOONLIGHT_TRIANGULATION_H+#define MOONLIGHT_TRIANGULATION_H++#include <stddef.h>+#include <stdint.h>++#if defined(_WIN32)+#define ML_API __declspec(dllexport)+#else+#define ML_API __attribute__((visibility("default")))+#endif++#ifdef __cplusplus+extern "C" {+#endif++#define ML_ABI_VERSION 2u++typedef struct ml_mesh ml_mesh;+typedef struct ml_region ml_region;+typedef struct ml_structuring_element ml_structuring_element;++typedef uint32_t ml_status;+typedef uint32_t ml_obstruction_code;+typedef uint32_t ml_coordinate_error;+typedef uint32_t ml_region_location;+typedef uint32_t ml_minkowski_operation;++enum {+  ML_STATUS_OK = 0,+  ML_STATUS_NULL_POINTER = 1,+  ML_STATUS_COUNT_OVERFLOW = 2,+  ML_STATUS_BUFFER_TOO_SMALL = 3,+  ML_STATUS_GEOMETRY_OBSTRUCTION = 4,+  ML_STATUS_RUNTIME_FAILURE = 5+};++enum {+  ML_OBSTRUCTION_NONE = 0,+  ML_OBSTRUCTION_INVALID_COORDINATE = 1,+  ML_OBSTRUCTION_POINT_LOCATION_FAILED = 2,+  ML_OBSTRUCTION_LOCATION_WALK_EXHAUSTED = 3,+  ML_OBSTRUCTION_REFINEMENT_INPUT_TOPOLOGY_INVALID = 4,+  ML_OBSTRUCTION_FRESH_INSERTION_MATCHED_EXISTING_VERTEX = 5,+  ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_MISSING_OUTGOING = 6,+  ML_OBSTRUCTION_DEGENERATE_LINE_ENDPOINT_TURN_MISSING = 7,+  ML_OBSTRUCTION_DEGENERATE_LINE_CONNECTED_VERTEX_MISSING = 8,+  ML_OBSTRUCTION_HULL_START_NOT_VISIBLE = 9,+  ML_OBSTRUCTION_OUTER_RANGE_DID_NOT_TERMINATE = 10,+  ML_OBSTRUCTION_OUTER_RANGE_CONTAINS_INNER_EDGE = 11,+  ML_OBSTRUCTION_CONSTRAINED_EDGE_FLIP_REFUSED = 12,+  ML_OBSTRUCTION_REMOVAL_VERTEX_OUT_OF_RANGE = 13,+  ML_OBSTRUCTION_REMOVAL_EDGE_OUT_OF_RANGE = 14,+  ML_OBSTRUCTION_REMOVAL_FACE_OUT_OF_RANGE = 15,+  ML_OBSTRUCTION_REMOVAL_FACE_CYCLE_DID_NOT_TERMINATE = 16,+  ML_OBSTRUCTION_REMOVAL_EMPTY_TRIANGULATION = 17,+  ML_OBSTRUCTION_REMOVAL_TWO_POINT_DEGREE_MISMATCH = 18,+  ML_OBSTRUCTION_REMOVAL_COLLINEAR_DEGREE_MISMATCH = 19,+  ML_OBSTRUCTION_REMOVAL_BORDER_TOO_SHORT = 20,+  ML_OBSTRUCTION_REMOVAL_BORDER_ARITY_MISMATCH = 21,+  ML_OBSTRUCTION_REMOVAL_OUTGOING_CYCLE_DID_NOT_TERMINATE = 22,+  ML_OBSTRUCTION_CIRCLE_SWEEP_HULL_EMPTY = 23,+  ML_OBSTRUCTION_OUTER_CYCLE_DID_NOT_TERMINATE = 24,+  ML_OBSTRUCTION_HIERARCHY_LEVEL_POPULATION_MISMATCH = 25,+  ML_OBSTRUCTION_HIERARCHY_INSERTION_HANDLE_MISMATCH = 26,+  ML_OBSTRUCTION_POINT_INDEX_CAPACITY_EXHAUSTED = 27,+  ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_NOT_FINITE = 28,+  ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_OUT_OF_RANGE = 29,+  ML_OBSTRUCTION_REFINEMENT_MINIMUM_ANGLE_DERIVED_RATIO_NOT_FINITE = 30,+  ML_OBSTRUCTION_REFINEMENT_MAXIMUM_ADDITIONAL_VERTICES_NEGATIVE = 31,+  ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NOT_FINITE = 32,+  ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_NEGATIVE = 33,+  ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_FINITE = 34,+  ML_OBSTRUCTION_REFINEMENT_MAXIMUM_AREA_NOT_POSITIVE = 35,+  ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_FINITE = 36,+  ML_OBSTRUCTION_REFINEMENT_MAXIMUM_RADIUS_EDGE_RATIO_NOT_POSITIVE = 37,+  ML_OBSTRUCTION_REFINEMENT_MINIMUM_AREA_EXCEEDS_MAXIMUM = 38,+  ML_OBSTRUCTION_REFINEMENT_SEED_FACE_NOT_ACTIVE = 39,+  ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EDGE_NOT_ACTIVE = 40,+  ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_MISSING = 41,+  ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_EXTRANEOUS = 42,+  ML_OBSTRUCTION_REFINEMENT_DOMAIN_TOPOLOGY_CHANGED = 43,+  ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONVEX_HULL_PRESERVATION = 44,+  ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_CONSTRAINT_PRESERVATION = 45,+  ML_OBSTRUCTION_REFINEMENT_DOMAIN_FORBIDS_OUTER_FACE_EXCLUSION = 46,+  ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_CROSS_INTERFACE = 47,+  ML_OBSTRUCTION_REFINEMENT_DOMAIN_WOULD_REWRITE_PROTECTED_FACE = 48,+  ML_OBSTRUCTION_REFINEMENT_DOMAIN_PROTECTED_FACE_CHANGED = 49,+  ML_OBSTRUCTION_CAPACITY_EXCEEDED = 50,+  ML_OBSTRUCTION_HALF_EDGE_CAPACITY_EXCEEDED = 51,+  ML_OBSTRUCTION_FACE_CAPACITY_EXCEEDED = 52,+  ML_OBSTRUCTION_PAYLOAD_STORAGE_FAILURE = 53,+  ML_OBSTRUCTION_COORDINATE_PAYLOAD_COUNT_MISMATCH = 54,+  ML_OBSTRUCTION_CIRCLE_SWEEP_REQUIRES_DENSE_STORAGE = 55,+  ML_OBSTRUCTION_SEAM_FRONTIER_UNAVAILABLE = 56,+  ML_OBSTRUCTION_REFINEMENT_DOMAIN_REQUIRES_FINITE_VERTEX_BUDGET = 57,+  ML_OBSTRUCTION_SEAM_SOURCE_EDGE_REQUIRES_FLIP = 58,+  ML_OBSTRUCTION_SEAM_PROTECTED_SOURCE_FACE_CHANGED = 59,+  ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_FINITE = 60,+  ML_OBSTRUCTION_REFINEMENT_MAXIMUM_EDGE_LENGTH_NOT_POSITIVE = 61,+  ML_OBSTRUCTION_REFINEMENT_OVERSIZED_EDGE = 62,+  ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_BUDGET_EXCEEDED = 63,+  ML_OBSTRUCTION_REFINEMENT_SEAM_BRIDGE_MIDPOINT_COLLAPSED = 64,+  ML_OBSTRUCTION_BOUNDARY_SPLIT_REQUIRES_BOUNDARY_EDGE = 65,+  ML_OBSTRUCTION_REFINEMENT_DOMAIN_INTERFACE_OPPOSITE_FACE_NOT_PERMITTED = 66,+  ML_OBSTRUCTION_NULL_POINTER = 100,+  ML_OBSTRUCTION_COUNT_OVERFLOW = 101,+  ML_OBSTRUCTION_BUFFER_TOO_SMALL = 102,+  ML_OBSTRUCTION_RUNTIME_FAILURE = 103,+  ML_OBSTRUCTION_REGION_LAYOUT_INVALID = 200,+  ML_OBSTRUCTION_REGION_VALIDATION_FAILED = 201,+  ML_OBSTRUCTION_OVERLAY_FAILED = 202,+  ML_OBSTRUCTION_REGION_PUBLICATION_FAILED = 203,+  ML_OBSTRUCTION_VALUATION_FAILED = 204,+  ML_OBSTRUCTION_MINKOWSKI_FAILED = 205,+  ML_OBSTRUCTION_REGION_PROJECTION_FAILED = 206+};++enum {+  ML_COORDINATE_ERROR_NONE = 0,+  ML_COORDINATE_ERROR_NAN = 1,+  ML_COORDINATE_ERROR_INFINITE = 2,+  ML_COORDINATE_ERROR_TOO_SMALL = 3,+  ML_COORDINATE_ERROR_TOO_LARGE = 4+};++enum {+  ML_REGION_EXTERIOR = 0,+  ML_REGION_BOUNDARY = 1,+  ML_REGION_INTERIOR = 2+};++enum {+  ML_MINKOWSKI_ADDITION = 0,+  ML_MINKOWSKI_EROSION = 1,+  ML_MINKOWSKI_OPENING = 2,+  ML_MINKOWSKI_CLOSING = 3+};++typedef struct ml_obstruction {+  uint32_t code;+  uint32_t coordinate_error;+  uint64_t input_index;+  uint64_t first_index;+  uint64_t second_index;+  double first_value;+  double second_value;+  double point_x;+  double point_y;+  char message[256];+} ml_obstruction;++typedef struct ml_minkowski_receipt {+  uint32_t operation;+  uint32_t reserved;+  uint64_t input_components;+  uint64_t convex_pieces;+  uint64_t generated_pieces;+  uint64_t generated_convolution_edges;+  uint64_t overlay_passes;+  uint64_t exact_crossings;+  uint64_t output_cells;+  uint64_t exact_coordinate_bit_growth;+} ml_minkowski_receipt;++ML_API uint32_t ml_abi_version(void);+ML_API ml_status ml_runtime_initialize(void);+ML_API ml_status ml_delaunay_f64(const double * coordinates, size_t point_count, ml_mesh ** result, ml_obstruction * obstruction);+ML_API ml_status ml_mesh_insert_many_f64(const ml_mesh * mesh, const double * coordinates, size_t point_count, ml_mesh ** result, ml_obstruction * obstruction);+ML_API ml_status ml_mesh_site_union(const ml_mesh * left, const ml_mesh * right, ml_mesh ** result, ml_obstruction * obstruction);+ML_API ml_status ml_mesh_site_intersection(const ml_mesh * left, const ml_mesh * right, ml_mesh ** result, ml_obstruction * obstruction);+ML_API ml_status ml_mesh_site_difference(const ml_mesh * left, const ml_mesh * right, ml_mesh ** result, ml_obstruction * obstruction);+ML_API ml_status ml_mesh_site_symmetric_difference(const ml_mesh * left, const ml_mesh * right, ml_mesh ** result, ml_obstruction * obstruction);+ML_API ml_status ml_mesh_vertex_count(const ml_mesh * mesh, size_t * count, ml_obstruction * obstruction);+ML_API ml_status ml_mesh_triangle_count(const ml_mesh * mesh, size_t * count, ml_obstruction * obstruction);+ML_API ml_status ml_mesh_copy_vertices_f64(const ml_mesh * mesh, double * coordinates, size_t point_capacity, size_t * points_written, ml_obstruction * obstruction);+ML_API ml_status ml_mesh_copy_triangles_u32(const ml_mesh * mesh, uint32_t * triangles, size_t triangle_capacity, size_t * triangles_written, ml_obstruction * obstruction);+ML_API void ml_mesh_free(ml_mesh * mesh);+ML_API ml_status ml_region_create_f64(const double * coordinates, size_t point_count, const size_t * loop_point_counts, size_t loop_count, const size_t * component_loop_counts, size_t component_count, ml_region ** result, ml_obstruction * obstruction);+ML_API ml_status ml_region_counts(const ml_region * region, size_t * component_count, size_t * loop_count, size_t * point_count, ml_obstruction * obstruction);+ML_API ml_status ml_region_copy_f64(const ml_region * region, double * coordinates, size_t point_capacity, size_t * loop_point_offsets, size_t loop_offset_capacity, size_t * component_loop_offsets, size_t component_offset_capacity, ml_obstruction * obstruction);+ML_API ml_status ml_region_union(const ml_region * left, const ml_region * right, ml_region ** result, ml_obstruction * obstruction);+ML_API ml_status ml_region_intersection(const ml_region * left, const ml_region * right, ml_region ** result, ml_obstruction * obstruction);+ML_API ml_status ml_region_difference(const ml_region * left, const ml_region * right, ml_region ** result, ml_obstruction * obstruction);+ML_API ml_status ml_region_symmetric_difference(const ml_region * left, const ml_region * right, ml_region ** result, ml_obstruction * obstruction);+ML_API ml_status ml_region_locate_point_f64(const ml_region * region, double x, double y, ml_region_location * location, ml_obstruction * obstruction);+ML_API ml_status ml_region_measure(const ml_region * region, int64_t * euler_characteristic, char * area_ratio_utf8, size_t area_capacity, size_t * area_bytes_written, double * perimeter_lower, double * perimeter_upper, ml_obstruction * obstruction);+ML_API void ml_region_free(ml_region * region);+ML_API ml_status ml_structuring_element_create_f64(const double * coordinates, size_t point_count, ml_structuring_element ** result, ml_obstruction * obstruction);+ML_API void ml_structuring_element_free(ml_structuring_element * element);+ML_API ml_status ml_region_minkowski_sum(const ml_region * left, const ml_region * right, ml_region ** result, ml_minkowski_receipt * receipt, ml_obstruction * obstruction);+ML_API ml_status ml_region_offset(const ml_structuring_element * element, const ml_region * region, ml_region ** result, ml_minkowski_receipt * receipt, ml_obstruction * obstruction);+ML_API ml_status ml_region_inset(const ml_structuring_element * element, const ml_region * region, ml_region ** result, ml_minkowski_receipt * receipt, ml_obstruction * obstruction);+ML_API ml_status ml_region_open(const ml_structuring_element * element, const ml_region * region, ml_region ** result, ml_minkowski_receipt * receipt, ml_obstruction * obstruction);+ML_API ml_status ml_region_close(const ml_structuring_element * element, const ml_region * region, ml_region ** result, ml_minkowski_receipt * receipt, ml_obstruction * obstruction);++#ifdef __cplusplus+}+#endif++#endif
+ moonlight-planar.cabal view
@@ -0,0 +1,1411 @@+cabal-version:       3.4+name:                moonlight-planar+version:             1.0.0.0+synopsis:            Native hex regions, Delaunay meshes, and exact planar algebra.+description:         Native packed hexagonal cell regions and Delaunay and+                     constrained Delaunay triangulation as lawful+                     finite-set algebras, 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+                     constrained and unconstrained layers. Private finite-DCEL+                     and construction kernels own trusted representations and+                     admitted fast paths. Public dcel and build sublibraries+                     expose their lawful immutable observations, typed queries,+                     construction, incremental edits, constraint recovery, and+                     refinement without duplicating those owners. Further opt-in+                     sublibraries expose the exact scalar core, Voronoi and+                     natural-neighbour dual, bounded concurrent join interpreter,+                     and versioned serialization surface beside the broad main+                     facade. The dependency-light hex component provides axial+                     elements, arithmetic neighbours, wordwise Boolean algebra,+                     restriction, and overlap-compatible gluing without DCEL or+                     polygon construction.+                     On GHC 9.14, a public cell-complex component interprets+                     admitted exact cell selections for Homology and Category+                     and lowers exact Delaunay alpha filtrations into persistent+                     homology; an opt-in zigzag component tracks exact topology+                     across independently sampled, non-nested labelled depths.+                     Failure is values: every refusal names its witness.+license:             MIT+license-file:        LICENSE+author:              Blue Rose+maintainer:          rosaliafialkova@gmail.com+copyright:           (c) 2026 Blue Rose+category:            Geometry, Math+homepage:            https://github.com/PaleRoses/moonlight+bug-reports:         https://github.com/PaleRoses/moonlight/issues+build-type:          Simple+tested-with:         GHC == 9.8.4+                     GHC == 9.10.3+                     GHC == 9.12.4+                     GHC == 9.14.1+extra-doc-files:+  README.md+  CHANGELOG.md+  docs/README.md+  docs/development.md+  docs/activation-zigzag.md+  docs/regular-site-algebra.md+  docs/weighted-alpha.md+  docs/examples/README.md+  docs/mesh-publication.md+  docs/category-observatory/README.md+  docs/category-observatory/moonlight-triangulation-category-observatory.svg+  docs/delaunay-compare/README.md+  docs/delaunay-compare/results/moonlight-delaunay-compare-small.svg+  docs/persistence-rose/alpha-eclipse.md+  docs/persistence-rose/README.md+  docs/persistence-rose/moonlight-triangulation-alpha-eclipse.svg+  docs/persistence-rose/moonlight-triangulation-persistence-rose.svg+  docs/persistence-rose/moonlight-triangulation-persistence-rose.gif+extra-source-files:+  weeder.toml+  -- The retained CSV, source receipt, and big-point SVG remain beside the+  -- benchmark but are not package inputs. The small documentation projection+  -- is the sole published chart and is declared above.+  docs/delaunay-compare/rust/Cargo.lock+  docs/delaunay-compare/rust/Cargo.toml+  docs/delaunay-compare/rust/src/lib.rs+  ffi/include/moonlight_triangulation.h+  ffi/bindings/README.md+  ffi/bindings/python/pyproject.toml+  ffi/bindings/python/src/moonlight_triangulation/__init__.py+  ffi/bindings/python/src/moonlight_triangulation/_binding.py+  ffi/bindings/python/src/moonlight_triangulation/_native_generated.py+  ffi/bindings/python/src/moonlight_triangulation/errors.py+  ffi/bindings/python/src/moonlight_triangulation/values.py+  ffi/bindings/python/tests/test_binding.py+  ffi/bindings/rust/Cargo.toml+  ffi/bindings/rust/build.rs+  ffi/bindings/rust/src/binding.rs+  ffi/bindings/rust/src/error.rs+  ffi/bindings/rust/src/lib.rs+  ffi/bindings/rust/src/raw_generated.rs+  ffi/bindings/rust/src/values.rs+  ffi/bindings/rust/tests/binding.rs+  ffi/bindings/typescript/README.md+  ffi/bindings/typescript/package.json+  ffi/bindings/typescript/pnpm-workspace.yaml+  ffi/bindings/typescript/tsconfig.json+  ffi/bindings/typescript/src/failure.ts+  ffi/bindings/typescript/src/index.ts+  ffi/bindings/typescript/src/internal/call.ts+  ffi/bindings/typescript/src/internal/decode.ts+  ffi/bindings/typescript/src/internal/native.generated.ts+  ffi/bindings/typescript/src/internal/resource.ts+  ffi/bindings/typescript/src/mesh.ts+  ffi/bindings/typescript/src/moonlight.ts+  ffi/bindings/typescript/src/morphology.ts+  ffi/bindings/typescript/src/region.ts+  ffi/bindings/typescript/src/resource.ts+  ffi/bindings/typescript/src/values.ts+  ffi/bindings/typescript/src/wire.generated.ts+  ffi/bindings/typescript/test/binding.test.ts++source-repository head+  type:     git+  location: https://github.com/PaleRoses/moonlight.git+  subdir:   moonlight-planar++source-repository this+  type:     git+  location: https://github.com/PaleRoses/moonlight.git+  tag:      moonlight-planar-1.0.0.0+  subdir:   moonlight-planar++flag warnings-as-errors+  description: Treat compiler warnings as errors in package validation.+  default: False+  manual: True++common shared-properties+  default-language: GHC2021+  default-extensions:+    DerivingStrategies+  ghc-options:+    -Wall+    -Wcompat+    -Widentities+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wredundant-constraints+    -Wpartial-fields+    -Wno-missing-import-lists+  if flag(warnings-as-errors)+    ghc-options: -Werror+  -- The hot modules that request LLVM O3 replace GHC's default optimiser+  -- recipe. GHC 9.8 therefore needs its supported legacy pass manager stated+  -- explicitly; LLVM 15 otherwise combines the new manager with old TBAA+  -- pass flags and refuses before code generation.+  if impl(ghc < 9.10)+    ghc-options: -optlo-enable-new-pm=0++-- ── the tower ────────────────────────────────────────────────────────────────+-- The implementation tower separates the public exact scalar core from the+-- package-private paged-storage kernel. Both feed dcel-internal, followed by+-- build-internal. Public dcel and build components are restrictions of those+-- owners: they reexport lawful modules without copying implementations or+-- publishing trusted constructors. Dual branches directly from the DCEL owner;+-- the apex owns only the genuine overlaps. The graph is acyclic and uses no+-- @.hs-boot@ files.++library core+  import: shared-properties+  visibility: public+  hs-source-dirs: src-core+  exposed-modules:+    Moonlight.Triangulation.Scalar+    Moonlight.Triangulation.LineSideInfo+    Moonlight.Triangulation.Internal.Dyadic+    Moonlight.Triangulation.Internal.ExactRational+  build-depends:+    base >= 4.19 && < 5+    , deepseq >= 1.5 && < 1.6+  ghc-options: -fexpose-all-unfoldings++-- Native hexagonal cell algebra is a bottom component: consumers pay for one+-- packed bit per admitted cell and do not acquire DCEL, overlay, Homology, or+-- serialization dependencies merely to manipulate a hexagonal world.+library hex+  import: shared-properties+  visibility: public+  hs-source-dirs: src-hex+  exposed-modules:+    Moonlight.Hex.Coordinate+    Moonlight.Hex.Element+    Moonlight.Hex.Region+  build-depends:+    base >= 4.19 && < 5+    , deepseq >= 1.5 && < 1.6+    , transformers >= 0.6 && < 0.7+    , vector >= 0.13 && < 0.14+  ghc-options: -O2 -fexpose-all-unfoldings++-- Trusted paged storage is shared by the immutable DCEL and construction+-- owners. It is private because raw page indices and unsafe vector operations+-- are valid only after those owners have admitted array bounds and page order.+library storage-internal+  import: shared-properties+  visibility: private+  hs-source-dirs: src-core+  exposed-modules:+    Moonlight.Triangulation.Internal.PageDirectory+    Moonlight.Triangulation.Internal.Paged+    Moonlight.Triangulation.Internal.BoxedPaged+    Moonlight.Triangulation.Internal.Growable+    Moonlight.Triangulation.Internal.PackedIndex+    Moonlight.Triangulation.Internal.FaceQueue+  build-depends:+    base >= 4.19 && < 5+    , containers >= 0.8 && < 0.9+    , deepseq >= 1.5 && < 1.6+    , vector >= 0.13 && < 0.14+  ghc-options: -fexpose-all-unfoldings++library dcel-internal+  import: shared-properties+  visibility: private+  hs-source-dirs: src-dcel+  exposed-modules:+    Moonlight.Triangulation.Alpha+    Moonlight.Triangulation.Types+    Moonlight.Triangulation.Math+    Moonlight.Triangulation.Exact+    Moonlight.Triangulation.Simplex+    Moonlight.Triangulation.CellSet+    Moonlight.Triangulation.Region+    Moonlight.Triangulation.Valuation+    Moonlight.Triangulation.Interop+    Moonlight.Triangulation.Dcel+    Moonlight.Triangulation.Canonical+    Moonlight.Triangulation.Payload+    Moonlight.Triangulation.JoinSemilattice+    Moonlight.Triangulation.Handles.HandleDefs+    Moonlight.Triangulation.Internal.HandleDefs+    Moonlight.Triangulation.Handles.Dynamic+    Moonlight.Triangulation.Handles.Scoped+    Moonlight.Triangulation.Handles.Iterators.CircularIterator+    Moonlight.Triangulation.Handles.Iterators.DynamicIterators+    Moonlight.Triangulation.Handles.Iterators.FixedIterators+    Moonlight.Triangulation.Handles.Iterators.HullIterator+    Moonlight.Triangulation.PointLocation+    Moonlight.Triangulation.Validation+    Moonlight.Triangulation.Internal.Validation+    Moonlight.Triangulation.FloodFillIterator+    Moonlight.Triangulation.Internal.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.Predicates+    Moonlight.Triangulation.Internal.SegmentRelation+    Moonlight.Triangulation.Internal.Types+    Moonlight.Triangulation.Internal.Representation+    Moonlight.Triangulation.Internal.PointIndex+    Moonlight.Triangulation.Internal.Mutable+    Moonlight.Triangulation.Internal.OperationState+    Moonlight.Triangulation.Internal.Tournament+    Moonlight.Triangulation.Internal.Probe+    Moonlight.Triangulation.Internal.DcelOperations.CandidateArena+    Moonlight.Triangulation.Internal.DcelOperations.Chain+    Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite+    Moonlight.Triangulation.Internal.DcelOperations.FlipRule+    Moonlight.Triangulation.Internal.DcelOperations.Hull+    Moonlight.Triangulation.Internal.DcelOperations.Legalize+    Moonlight.Triangulation.Internal.DcelOperations.Normalize+    Moonlight.Triangulation.Internal.DcelOperations.Subdivide+    Moonlight.Triangulation.Internal.DcelOperations.Twin+    Moonlight.Triangulation.Internal.Canonical+  other-modules:+    Moonlight.Triangulation.Internal.Region.Bounds+  build-depends:+    base >= 4.19 && < 5+    , containers >= 0.8 && < 0.9+    , deepseq >= 1.5 && < 1.6+    , primitive >= 0.9 && < 0.10+    , vector >= 0.13 && < 0.14+    , vector-algorithms >= 0.9 && < 0.10+    , moonlight-planar:core+    , moonlight-planar:storage-internal+  ghc-options: -fexpose-all-unfoldings++-- Public immutable-DCEL and exact-geometry surface. Every module is the module+-- compiled by dcel-internal; reexporting preserves one type and implementation+-- identity while leaving representation modules hidden.+library dcel+  import: shared-properties+  visibility: public+  reexported-modules:+    Moonlight.Triangulation.Alpha+    , Moonlight.Triangulation.Types+    , Moonlight.Triangulation.Math+    , Moonlight.Triangulation.Exact+    , Moonlight.Triangulation.Simplex+    , Moonlight.Triangulation.CellSet+    , Moonlight.Triangulation.Region+    , Moonlight.Triangulation.Valuation+    , Moonlight.Triangulation.Interop+    , Moonlight.Triangulation.Dcel+    , Moonlight.Triangulation.Canonical+    , Moonlight.Triangulation.Payload+    , Moonlight.Triangulation.JoinSemilattice+    , Moonlight.Triangulation.Handles.HandleDefs+    , Moonlight.Triangulation.Handles.Dynamic+    , Moonlight.Triangulation.Handles.Scoped+    , Moonlight.Triangulation.Handles.Iterators.DynamicIterators+    , Moonlight.Triangulation.Handles.Iterators.FixedIterators+    , Moonlight.Triangulation.Handles.Iterators.HullIterator+    , Moonlight.Triangulation.PointLocation+    , Moonlight.Triangulation.Validation+    , Moonlight.Triangulation.FloodFillIterator+    , Moonlight.Triangulation.IntersectionIterator+  build-depends:+    moonlight-planar:dcel-internal++-- An ExactCellSet already carries every handle and closure witness needed to+-- interpret it as a generic finite cell complex. This component is the+-- canonical owner of that interpretation and of the alpha-birth lowering into+-- Homology. It deliberately remains outside the portable geometry tower+-- because its Homology dependency requires GHC 9.14.+library cell-complex+  import: shared-properties+  visibility: public+  hs-source-dirs: src-cell-complex+  default-extensions:+    TypeFamilies+  exposed-modules:+    Moonlight.Hex.CellComplex+    Moonlight.Triangulation.CellComplex+    Moonlight.Triangulation.LabelledComplex+  if impl(ghc < 9.14)+    buildable: False+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , deepseq >= 1.5 && < 1.6+    , moonlight-algebra:abstract >= 0.1 && < 0.2+    , moonlight-homology >= 0.1.0.2 && < 0.2+    , moonlight-homology:cell-complex >= 0.1.0.2 && < 0.2+    , moonlight-planar:hex+    , moonlight-planar:dcel-internal+    , vector >= 0.13 && < 0.14++-- Stable activation labels induce canonical simplices across independently+-- built depth meshes.  This opt-in layer owns the exact alpha ingestion and+-- adjacent-union correspondence witnesses; Homology owns the zigzag reducer.+library zigzag+  import: shared-properties+  visibility: public+  hs-source-dirs: src-zigzag+  exposed-modules:+    Moonlight.Triangulation.Zigzag+  if impl(ghc < 9.14)+    buildable: False+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , moonlight-core >= 0.1 && < 0.2+    , moonlight-homology >= 0.1.0.3 && < 0.2+    , moonlight-planar:build+    , moonlight-planar:cell-complex+    , moonlight-planar:dcel+    , vector >= 0.13 && < 0.14++library build-internal+  import: shared-properties+  visibility: private+  hs-source-dirs: src-build+  exposed-modules:+    Moonlight.Triangulation.BulkLoad+    Moonlight.Triangulation.Internal.BulkLoad+    Moonlight.Triangulation.Removal+    Moonlight.Triangulation.Session+    Moonlight.Triangulation.Internal.Session+    Moonlight.Triangulation.Cdt+    Moonlight.Triangulation.Refinement+    Moonlight.Triangulation.SetAlgebra+    Moonlight.Triangulation.Internal.Cdt.Build+    Moonlight.Triangulation.Internal.Cdt.Query+    Moonlight.Triangulation.Internal.Cdt.Types+    Moonlight.Triangulation.Internal.Cdt.Union+    Moonlight.Triangulation.Internal.Join+    Moonlight.Triangulation.Internal.Join.Seam+  other-modules:+    Moonlight.Triangulation.Insertion+    Moonlight.Triangulation.Internal.Capacity+    Moonlight.Triangulation.Internal.Cdt.Admission+    Moonlight.Triangulation.Internal.Cdt.Batch+    Moonlight.Triangulation.Internal.Cdt.Combinators+    Moonlight.Triangulation.Internal.Cdt.Corridor+    Moonlight.Triangulation.Internal.Cdt.Corridor.Trace+    Moonlight.Triangulation.Internal.Cdt.Recovery+    Moonlight.Triangulation.Internal.Cdt.Region+    Moonlight.Triangulation.Internal.Cdt.Segment+    Moonlight.Triangulation.Internal.Cdt.Site+    Moonlight.Triangulation.Internal.Cdt.Split+    Moonlight.Triangulation.Internal.Excision+    Moonlight.Triangulation.Internal.Location+    Moonlight.Triangulation.Internal.CircleSweep+    Moonlight.Triangulation.Internal.Refinement+    Moonlight.Triangulation.Internal.Transaction+    Moonlight.Triangulation.Internal.Join.Plan+    Moonlight.Triangulation.Internal.Join.SiteSet+  build-depends:+    base >= 4.19 && < 5+    , containers >= 0.8 && < 0.9+    , deepseq >= 1.5 && < 1.6+    , primitive >= 0.9 && < 0.10+    , vector >= 0.13 && < 0.14+    , vector-algorithms >= 0.9 && < 0.10+    , moonlight-planar:core+    , moonlight-planar:dcel-internal+    , moonlight-planar:storage-internal+  ghc-options: -fexpose-all-unfoldings++-- Public construction surface over the private kernel. Trusted admitted-input+-- and local-transaction entries live only in build-internal; the modules below+-- are their typed, immutable restrictions.+library build+  import: shared-properties+  visibility: public+  reexported-modules:+    Moonlight.Triangulation.BulkLoad+    , Moonlight.Triangulation.Removal+    , Moonlight.Triangulation.Session+    , Moonlight.Triangulation.Cdt+    , Moonlight.Triangulation.Refinement+    , Moonlight.Triangulation.SetAlgebra+  build-depends:+    moonlight-planar:build-internal++-- Concurrency is an effect boundary over the pure build planner. Keeping it in+-- its own sublibrary prevents @async@ from infecting the geometry core.+library parallel+  import: shared-properties+  visibility: public+  hs-source-dirs: src-parallel+  exposed-modules:+    Moonlight.Triangulation.Parallel+  build-depends:+    base >= 4.19 && < 5+    , async >= 2.2 && < 2.3+    , deepseq >= 1.5 && < 1.6+    , moonlight-planar:build-internal+    , moonlight-planar:dcel-internal+  ghc-options: -fexpose-all-unfoldings++-- Its own sublibrary so that @binary@ and @bytestring@ stay out of the minimal+-- geometry core.  This is a dependency boundary, not a size split; it replaces+-- the former @serialization@ flag, which could not be checked by a single build.+library serialize+  import: shared-properties+  visibility: public+  hs-source-dirs: src-serialize+  exposed-modules:+    Moonlight.Hex.Serialization+    Moonlight.Triangulation.Serialization+  build-depends:+    base >= 4.19 && < 5+    , binary >= 0.8 && < 0.9+    , bytestring >= 0.12 && < 0.13+    , containers >= 0.8 && < 0.9+    , deepseq >= 1.5 && < 1.6+    , transformers >= 0.6 && < 0.7+    , vector >= 0.13 && < 0.14+    , moonlight-planar:hex+    , moonlight-planar:core+    , moonlight-planar:dcel-internal+    , moonlight-planar:storage-internal+  -- The @Binary@ instances for the identifier and point types are orphans by+  -- construction: the types belong to @dcel@ and the class to @binary@, and the+  -- whole purpose of this component is that neither one has to know about the+  -- other.  Rehoming them would pull @binary@ into the core and defeat the split.+  ghc-options: -fexpose-all-unfoldings -Wno-orphans++library dual+  import: shared-properties+  visibility: public+  hs-source-dirs: src-dual+  exposed-modules:+    Moonlight.Triangulation.Voronoi+    Moonlight.Triangulation.Voronoi.Handles+    Moonlight.Triangulation.Interpolation+  other-modules:+    Moonlight.Triangulation.Internal.InterpolationWorkspace+  build-depends:+    base >= 4.19 && < 5+    , deepseq >= 1.5 && < 1.6+    , primitive >= 0.9 && < 0.10+    , vector >= 0.13 && < 0.14+    , moonlight-planar:core+    , moonlight-planar:dcel-internal+  ghc-options: -fexpose-all-unfoldings++-- Package-private overlay machine room. The main library and package-owned+-- oracle tests share these exact modules; external consumers receive only the+-- public embedding certifier and Overlay equations reexported across this wall.+library overlay-internal+  import: shared-properties+  visibility: private+  hs-source-dirs: src-overlay+  exposed-modules:+    Moonlight.Triangulation.Embedding+    Moonlight.Triangulation.Internal.Overlay.Arrangement+    Moonlight.Triangulation.Internal.Overlay.Resident+    Moonlight.Triangulation.Internal.Overlay.Types+  build-depends:+    base >= 4.19 && < 5+    , containers >= 0.8 && < 0.9+    , deepseq >= 1.5 && < 1.6+    , vector >= 0.13 && < 0.14+    , moonlight-planar:core+    , moonlight-planar:dcel-internal+    , moonlight-planar:build-internal+    , moonlight-planar:storage-internal++library+  import: shared-properties+  hs-source-dirs:+    src-public+  exposed-modules:+    Moonlight.Hex.Planar+    Moonlight.Triangulation+    Moonlight.Triangulation.HintGenerator+    Moonlight.Triangulation.Minkowski+    Moonlight.Triangulation.Overlay+    Moonlight.Triangulation.PowerDiagram+    Moonlight.Triangulation.RegularAlpha+  -- The default library is the broad surface. Scoped/owning handles are the safe+  -- path; Dcel is the explicitly unchecked fixed-index kernel. These are the+  -- exact focused-component modules, not facade copies.+  reexported-modules:+    Moonlight.Triangulation.Alpha+    , 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.Canonical+    , Moonlight.Triangulation.Payload+    , Moonlight.Triangulation.JoinSemilattice+    , Moonlight.Triangulation.Handles.HandleDefs+    , Moonlight.Triangulation.Handles.Dynamic+    , Moonlight.Triangulation.Handles.Scoped+    , Moonlight.Triangulation.Handles.Iterators.DynamicIterators+    , Moonlight.Triangulation.Handles.Iterators.FixedIterators+    , Moonlight.Triangulation.Handles.Iterators.HullIterator+    , Moonlight.Triangulation.PointLocation+    , Moonlight.Triangulation.Validation+    , Moonlight.Triangulation.FloodFillIterator+    , Moonlight.Triangulation.IntersectionIterator+    , Moonlight.Triangulation.BulkLoad+    , Moonlight.Triangulation.Removal+    , Moonlight.Triangulation.Session+    , Moonlight.Triangulation.Cdt+    , Moonlight.Triangulation.Refinement+    , Moonlight.Triangulation.SetAlgebra+    , Moonlight.Triangulation.Voronoi+    , Moonlight.Triangulation.Voronoi.Handles+    , Moonlight.Triangulation.Interpolation+    , Moonlight.Triangulation.Embedding+  other-modules:+    Moonlight.Triangulation.Internal.Minkowski.Convex+    Moonlight.Triangulation.Internal.Minkowski.Types+    Moonlight.Triangulation.Internal.PowerDiagram.Edit+    Moonlight.Triangulation.Internal.PowerDiagram.Generator+    Moonlight.Triangulation.Internal.PowerDiagram.Hull+    Moonlight.Triangulation.Internal.PowerDiagram.Locality+    Moonlight.Triangulation.Internal.PowerDiagram.Model+    Moonlight.Triangulation.Internal.PowerDiagram.Projection+    Moonlight.Triangulation.Internal.PowerDiagram.Section+  build-depends:+    base >= 4.19 && < 5+    , containers >= 0.8 && < 0.9+    , deepseq >= 1.5 && < 1.6+    , vector >= 0.13 && < 0.14+    , moonlight-planar:hex+    , moonlight-planar:core+    , moonlight-planar:dcel-internal+    , moonlight-planar:build-internal+    , moonlight-planar:dual+    , moonlight-planar:overlay-internal+    , moonlight-planar:storage-internal+  ghc-options: -fexpose-all-unfoldings++library ffi+  import: shared-properties+  visibility: private+  hs-source-dirs: ffi/abi+  exposed-modules:+    Moonlight.Triangulation.Foreign.Boundary+    Moonlight.Triangulation.Foreign.Contract+    Moonlight.Triangulation.Foreign.Contract.Render+    Moonlight.Triangulation.Foreign.Mesh+    Moonlight.Triangulation.Foreign.Morphology+    Moonlight.Triangulation.Foreign.Obstruction+    Moonlight.Triangulation.Foreign.Region+  build-depends:+    base >= 4.19 && < 5+    , containers >= 0.8 && < 0.9+    , vector >= 0.13 && < 0.14+    , moonlight-planar+    , moonlight-planar:build-internal+    , moonlight-planar:dcel-internal++foreign-library moonlight-triangulation-c+  import: shared-properties+  type: native-shared+  hs-source-dirs: ffi/exports+  other-modules:+    Moonlight.Triangulation.Foreign.Exports+  c-sources:+    ffi/cbits/moonlight_runtime.c+  include-dirs:+    ffi/include+  install-includes:+    moonlight_triangulation.h+  build-depends:+    base >= 4.19 && < 5+    , moonlight-planar:ffi >= 1.0 && < 1.1+  ghc-options: -threaded+  if os(windows)+    options: standalone+    mod-def-file: ffi/cbits/moonlight-triangulation.def+  else+    extra-libraries: pthread+  if os(linux)+    lib-version-info: 2:0:0++executable moonlight-triangulation-ffi-contract+  import: shared-properties+  hs-source-dirs: ffi/generator+  main-is: Main.hs+  build-depends:+    base >= 4.19 && < 5+    , directory >= 1.3 && < 1.4+    , filepath >= 1.4 && < 1.6+    , moonlight-planar:ffi >= 1.0 && < 1.1++-- ── test slices ──────────────────────────────────────────────────────────────++-- Each slice is an ATOM: a @common@ stanza binding a spec module to the+-- dependencies and RTS options that module requires.  A suite is then a choice+-- of atoms and nothing more.  The coherence component below imports every atom+-- and therefore checks their combined module, instance, and dependency surface+-- without running every behavioral suite a second time.++common triangulation-test-properties+  import: shared-properties+  ghc-options: -O0+  build-depends:+    base >= 4.19 && < 5+    , vector >= 0.13 && < 0.14+    , moonlight-planar++common triangulation-test-support-slice+  other-modules: Support++common triangulation-native-test-slice+  other-modules:+    Moonlight.Triangulation.NativeSpec+    Moonlight.Triangulation.FilteredPredicateOptimizationSpec+    Moonlight.Triangulation.ExactEmbeddingSpec+    Moonlight.Triangulation.OverlaySpec+    Moonlight.Triangulation.RegionSpec+  -- The RTS options this module needs are named on the SUITES rather than+  -- here, which is the one place the slice-owns-its-requirements rule cannot+  -- hold.  @-with-rtsopts@ is CONCATENATED by GHC across repetitions, so a+  -- suite importing two slices that both name it links a binary whose RTS+  -- string is the two spliced together — @-N4 -T-N4 -T@ — which the RTS+  -- discards whole, silently disarming both.  It must appear exactly once per+  -- suite, so @triangulation-suite-rtsopts@ below carries it.+  ghc-options: -threaded -rtsopts+  build-depends:+    containers >= 0.8 && < 0.9+    , deepseq >= 1.5 && < 1.6+    , primitive >= 0.9 && < 0.10+    , moonlight-planar:core+    , moonlight-planar:dcel-internal+    , moonlight-planar:build-internal+    , moonlight-planar:dual+    , moonlight-planar:overlay-internal+    , moonlight-planar:storage-internal++common triangulation-serialization-test-slice+  other-modules: Moonlight.Triangulation.SerializationSpec+  build-depends:+    binary >= 0.8 && < 0.9+    , bytestring >= 0.12 && < 0.13+    , deepseq >= 1.5 && < 1.6+    , moonlight-planar:dcel-internal+    , moonlight-planar:serialize++-- The operand meshes both algebra slices are stated over.  It sits at the+-- surface tier with them, so the fixtures cannot quietly acquire a+-- machine-room dependency that the law slice would then inherit.+common triangulation-algebra-fixture-slice+  other-modules: Moonlight.Triangulation.AlgebraFixtures+  build-depends: containers >= 0.8 && < 0.9++-- The finite-set laws, stated against the facade a caller has.+common triangulation-algebra-law-slice+  other-modules: Moonlight.Triangulation.AlgebraSpec+  build-depends: containers >= 0.8 && < 0.9++-- 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-planar:core+    , moonlight-planar:dcel-internal++common triangulation-minkowski-law-slice+  other-modules: Moonlight.Triangulation.MinkowskiSpec+  build-depends:+    moonlight-planar:core+    , moonlight-planar:dcel-internal++-- A test-only endpoint-reconstruction oracle demonstrating why the production+-- clipping owner retains original affine source lines.+common triangulation-exact-clip-retention-law-slice+  other-modules: Moonlight.Triangulation.ExactClipRetentionSpec+  build-depends:+    moonlight-planar:core+    , moonlight-planar:dcel-internal++common triangulation-power-diagram-law-slice+  other-modules: Moonlight.Triangulation.PowerDiagramSpec+  build-depends:+    containers >= 0.8 && < 0.9+    , moonlight-planar:core+    , moonlight-planar:dcel-internal++common triangulation-layer-operations-law-slice+  other-modules: Moonlight.Triangulation.LayerOperationsSpec+  build-depends:+    containers >= 0.8 && < 0.9+    , moonlight-planar:core+    , moonlight-planar:dcel-internal++-- The agreement between the seam schedule and the reference rebuild.  It names+-- an internal schedule, so it reaches below the wall and travels with the+-- schedule it names: a replacement kernel carries its own copy of this.+common triangulation-algebra-schedule-slice+  other-modules: Moonlight.Triangulation.ScheduleAgreementSpec+  build-depends: moonlight-planar:build-internal++common triangulation-parallel-test-slice+  other-modules: Moonlight.Triangulation.ParallelSpec+  ghc-options: -threaded -rtsopts+  build-depends: moonlight-planar:parallel++test-suite moonlight-triangulation-cell-complex-test+  import: shared-properties+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: test/cell-complex+  default-extensions:+    TypeFamilies+  if impl(ghc < 9.14)+    buildable: False+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , moonlight-homology >= 0.1.0.2 && < 0.2+    , moonlight-homology:cell-complex >= 0.1.0.2 && < 0.2+    , moonlight-planar:hex+    , moonlight-planar:core+    , moonlight-planar:build-internal+    , moonlight-planar:cell-complex+    , moonlight-planar:dcel-internal+    , tasty >= 1.4 && < 1.6+    , tasty-hunit >= 0.10 && < 0.11+    , vector >= 0.13 && < 0.14++-- Public activation ingestion, labelled adjacent-union correspondences, and+-- exact non-monotone persistence, including its compiled documentation path.+test-suite moonlight-triangulation-zigzag-test+  import: shared-properties+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    test/zigzag+    docs/examples+  other-modules:+    Moonlight.Triangulation.Example.ActivationZigzag+  if impl(ghc < 9.14)+    buildable: False+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , moonlight-homology >= 0.1.0.3 && < 0.2+    , moonlight-planar:dcel+    , moonlight-planar:zigzag+    , tasty >= 1.4 && < 1.6+    , tasty-hunit >= 0.10 && < 0.11+    , vector >= 0.13 && < 0.14++-- Canonical documentation examples compile exclusively against the public+-- facade and retain their expected semantic summaries as executable checks.+test-suite moonlight-triangulation-examples-test+  import: triangulation-test-properties+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    test/examples+    docs/examples+  other-modules:+    Moonlight.Triangulation.Example.AlphaBoundary+    Moonlight.Triangulation.Example.ConstrainedRegion+    Moonlight.Triangulation.Example.PlanarRegion+    Moonlight.Triangulation.Example.SetAlgebra+  build-depends: containers >= 0.8 && < 0.9++-- One behavioral owner for exact clipping, power cells, morphology, affine+-- envelopes, coverage, n-ary overlay, and mass. The law slices remain+-- independently reusable by the compile-only coherence component.+test-suite moonlight-triangulation-exact-planar-test+  import:+    triangulation-test-properties,+    triangulation-test-support-slice,+    triangulation-algebra-fixture-slice,+    triangulation-exact-clip-retention-law-slice,+    triangulation-minkowski-law-slice,+    triangulation-power-diagram-law-slice,+    triangulation-layer-operations-law-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    test/exact-planar+    test/algebra+    test/support++-- A real external shape over only the two focused public components. It proves+-- that immutable observation and construction/editing compose without either+-- the broad facade or a private implementation token.+test-suite moonlight-triangulation-public-components-test+  import: shared-properties+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: test/public-components+  build-depends:+    base >= 4.19 && < 5+    , vector >= 0.13 && < 0.14+    , moonlight-planar:dcel+    , moonlight-planar:build++-- Native coordinate, element, finite-set, descent/gluing, exact-publication,+-- and serialization laws through public component boundaries only.+test-suite moonlight-planar-hex-test+  import: shared-properties+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: test/hex+  ghc-options: -O0+  build-depends:+    base >= 4.19 && < 5+    , bytestring >= 0.12 && < 0.13+    , containers >= 0.8 && < 0.9+    , moonlight-planar+    , moonlight-planar:hex+    , moonlight-planar:serialize+    , vector >= 0.13 && < 0.14++-- One pure, source-grounded projection of the alpha, dual, interpolation,+-- planar-algebra, and persistence owners. The test shares the internal exhibit+-- module; neither component creates a public visualization API.+test-suite moonlight-triangulation-persistence-rose-test+  import: shared-properties+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    test/persistence-rose+    docs/persistence-rose+  other-modules:+    Moonlight.Triangulation.Exhibit.PersistenceRose+  if impl(ghc < 9.14)+    buildable: False+  build-depends:+    base >= 4.22 && < 5+    , bytestring >= 0.12 && < 0.13+    , containers >= 0.6 && < 0.9+    , moonlight-homology >= 0.1.0.2 && < 0.2+    , moonlight-planar+    , moonlight-planar:cell-complex+    , moonlight-planar:dcel-internal+    , moonlight-planar:dual+    , tasty >= 1.4 && < 1.6+    , tasty-hunit >= 0.10 && < 0.11+    , text >= 2.0 && < 2.2+    , vector >= 0.13 && < 0.14++-- The single statement of the RTS environment every suite runs under: -N so+-- that the concurrent tournament has more than one capability to be scheduled+-- onto, -T so that the filtered-predicate test can read allocation counters.+-- It is one stanza rather than a line on each slice because @-with-rtsopts@+-- concatenates rather than replaces, so naming it twice in one suite produces+-- a spliced string the RTS rejects entirely.  Every behavioral suite that+-- needs those capabilities imports this exactly once; the compile-only+-- coherence suite deliberately installs no runtime defaults.+common triangulation-suite-rtsopts+  ghc-options: -threaded -rtsopts "-with-rtsopts=-N4 -T"++test-suite moonlight-triangulation-native-test+  import:+    triangulation-suite-rtsopts,+    triangulation-test-properties,+    triangulation-test-support-slice,+    triangulation-native-test-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    test/native+    test/support++test-suite moonlight-triangulation-serialization-test+  import:+    triangulation-test-properties,+    triangulation-test-support-slice,+    triangulation-serialization-test-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    test/serialization+    test/support++test-suite moonlight-triangulation-algebra-test+  import:+    triangulation-test-properties,+    triangulation-test-support-slice,+    triangulation-algebra-fixture-slice,+    triangulation-algebra-law-slice,+    triangulation-region-algebra-law-slice,+    triangulation-valuation-law-slice,+    triangulation-algebra-schedule-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    test/algebra+    test/support++test-suite moonlight-triangulation-parallel-test+  import:+    triangulation-suite-rtsopts,+    triangulation-test-properties,+    triangulation-test-support-slice,+    triangulation-algebra-fixture-slice,+    triangulation-parallel-test-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    test/parallel+    test/algebra+    test/support++test-suite moonlight-triangulation-ffi-test+  import: shared-properties+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: test/ffi+  build-depends:+    base >= 4.19 && < 5+    , moonlight-planar:ffi++-- This component owns only cross-slice compile coherence.  Behavioral ownership+-- remains in focused suites.  The shared test-properties stanza keeps+-- every test body at @-O0@, so the union retains type/module/instance collision+-- detection without paying to optimize a second copy of every test body.+test-suite moonlight-triangulation-coherence-test+  import:+    triangulation-test-properties,+    triangulation-test-support-slice,+    triangulation-native-test-slice,+    triangulation-serialization-test-slice,+    triangulation-algebra-fixture-slice,+    triangulation-algebra-law-slice,+    triangulation-region-algebra-law-slice,+    triangulation-valuation-law-slice,+    triangulation-minkowski-law-slice,+    triangulation-exact-clip-retention-law-slice,+    triangulation-power-diagram-law-slice,+    triangulation-layer-operations-law-slice,+    triangulation-algebra-schedule-slice,+    triangulation-parallel-test-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    test/coherence+    test/native+    test/serialization+    test/algebra+    test/parallel+    test/support++-- ── benchmark slices ─────────────────────────────────────────────────────────+-- Deliberately not @tasty-bench@: these report allocated bytes and the work+-- counters the library keeps about itself — hierarchy walk steps, refinement+-- queue pops, bytes per interpolation query — and a wall-clock harness cannot+-- express any of them.  @core@ and @serialize@ carry no benchmark today; that is+-- stated rather than filled with an invented one.++common triangulation-benchmark-properties+  import: shared-properties+  -- The allocation arms read GHC.Stats, which is dark without -T.  As with the+  -- test suites, @-with-rtsopts@ is CONCATENATED by GHC across repetitions, so+  -- it must appear exactly once per benchmark: this stanza is that one place,+  -- and no benchmark slice may name it again.+  ghc-options: -threaded -rtsopts "-with-rtsopts=-T"+  build-depends:+    base >= 4.19 && < 5+    , deepseq >= 1.5 && < 1.6+    , vector >= 0.13 && < 0.14+    , moonlight-planar++common triangulation-benchmark-support-slice+  other-modules:+    BenchMeasure+    BenchSupport+  build-depends: moonlight-planar:dcel-internal++common triangulation-build-benchmark-slice+  other-modules: Moonlight.Triangulation.BuildBench+  build-depends:+    primitive >= 0.9 && < 0.10+    , moonlight-planar:dcel-internal+    , moonlight-planar:build-internal+    , moonlight-planar:ffi++common triangulation-dcel-benchmark-slice+  other-modules: Moonlight.Triangulation.DcelBench+  build-depends: moonlight-planar:dcel-internal++common triangulation-dual-benchmark-slice+  other-modules: Moonlight.Triangulation.DualBench+  build-depends: moonlight-planar:dual++common triangulation-join-benchmark-slice+  other-modules: Moonlight.Triangulation.JoinBench+  build-depends:+    containers >= 0.8 && < 0.9+    , moonlight-planar:core+    , moonlight-planar:dcel-internal+    , moonlight-planar:build-internal+    , moonlight-planar:storage-internal++common triangulation-region-benchmark-slice+  other-modules: Moonlight.Triangulation.RegionBench+  build-depends:+    containers >= 0.8 && < 0.9+    , moonlight-planar:core+    , moonlight-planar:dcel-internal++-- The package-owned external construction board deliberately uses tasty-bench:+-- unlike the native work-counter slices above, its only lawful common metric+-- across Haskell and four Rust referents is elapsed or CPU time.  The Rust+-- crate is a foreign adapter; Moonlight owns the case algebra, agreement+-- descent, timing, receipt parser, and derived pictures here.+common triangulation-delaunay-compare-properties+  import: shared-properties+  ghc-options: -O2+  build-depends:+    base >= 4.19 && < 5+    , deepseq >= 1.5 && < 1.6+    , moonlight-planar:build-internal+    , moonlight-planar:dcel-internal++executable moonlight-triangulation-delaunay-compare+  import: triangulation-delaunay-compare-properties+  ghc-options: -threaded -rtsopts+  main-is: Main.hs+  hs-source-dirs: docs/delaunay-compare+  other-modules:+    Moonlight.Triangulation.Bench.DelaunayCompare.Domain+    Moonlight.Triangulation.Bench.DelaunayCompare.Native+    Moonlight.Triangulation.Bench.DelaunayCompare.Suite+  build-depends:+    directory >= 1.3 && < 1.4+    , filepath >= 1.4 && < 1.6+    , process >= 1.6 && < 1.7+    , tasty-bench >= 0.3 && < 0.6+    , transformers >= 0.5 && < 0.7+    , unix >= 2.8 && < 2.9+    , vector >= 0.13 && < 0.14++executable moonlight-triangulation-delaunay-pictures+  import: triangulation-delaunay-compare-properties+  main-is: PictureMain.hs+  hs-source-dirs: docs/delaunay-compare+  other-modules:+    Moonlight.Triangulation.Bench.DelaunayCompare.Domain+    Moonlight.Triangulation.Bench.DelaunayCompare.Picture+  build-depends:+    containers >= 0.8 && < 0.9+    , directory >= 1.3 && < 1.4+    , filepath >= 1.4 && < 1.6+    , transformers >= 0.5 && < 0.7++executable moonlight-triangulation-category-observatory-export+  import: shared-properties+  main-is: Main.hs+  hs-source-dirs: docs/category-observatory+  other-modules:+    Moonlight.Triangulation.Exhibit.CategoryObservatory+    Moonlight.Triangulation.Exhibit.CategoryObservatory.Category+    Moonlight.Triangulation.Exhibit.CategoryObservatory.Geometry+    Moonlight.Triangulation.Exhibit.CategoryObservatory.Identifier+    Moonlight.Triangulation.Exhibit.CategoryObservatory.Model+    Moonlight.Triangulation.Exhibit.CategoryObservatory.Nerve+    Moonlight.Triangulation.Exhibit.CategoryObservatory.Picture+  ghc-options: -Wall -Wcompat+  default-extensions:+    TypeFamilies+  if impl(ghc < 9.14)+    buildable: False+  build-depends:+    aeson >= 2.2 && < 2.4+    , base >= 4.22 && < 5+    , bytestring >= 0.12 && < 0.13+    , containers >= 0.6 && < 0.9+    , directory >= 1.3 && < 1.4+    , filepath >= 1.4 && < 1.6+    , moonlight-category >= 1.1.0.0 && < 1.2+    , moonlight-category:simplicial >= 1.1.0.0 && < 1.2+    , moonlight-homology:cell-category >= 0.1.0.2 && < 0.2+    , moonlight-homology:cell-complex >= 0.1.0.2 && < 0.2+    , moonlight-planar:build-internal+    , moonlight-planar:cell-complex+    , moonlight-planar:dcel-internal+    , transformers >= 0.5 && < 0.7+    , vector >= 0.13 && < 0.14++executable moonlight-triangulation-persistence-rose+  import: shared-properties+  main-is: Main.hs+  hs-source-dirs: docs/persistence-rose+  other-modules:+    Moonlight.Triangulation.Exhibit.PersistenceRose+  if impl(ghc < 9.14)+    buildable: False+  build-depends:+    base >= 4.22 && < 5+    , bytestring >= 0.12 && < 0.13+    , containers >= 0.6 && < 0.9+    , directory >= 1.3 && < 1.4+    , filepath >= 1.4 && < 1.6+    , moonlight-homology >= 0.1.0.2 && < 0.2+    , moonlight-planar+    , moonlight-planar:cell-complex+    , moonlight-planar:dcel-internal+    , moonlight-planar:dual+    , text >= 2.0 && < 2.2+    , transformers >= 0.5 && < 0.7+    , vector >= 0.13 && < 0.14++-- These referent instruments inspect package-internal handles and thaw/freeze+-- lanes. They belong to the triangulation package rather than reopening its+-- private construction boundary through a second package.+executable moonlight-triangulation-spade-referent+  default-language: GHC2024+  ghc-options:+    -Wall+    -Wcompat+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wredundant-constraints+    -Wpartial-fields+    -O2+    -rtsopts+  default-extensions:+    BangPatterns+    LambdaCase+    NumericUnderscores+  hs-source-dirs: bench/spade-compare/hs+  main-is: Main.hs+  -- Main is the entry and the lane dispatch; every workload, gate and+  -- diagnostic sits in the domain module that owns it. The domains depend on+  -- SpadeCompare.Support and on nothing else of each other, so they compile in+  -- parallel and a lane edit rebuilds one slice.+  other-modules:+    Moonlight.Triangulation.Bench.SpadeCompare.Lane+    Moonlight.Triangulation.Bench.SpadeCompare.Input+    Moonlight.Triangulation.Bench.SpadeCompare.Timing+    Moonlight.Triangulation.Bench.SpadeCompare.Support+    Moonlight.Triangulation.Bench.SpadeCompare.Delaunay+    Moonlight.Triangulation.Bench.SpadeCompare.Removal+    Moonlight.Triangulation.Bench.SpadeCompare.Hierarchy+    Moonlight.Triangulation.Bench.SpadeCompare.Constraint+    Moonlight.Triangulation.Bench.SpadeCompare.Interpolation+    Moonlight.Triangulation.Bench.SpadeCompare.Voronoi+    Moonlight.Triangulation.Bench.SpadeCompare.Dcel+    Moonlight.Triangulation.Bench.SpadeCompare.Intersection+    Moonlight.Triangulation.Bench.SpadeCompare.Gates+  build-depends:+    base >= 4.22 && < 5+    , deepseq >= 1.4 && < 1.6+    , directory >= 1.3 && < 1.4+    , filepath >= 1.4 && < 1.6+    , vector >= 0.13 && < 0.14+    , primitive >= 0.9 && < 0.10+    , moonlight-planar+    , moonlight-planar:dcel-internal+    , moonlight-planar:build-internal+    , moonlight-planar:dual++-- The alpha comparison is deliberately opt-in: ordinary scorecard listing and+-- replay do not inherit Homology merely because this diagnostic exists beside+-- the canonical board.+executable moonlight-triangulation-alpha-spade-referent+  default-language: GHC2024+  ghc-options:+    -Wall+    -Wcompat+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wredundant-constraints+    -Wpartial-fields+    -O2+    -rtsopts+  default-extensions:+    BangPatterns+    LambdaCase+    NumericUnderscores+  hs-source-dirs:+    bench/spade-compare/hs-alpha+    bench/spade-compare/hs+  main-is: Main.hs+  other-modules:+    Moonlight.Triangulation.Bench.SpadeCompare.Alpha+    Moonlight.Triangulation.Bench.SpadeCompare.Input+    Moonlight.Triangulation.Bench.SpadeCompare.Lane+    Moonlight.Triangulation.Bench.SpadeCompare.Timing+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , deepseq >= 1.4 && < 1.6+    , vector >= 0.13 && < 0.14+    , moonlight-homology >= 0.1 && < 0.2+    , moonlight-planar:build-internal+    , moonlight-planar:cell-complex+    , moonlight-planar:dcel-internal++-- One exact Delaunay alpha filtration versus independently restricting and+-- reducing the same chain complex at every critical radius. Construction of+-- the shared Delaunay geometry is outside all timed lanes.+benchmark moonlight-triangulation-alpha-bench+  import:+    shared-properties,+    triangulation-benchmark-support-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    bench/alpha+    bench/support+  ghc-options: -threaded -rtsopts "-with-rtsopts=-T"+  if impl(ghc < 9.14)+    buildable: False+  build-depends:+    base >= 4.22 && < 5+    , containers >= 0.6 && < 0.9+    , deepseq >= 1.5 && < 1.6+    , moonlight-homology >= 0.1.0.2 && < 0.2+    , moonlight-planar+    , moonlight-planar:build-internal+    , moonlight-planar:cell-complex+    , moonlight-planar:dcel-internal+    , vector >= 0.13 && < 0.14++-- Exact bounded power-cell construction.  Tasty-bench owns the timing+-- distribution; the benchmark's one-shot report derives boundary/intersection and+-- rational-width receipts from the public power-diagram result.+benchmark moonlight-triangulation-power-bench+  import:+    triangulation-benchmark-properties,+    triangulation-benchmark-support-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    bench/power+    bench/support+  other-modules:+    Moonlight.Triangulation.PowerBench+  build-depends:+    containers >= 0.6 && < 0.9+    , tasty-bench >= 0.3 && < 0.6++-- Exact affine-envelope construction, balanced n-ary refinement, and direct+-- cell analytics against the public compositions callers would otherwise+-- materialize by hand.+benchmark moonlight-triangulation-layer-bench+  import:+    triangulation-benchmark-properties,+    triangulation-benchmark-support-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    bench/layer+    bench/support+  other-modules:+    Moonlight.Triangulation.LayerBench+  build-depends:+    containers >= 0.8 && < 0.9+    , tasty-bench >= 0.3 && < 0.6++benchmark moonlight-triangulation-build-bench+  import:+    triangulation-benchmark-properties,+    triangulation-benchmark-support-slice,+    triangulation-build-benchmark-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    bench/build+    bench/support++benchmark moonlight-triangulation-dcel-bench+  import:+    triangulation-benchmark-properties,+    triangulation-benchmark-support-slice,+    triangulation-dcel-benchmark-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    bench/dcel+    bench/support++benchmark moonlight-triangulation-dual-bench+  import:+    triangulation-benchmark-properties,+    triangulation-benchmark-support-slice,+    triangulation-dual-benchmark-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    bench/dual+    bench/support++benchmark moonlight-triangulation-join-bench+  import:+    triangulation-benchmark-properties,+    triangulation-benchmark-support-slice,+    triangulation-join-benchmark-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    bench/join+    bench/support++benchmark moonlight-triangulation-publication-bench+  import:+    triangulation-benchmark-properties,+    triangulation-benchmark-support-slice,+    triangulation-join-benchmark-slice+  type: exitcode-stdio-1.0+  main-is: PublicationMain.hs+  hs-source-dirs:+    bench/publication+    bench/join+    bench/support++benchmark moonlight-triangulation-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++-- Packed native finite-set kernels. The measurement module is shared, but the+-- component depends on no triangulation, DCEL, overlay, or Homology library.+benchmark moonlight-planar-hex-bench+  import: shared-properties+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    bench/hex+    bench/support+  other-modules: BenchMeasure+  ghc-options: -O2 -threaded -rtsopts "-with-rtsopts=-T"+  build-depends:+    base >= 4.19 && < 5+    , deepseq >= 1.5 && < 1.6+    , moonlight-planar:hex++benchmark moonlight-triangulation-bench+  import:+    triangulation-benchmark-properties,+    triangulation-benchmark-support-slice,+    triangulation-build-benchmark-slice,+    triangulation-dcel-benchmark-slice,+    triangulation-dual-benchmark-slice,+    triangulation-join-benchmark-slice,+    triangulation-region-benchmark-slice+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+    bench/aggregate+    bench/build+    bench/dcel+    bench/dual+    bench/join+    bench/region+    bench/support
+ src-build/Moonlight/Triangulation/BulkLoad.hs view
@@ -0,0 +1,14 @@+-- | Whole-support construction and persistent incremental insertion.+module Moonlight.Triangulation.BulkLoad+  ( empty+  , clear+  , delaunay+  , delaunayGeometry+  , DuplicatePayloadPolicy (..)+  , delaunayFromCoordinates+  , insert+  , insertAt+  , insertMany+  ) where++import Moonlight.Triangulation.Internal.BulkLoad
+ src-build/Moonlight/Triangulation/Cdt.hs view
@@ -0,0 +1,119 @@+-- | The constraint layer: the partial map from sites and segments, defined+-- exactly on realizable segment sets and naming its witness where it is not.+module Moonlight.Triangulation.Cdt+  ( ConstrainedDelaunayTriangulation+  , CdtError (..)+  , CorridorObstruction (..)+  , ConstraintRecoveryResult (..)+  , ConstraintResult+  , ConstraintOutcome (..)+  , ConstraintBatchStats (..)+  , ConstraintBatchResult (..)+  , ConstrainedExtensionResult (..)+  , ConstrainedSeamSide (..)+  , ConstrainedSeamFaceEvidence+  , constrainedSeamSourceFace+  , constrainedSeamTargetFace+  , constrainedSeamFaceFirstPoint+  , constrainedSeamFaceSecondPoint+  , constrainedSeamFaceThirdPoint+  , ConstrainedSeamResult+  , constrainedSeamResultTriangulation+  , constrainedSeamLeftFaceCount+  , constrainedSeamRightFaceEvidence+  , constrainedSeamJoinFaces+  , constrainedSeamLeftConstraintCount+  , constrainedSeamConstraintStats+  , constrainedSeamBuildStats+  , constrainedSeamPublicationStats+  , constrainedSeamCachedFrontierPointReads+  , ConstraintSplitBatchResult+  , CdtBuildResult (..)+  , constrainedDelaunay+  , constrainedDelaunayMaximal+  , fromDelaunay+  , constraintEdges+  , CanonicalSegment+  , segmentStart+  , segmentEnd+  , ConstraintConflict+  , conflictFirstSegment+  , conflictSecondSegment+  , ConstrainedUnionError (..)+  , constraintSegments+  , unionConstrainedWith+  , unionConstrained+  , joinSeparatedConstrained+  , extendConstrainedWith+  , constraintStorageBytes+  , existsConstraint+  , canAddConstraint+  , intersectsConstraint+  , getConflictingEdgesBetweenPoints+  , getConflictingEdgesBetweenVertices+  , recoverConstraints+  , addConstraintEdge+  , addConstraintEdges+  , addConstraintAndSplit+  , addConstraintsAndSplit+  , removeConstraintEdge+  , outerRegionFaces+  , boundedRegionFaces+  ) where++import Moonlight.Triangulation.Internal.Cdt.Batch (recoverConstraints)+import Moonlight.Triangulation.Internal.Cdt.Build+  ( constrainedDelaunay+  , constrainedDelaunayMaximal+  , fromDelaunay+  )+import Moonlight.Triangulation.Internal.Cdt.Query+  ( canAddConstraint+  , constraintEdges+  , constraintStorageBytes+  , existsConstraint+  , getConflictingEdgesBetweenPoints+  , getConflictingEdgesBetweenVertices+  , intersectsConstraint+  )+import Moonlight.Triangulation.Internal.Cdt.Region+  ( boundedRegionFaces+  , outerRegionFaces+  )+import Moonlight.Triangulation.Internal.Cdt.Segment+  ( addConstraintEdge+  , addConstraintEdges+  , removeConstraintEdge+  )+import Moonlight.Triangulation.Internal.Cdt.Split+  ( addConstraintAndSplit+  , addConstraintsAndSplit+  )+import Moonlight.Triangulation.Internal.Cdt.Types+  ( CanonicalSegment (..)+  , CdtBuildResult (..)+  , CdtError (..)+  , ConstrainedUnionError (..)+  , ConstraintBatchResult (..)+  , ConstraintBatchStats (..)+  , ConstrainedExtensionResult (..)+  , ConstrainedSeamSide (..)+  , ConstrainedSeamFaceEvidence (..)+  , ConstrainedSeamResult (..)+  , ConstraintConflict (..)+  , ConstraintOutcome (..)+  , ConstraintRecoveryResult (..)+  , ConstraintResult+  , ConstraintSplitBatchResult+  , CorridorObstruction (..)+  )+import Moonlight.Triangulation.Internal.Cdt.Union+  ( constraintSegments+  , extendConstrainedWith+  , joinSeparatedConstrained+  , unionConstrained+  , unionConstrainedWith+  )+import Moonlight.Triangulation.Internal.Representation+  ( ConstrainedDelaunayTriangulation+  )
+ src-build/Moonlight/Triangulation/Insertion.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Moonlight.Triangulation.Insertion+  ( insertExistingVertex+  , insertExistingVertexWithHint+  , insertPointCombining+  , insertAdmittedPointCombining+  , insertVertexAtPoint+  , insertExistingVertexAtLocation+  ) where++import Control.Monad.ST (ST)+import Moonlight.Triangulation.Internal.HandleDefs (VertexId (..))+import Moonlight.Triangulation.Internal.DcelOperations.Chain+  ( extendLine+  , lineToArea+  , setupFirstVertex+  , setupSecondVertex+  , splitLineEdge+  )+import Moonlight.Triangulation.Internal.DcelOperations.Hull (insertOutsideHull)+import Moonlight.Triangulation.Internal.DcelOperations.Subdivide+  ( insertIntoFace+  , insertOnEdge+  )+import Moonlight.Triangulation.Internal.Location+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  )+import Moonlight.Triangulation.Internal.Probe (KnownProbe, Probe (..))+import Moonlight.Triangulation.Internal.Predicates+import Moonlight.Triangulation.Math (validatePoint)+import Moonlight.Triangulation.Types++-- | Admit a raw site, then delegate to the shared admitted-site interpreter.+-- Geometry decides whether a site is new; callers choose only the annotation+-- law for an occupied site. Keeping raw admission and the common location,+-- placement, and counters in this one owner prevents sessions and constrained+-- extension from drifting into two insertion semantics merely because they own+-- different enclosing transactions.+insertPointCombining+  :: (vertex -> vertex -> vertex)+  -> Maybe Int+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Point+  -> vertex+  -> ST s (Either BuildError (Int, InsertionDisposition))+insertPointCombining combine seed mutable operation point payload =+  case validatePoint Nothing point of+    Left failure -> pure (Left failure)+    Right admitted ->+      insertAdmittedPointCombining combine seed mutable operation admitted payload+{-# INLINE insertPointCombining #-}++-- | Insert an already admitted site. The caller has retained the canonical+-- coordinate section, so this interpreter only locates and glues the payload;+-- it must not reopen coordinate admission.+insertAdmittedPointCombining+  :: (vertex -> vertex -> vertex)+  -> Maybe Int+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> QueryPoint+  -> vertex+  -> ST s (Either BuildError (Int, InsertionDisposition))+insertAdmittedPointCombining combine seed mutable operation queryPoint payload = do+  addCounter operation CounterInputPoints 1+  outcome <-+    insertVertexAtPoint+      @'ProbeOff+      mutable+      operation+      seed+      (queryPointValue queryPoint)+      payload+  case outcome of+    Left failure -> pure (Left failure)+    Right resolved@(vertex, disposition) -> do+      case disposition of+        AlreadyPresent -> do+          resident <- vertexDataAt mutable vertex+          writeVertexData mutable vertex (combine resident payload)+          addCounter operation CounterExistingPoints 1+          addCounter operation CounterDuplicatePoints 1+        Inserted -> addCounter operation CounterUniquePoints 1+      pure (Right resolved)+{-# INLINE insertAdmittedPointCombining #-}++insertExistingVertex+  :: forall p s vertex directed undirected face+   . KnownProbe p+  => MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> ST s (Either BuildError ())+insertExistingVertex mutable operation = insertExistingVertexWithHint @p mutable operation Nothing++-- | Insert a materialized vertex while beginning point location from a face+-- already known to be geometrically adjacent to the request. The hint changes+-- only the amount of walking; the located site remains authoritative.+insertExistingVertexWithHint+  :: forall p s vertex directed undirected face+   . KnownProbe p+  => MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Maybe Int+  -> Int+  -> ST s (Either BuildError ())+insertExistingVertexWithHint mutable operation hint vertex = do+  query <- pointAt mutable vertex+  located <- locateMutable mutable operation hint query+  case located of+    Left obstruction -> pure (Left obstruction)+    Right site -> insertExistingVertexAtLocation @p mutable operation vertex site++-- | Locate before materializing a point, so duplicate detection remains a+-- topological fact rather than a resident coordinate index.+insertVertexAtPoint+  :: forall p s vertex directed undirected face+   . KnownProbe p+  => MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Maybe Int+  -> Point+  -> vertex+  -> ST s (Either BuildError (Int, InsertionDisposition))+insertVertexAtPoint mutable operation hint point vertexData = do+  located <- locateMutable mutable operation hint point+  case located of+    Left obstruction -> pure (Left obstruction)+    Right (MutableOnVertex existing) -> pure (Right (existing, AlreadyPresent))+    Right site -> do+      capacity <- ensurePointCapacity mutable 1+      case capacity of+        Left obstruction -> pure (Left obstruction)+        Right () -> do+          vertex <- appendVertex mutable point vertexData+          inserted <- insertExistingVertexAtLocation @p mutable operation vertex site+          pure ((vertex, Inserted) <$ inserted)++-- | Interpret a point-location result without locating the same point again.+-- Callers may hold this witness only while no topology mutation intervenes.+--+-- The site decides which counts are consulted, and the vertex's own point is+-- read only by the two strata that compare against it — the degenerate line and+-- the failure report. The area strata already stand on a located site and would+-- otherwise rebuild a point the locate stage was handed.+insertExistingVertexAtLocation+  :: forall p s vertex directed undirected face+   . KnownProbe p+  => MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> MutableLocation+  -> ST s (Either BuildError ())+insertExistingVertexAtLocation mutable operation vertex located =+  case located of+    MutableOnVertex existing ->+      pure+        ( Left+            ( FreshInsertionMatchedExistingVertex+                (VertexId (fromIntegral vertex))+                (VertexId (fromIntegral existing))+            )+        )+    MutableEmpty -> do+      connected <- connectedCount mutable+      if connected == 0+        then setupFirstVertex mutable vertex >> pure (Right ())+        else locationFailed+    MutableOnEdge edge -> do+      faces <- faceCount mutable+      if faces <= 1+        then splitLineEdge mutable operation edge vertex+        else insertOnEdge @p mutable operation edge vertex+    MutableInFace face -> do+      faces <- faceCount mutable+      if faces <= 1+        then locationFailed+        else insertIntoFace @p mutable operation face vertex+    MutableOutsideHull edge -> do+      connected <- connectedCount mutable+      if connected == 1+        then setupSecondVertex mutable vertex+        else do+          faces <- faceCount mutable+          if faces <= 1+            then extendDegenerateLine edge+            else insertOutsideHull @p mutable operation edge vertex+ where+  extendDegenerateLine edge = do+    from <- edgeOriginPoint mutable edge+    to <- edgeOriginPoint mutable (edge `xorInt` 1)+    query <- pointAt mutable vertex+    if orient2d from to query == EQ+      then do+        endpoint <- readOrigin mutable edge+        extendLine mutable operation endpoint vertex+      else lineToArea @p mutable operation vertex++  locationFailed = do+    query <- pointAt mutable vertex+    pure (Left (PointLocationFailed query))++xorInt :: Int -> Int -> Int+xorInt value 1 = if even value then value + 1 else value - 1+xorInt value _ = value+{-# INLINE xorInt #-}
+ src-build/Moonlight/Triangulation/Internal/BulkLoad.hs view
@@ -0,0 +1,947 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# 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.+module Moonlight.Triangulation.Internal.BulkLoad+  ( empty+  , clear+  , delaunay+  , delaunayGeometry+  , DuplicatePayloadPolicy (..)+  , delaunayFromCoordinates+  , delaunayFromAdmittedDistinctAscending+  , insert+  , insertAt+  , insertMany+  ) where++import Control.Monad (forM_)+import Control.Monad.ST (ST, runST)+import qualified Data.IntSet as IntSet+import Data.Primitive.PrimArray+  ( MutablePrimArray+  , newPrimArray+  , readPrimArray+  , unsafeFreezePrimArray+  , writePrimArray+  )+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32)+import Moonlight.Triangulation.Dcel (numInnerFaces, numVertices)+import Moonlight.Triangulation.Internal.HandleDefs+  ( VertexId (..)+  , directedEdgeIdIndex+  , faceIdIndex+  , vertexIdIndex+  )+import Moonlight.Triangulation.Internal.BoxedPaged (boxedFromVector, boxedUpdate, emptyBoxedPaged)+import Moonlight.Triangulation.Internal.Capacity (ensureCapacity)+import Moonlight.Triangulation.Insertion (insertExistingVertexAtLocation, insertVertexAtPoint)+import Moonlight.Triangulation.Internal.Location (MutableLocation (..))+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , freezeBuildStats+  , newOperationState+  , setCounter+  )+import Moonlight.Triangulation.Internal.CircleSweep+  ( RadiallyOrderedArena+  , circleSweepInsert+  , radiallyOrderArena+  , radiallyOrderGeometry+  )+import Moonlight.Triangulation.Internal.PointIndex+  ( MutablePointIndex+  , emptyPointIndex+  , newMutablePointIndex+  , resolveMutablePoint+  , seedMutablePointIndex+  )+import Moonlight.Triangulation.Math (canonicalCoordinate, validatePoint)+import Moonlight.Triangulation.PointLocation (locatePointWithHint)+import Moonlight.Triangulation.Internal.Probe (Probe (..))+import Moonlight.Triangulation.Internal.Representation (Triangulation (..))+import Moonlight.Triangulation.Internal.PackedIndex (noIndex, unpackIndex)+import Moonlight.Triangulation.Internal.Paged (TransactionShape (DenseTransaction, LocalTransaction), emptyPaged, fromVector)+import Moonlight.Triangulation.Internal.Transaction (runTransaction)+import Moonlight.Triangulation.Types++-- | The vertexless triangulation: the outer face and nothing else. This is the+-- canonical origin of the type — bulk loading, incremental insertion and+-- refinement all agree with growing this value.+empty+  :: ElementDefaults directed undirected face+  -> Triangulation mode vertex directed undirected face+empty defaults@ElementDefaults{defaultDirectedEdgeData, defaultUndirectedEdgeData, defaultFaceData} =+  Triangulation+    { triPointX = emptyPaged+    , triPointY = emptyPaged+    , triPointIndex = emptyPointIndex+    , triVertexOut = emptyPaged+    , triVertexData = emptyBoxedPaged Nothing+    , triHalfTopology = emptyPaged+    , triDirectedData = emptyBoxedPaged (Just defaultDirectedEdgeData)+    , triUndirectedData = emptyBoxedPaged (Just defaultUndirectedEdgeData)+    , triFaceEdge = fromVector noIndex (U.singleton noIndex)+    , triFaceData = boxedFromVector (Just defaultFaceData) (V.singleton defaultFaceData)+    , triConstraint = emptyPaged+    , triConstraintCount = 0+    , triConstraintEdges = IntSet.empty+    , triSeamFrontier = Nothing+    , triElementDefaults = defaults+    }++-- | Discard every vertex while retaining the element defaults the+-- triangulation was built with.+clear+  :: Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex directed undirected face+clear = empty . triElementDefaults++-- | How a canonical bulk source combines payloads whose exact coordinates+-- coincide. Geometry identity is settled independently by the point index.+data DuplicatePayloadPolicy vertex+  = KeepFirstPayload+  | CombineDuplicatePayload !(vertex -> vertex -> vertex)++-- | The two lawful ingress sections for the one bulk construction engine.+-- Raw callers need coordinate admission and duplicate classification; an exact+-- SiteSet has already established canonical, distinct, lexicographically+-- ascending 'QueryPoint's. The latter remains package-internal through the+-- private build component, rather than becoming a second constructor.+data BulkInput vertex+  = RawPossiblyDuplicate+      !(Int -> Point)+      !(DuplicatePayloadPolicy vertex)+  | AdmittedDistinctAscending !(Int -> QueryPoint)++-- | 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.+delaunay+  :: forall vertex directed undirected face+   . HasPosition vertex+  => ElementDefaults directed undirected face+  -> V.Vector vertex+  -> Either BuildError (BuildResult 'Unconstrained vertex directed undirected face)+delaunay defaults input =+  buildDelaunayFromSource+    defaults+    (V.length input)+    (RawPossiblyDuplicate (position . (input V.!)) KeepFirstPayload)+    (input V.!)++-- | Build the geometry-only Delaunay triangulation of a coordinate vector.+-- Exact duplicate positions collapse to one site. Use 'delaunay' or+-- 'delaunayFromCoordinates' when vertex annotations or the input-to-vertex+-- mapping are part of the result.+delaunayGeometry+  :: V.Vector Point+  -> Either BuildError (DelaunayTriangulation ())+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+          (distanceArena, pointXMutable, pointYMutable, inputOrder) =+            MUV.unzip4 inputArena+      assignGeometryRadialDistances+        distanceArena+        pointXMutable+        pointYMutable+        inputCenterX+        inputCenterY+      distances <- U.unsafeFreeze distanceArena+      pointXs <- U.unsafeFreeze pointXMutable+      pointYs <- U.unsafeFreeze pointYMutable+      orderedInputArena <-+        radiallyOrderGeometry distances pointXs pointYs inputOrder+      defaultedOutcome <-+        newMutableDcelWithVertexDefault+          ()+          unitElementDefaults+          (planarDcelCapacity inputCount)+      case defaultedOutcome of+        Left failure -> pure (Left failure)+        Right defaultedMutable -> do+          let !mutable = defaultedVertexDcel defaultedMutable+              !dense = defaultedDenseVertexDcel defaultedMutable+          operation <- newOperationState (halfEdgeCapacity mutable)+          unique <- appendSortedGeometry defaultedMutable pointXs pointYs inputOrder+          orderedArena <-+            if unique == inputCount+              then pure orderedInputArena+              else do+                let !scale = recip (fromIntegral unique)+                    !uniqueOrder = MUV.unsafeSlice 0 unique inputOrder+                (sumX, sumY) <- sumGeometryVertices dense uniqueOrder+                uniqueArena <-+                  fillRadialArena+                    mutable+                    (sumX * scale)+                    (sumY * scale)+                    (MUV.unsafeRead uniqueOrder)+                    unique+                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+    -> MUV.MVector s Double+    -> MUV.MVector s Double+    -> Double+    -> Double+    -> ST s ()+  assignGeometryRadialDistances distances pointXs pointYs centerX centerY =+    MUV.imapM_+      (\index _ -> do+        x <- MUV.unsafeRead pointXs index+        y <- MUV.unsafeRead pointYs index+        let !deltaX = centerX - x+            !deltaY = centerY - y+        MUV.unsafeWrite distances index (deltaX * deltaX + deltaY * deltaY)+      )+      distances++  appendSortedGeometry+    :: forall s+     . DefaultedVertexDcel s () () () ()+    -> U.Vector Double+    -> U.Vector Double+    -> MUV.MVector s Word32+    -> ST s Int+  appendSortedGeometry defaultedMutable pointXs pointYs order+    | inputCount == 0 = pure 0+    | otherwise = do+        firstInput <- MUV.unsafeRead order 0+        let !x = U.unsafeIndex pointXs (fromIntegral firstInput)+            !y = U.unsafeIndex pointYs (fromIntegral firstInput)+        denseWriteFreshDefaultPoint defaultedMutable 0 x y+        MUV.unsafeWrite order 0 0+        (_, _, unique) <-+          MUV.foldM'+            (\(!previousX, !previousY, !uniqueCount) nextInput ->+               let !nextX = U.unsafeIndex pointXs (fromIntegral nextInput)+                   !nextY = U.unsafeIndex pointYs (fromIntegral nextInput)+                in if nextX == previousX && nextY == previousY+                     then pure (previousX, previousY, uniqueCount)+                     else do+                       denseWriteFreshDefaultPoint defaultedMutable uniqueCount nextX nextY+                       MUV.unsafeWrite order uniqueCount (fromIntegral uniqueCount)+                       pure (nextX, nextY, uniqueCount + 1)+            )+            (x, y, 1)+            (MUV.unsafeSlice 1 (inputCount - 1) order)+        unique <$ denseCommitFreshDefaultPoints defaultedMutable unique++  sumGeometryVertices+    :: forall s+     . DenseMutableDcel s () () () ()+    -> MUV.MVector s Word32+    -> ST s (Double, Double)+  sumGeometryVertices dense vertices =+    MUV.foldM'+      (\(!sumX, !sumY) raw -> do+         x <- denseReadPointX dense (unpackIndex raw)+         y <- denseReadPointY dense (unpackIndex raw)+         pure (sumX + x, sumY + y)+      )+      (0, 0)+      vertices++-- | Canonical construction from separate geometry and annotation sources.+-- The coordinate vector remains the only geometry in ingress; payloads never+-- acquire a fabricated 'HasPosition' instance merely to reach the loader.+delaunayFromCoordinates+  :: forall vertex directed undirected face+   . ElementDefaults directed undirected face+  -> V.Vector (Point)+  -> V.Vector vertex+  -> DuplicatePayloadPolicy vertex+  -> Either BuildError (BuildResult 'Unconstrained vertex directed undirected face)+delaunayFromCoordinates defaults coordinates payloads duplicatePolicy+  | coordinateCount /= payloadCount =+      Left (CoordinatePayloadCountMismatch coordinateCount payloadCount)+  | otherwise =+      buildDelaunayFromSource+        defaults+        coordinateCount+        (RawPossiblyDuplicate (coordinates V.!) duplicatePolicy)+        (payloads V.!)+ where+  !coordinateCount = V.length coordinates+  !payloadCount = V.length payloads++-- | Construction from an already-admitted exact site section. The caller+-- supplies Map-ascending, distinct 'QueryPoint's; this skips only raw+-- admission, duplicate classification, and unique-site recentering. It still+-- derives the radial execution order and runs the one circle sweep.+delaunayFromAdmittedDistinctAscending+  :: forall vertex directed undirected face+   . ElementDefaults directed undirected face+  -> V.Vector (QueryPoint, vertex)+  -> Either BuildError (BuildResult 'Unconstrained vertex directed undirected face)+delaunayFromAdmittedDistinctAscending defaults input =+  buildDelaunayFromSource+    defaults+    (V.length input)+    (AdmittedDistinctAscending (\index -> fst (input V.! index)))+    (\index -> snd (input V.! index))+{-# INLINE delaunayFromAdmittedDistinctAscending #-}++buildDelaunayFromSource+  :: forall vertex directed undirected face+   . ElementDefaults directed undirected face+  -> Int+  -> BulkInput vertex+  -> (Int -> vertex)+  -> Either BuildError (BuildResult 'Unconstrained vertex directed undirected face)+buildDelaunayFromSource defaults inputCount input payloadAtInput = do+  ensureCapacity inputCount+  runST $ do+    inputArena <- MUV.new inputCount+    admitted <- initializeInputArena inputArena+    case admitted of+      Left failure -> pure (Left failure)+      Right (inputSumX, inputSumY) -> do+        mutable <- newMutableDcel defaults (planarDcelCapacity inputCount)+        operation <- newOperationState (halfEdgeCapacity mutable)+        (mapping, unique, orderedArena) <-+          case input of+            RawPossiblyDuplicate pointAtInput duplicatePolicy ->+              prepareRawInput+                inputArena+                mutable+                pointAtInput+                duplicatePolicy+                inputSumX+                inputSumY+            AdmittedDistinctAscending _ ->+              prepareAdmittedDistinctInput inputArena mutable inputSumX inputSumY+        setCounter operation CounterInputPoints inputCount+        setCounter operation CounterUniquePoints unique+        setCounter operation CounterDuplicatePoints (inputCount - unique)+        inserted <-+          if unique == 0+            then pure (Right 0)+            else circleSweepInsert mutable operation orderedArena+        case inserted of+          Left failure -> pure (Left failure)+          Right seedCount -> do+            setCounter operation CounterSpatialSeedPoints seedCount+            frozenOutcome <- freezeTriangulation mutable+            case frozenOutcome of+              Left failure -> pure (Left failure)+              Right frozen -> do+                mapped <- unsafeFreezePrimArray mapping+                stats <- freezeBuildStats operation+                pure+                  ( Right+                      BuildResult+                        { buildTriangulation = frozen+                        , buildInputVertices = mapped+                        , buildStats = stats+                        }+                  )+ where+  -- Raw sources validate and canonicalize at this one ingress. Admitted+  -- sources merely project their retained QueryPoint evidence into the sweep+  -- arena; neither route reconstructs coordinate identity downstream.+  initializeInputArena+    :: forall s+     . MUV.MVector s (Double, Double, Double, Word32)+    -> ST s (Either BuildError (Double, Double))+  initializeInputArena arena =+    case input of+      RawPossiblyDuplicate pointAtInput _ ->+        initializeRawInputArena arena pointAtInput 0 0 0+      AdmittedDistinctAscending pointAtInput ->+        initializeAdmittedInputArena arena pointAtInput++  initializeRawInputArena+    :: forall s+     . MUV.MVector s (Double, Double, Double, Word32)+    -> (Int -> Point)+    -> Int+    -> Double+    -> Double+    -> ST s (Either BuildError (Double, Double))+  initializeRawInputArena arena pointAtInput !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)+                initializeRawInputArena+                  arena+                  pointAtInput+                  (index + 1)+                  (sumX + x)+                  (sumY + y)++  initializeAdmittedInputArena+    :: forall s+     . MUV.MVector s (Double, Double, Double, Word32)+    -> (Int -> QueryPoint)+    -> ST s (Either BuildError (Double, Double))+  initializeAdmittedInputArena arena pointAtInput =+    Right+      <$> MUV.ifoldM'+        (\(!sumX, !sumY) index _ ->+           case queryPointValue (pointAtInput index) of+             Point x y -> do+               MUV.unsafeWrite arena index (0, x, y, fromIntegral index)+               pure (sumX + x, sumY + y)+        )+        (0, 0)+        arena++  prepareRawInput+    :: forall s+     . MUV.MVector s (Double, Double, Double, Word32)+    -> MutableDcel s vertex directed undirected face+    -> (Int -> Point)+    -> DuplicatePayloadPolicy vertex+    -> Double+    -> Double+    -> ST s (MutablePrimArray s Word32, Int, RadiallyOrderedArena s)+  prepareRawInput inputArena mutable pointAtInput duplicatePolicy 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+    mapping <- newPrimArray inputCount+    unique <- classifySortedInputs mapping inputArena+    (sumX, sumY) <-+      appendClassifiedInputs mutable mapping pointAtInput duplicatePolicy 0 0 0+    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+    pure (mapping, unique, orderedArena)++  prepareAdmittedDistinctInput+    :: forall s+     . MUV.MVector s (Double, Double, Double, Word32)+    -> MutableDcel s vertex directed undirected face+    -> Double+    -> Double+    -> ST s (MutablePrimArray s Word32, Int, RadiallyOrderedArena s)+  prepareAdmittedDistinctInput inputArena mutable inputSumX inputSumY = do+    mapping <- newPrimArray inputCount+    appendAdmittedDistinctInputs mutable mapping inputArena+    let !inputScale = if inputCount == 0 then 0 else recip (fromIntegral inputCount)+        !inputCenterX = inputSumX * inputScale+        !inputCenterY = inputSumY * inputScale+    assignRadialDistances inputArena inputCenterX inputCenterY 0+    orderedArena <- radiallyOrderArena inputArena+    pure (mapping, inputCount, orderedArena)++  -- An admitted SiteSet is already distinct. Sequential append therefore+  -- transports the identity class map directly into authoritative vertex ids,+  -- without reopening duplicate policy or recentering a compacted arena.+  appendAdmittedDistinctInputs+    :: forall s+     . MutableDcel s vertex directed undirected face+    -> MutablePrimArray s Word32+    -> MUV.MVector s (Double, Double, Double, Word32)+    -> ST s ()+  appendAdmittedDistinctInputs mutable mapping arena =+    MUV.imapM_+      (\index (_, x, y, _) -> do+         vertex <- appendVertexCoordinates mutable x y (payloadAtInput index)+         writePrimArray mapping index (fromIntegral vertex)+         MUV.unsafeWrite arena index (0, x, y, fromIntegral vertex)+      )+      arena++  -- 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+        (_, x, y, inputOrdinal) <- MUV.unsafeRead arena index+        let !deltaX = centerX - x+            !deltaY = centerY - y+        MUV.unsafeWrite arena index (deltaX * deltaX + deltaY * deltaY, x, y, inputOrdinal)+        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+      :: (Double, Double, Double, Word32)+      -> Double+      -> Double+      -> Word32+      -> Int+      -> Int+      -> ST s Int+    classifyFrom !_ !previousX !previousY !classInput !readIndex !uniqueCount+      | readIndex >= inputCount = pure uniqueCount+      | otherwise = do+          record@(_, x, y, inputOrdinal) <- MUV.unsafeRead arena readIndex+          if x == previousX && y == previousY+            then do+              writePrimArray mapping (fromIntegral inputOrdinal) classInput+              classifyFrom record previousX previousY classInput (readIndex + 1) uniqueCount+            else do+              writePrimArray mapping (fromIntegral inputOrdinal) inputOrdinal+              if uniqueCount == readIndex+                then pure ()+                else MUV.unsafeWrite arena uniqueCount record+              classifyFrom record x y inputOrdinal (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 -> Point)+    -> DuplicatePayloadPolicy vertex+    -> Int+    -> Double+    -> Double+    -> ST s (Double, Double)+  appendClassifiedInputs mutable mapping pointAtInput duplicatePolicy !index !sumX !sumY+    | index >= inputCount = pure (sumX, sumY)+    | otherwise = do+        classInput <- readPrimArray mapping index+        let !vertexData = payloadAtInput index+        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+                pointAtInput+                duplicatePolicy+                (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+              pointAtInput+              duplicatePolicy+              (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.+--+-- The published mesh is independent of the one passed in. A singleton below+-- ten thousand resident sites copies densely; larger bases publish through+-- copy-on-write pages. A caller inserting a sequence wants one+-- 'Moonlight.Triangulation.Session.withSession' over+-- 'Moonlight.Triangulation.Session.insertVertex' instead — see 'insertAt'.+insert+  :: HasPosition vertex+  => Triangulation mode vertex directed undirected face+  -> vertex+  -> Either BuildError (InsertionResult mode vertex directed undirected face)+insert triangulation vertexData = insertAt triangulation (position vertexData) vertexData++-- | Insert at a stated point. 'insert' is this with the point read out of the+-- payload, which is what a caller holding only a payload wants; a caller that+-- computed the point — a constraint split, a Steiner refinement — wants to say+-- so rather than build a payload and hope the round trip through 'HasPosition'+-- returns what it started with.+--+-- This is one shaped transaction over a single insertion. Replacing a fold of+-- it with one session is sound because the two agree on every mesh and differ+-- only in how many intermediate meshes they publish. A fold publishes @k@+-- meshes and pays a thaw for each, so it runs in Θ(n·k); the session pays one+-- thaw and runs in O(k·log n) expected.+insertAt+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> vertex+  -> Either BuildError (InsertionResult mode vertex directed undirected face)+insertAt triangulation rawPoint vertexData = do+  queryPoint <- validatePoint Nothing rawPoint+  case locatePointWithHint triangulation Nothing queryPoint of+    (OnVertex resident, walked) ->+      Right (replaceResidentPayload triangulation resident walked vertexData)+    (located, walked) -> do+      let transactionShape =+            if numVertices triangulation < 10_000+              then DenseTransaction+              else LocalTransaction+      ((vertex, disposition), frozen, stats) <-+        runTransaction+          id+          transactionShape+          triangulation+          1+          (\mutable operation -> do+             addCounter operation CounterInputPoints 1+             inserted <-+               case located of+                 -- A frozen degenerate-line location points at an arbitrary visible+                 -- segment, while the line extension interpreter requires a terminal+                 -- edge. The frozen section carries no terminal witness, so retain+                 -- the existing mutable line locator for this one non-lawful case.+                 OutsideConvexHull (Just _)+                   | numInnerFaces triangulation == 0 ->+                       insertVertexAtPoint @'ProbeOff mutable operation Nothing (queryPointValue queryPoint) vertexData+                 _ -> do+                   capacityOutcome <- ensurePointCapacity mutable 1+                   case capacityOutcome of+                     Left failure -> pure (Left failure)+                     Right () -> do+                       vertex <- appendVertex mutable (queryPointValue queryPoint) vertexData+                       let thawedLocation =+                             case located of+                               EmptyTriangulation -> MutableEmpty+                               OnEdge edge -> MutableOnEdge (directedEdgeIdIndex edge)+                               InFace face -> MutableInFace (faceIdIndex face)+                               -- The frozen locator emits no edge only for a+                               -- singleton mesh. Its mutable interpreter ignores+                               -- this sentinel while constructing the second vertex.+                               OutsideConvexHull Nothing -> MutableOutsideHull 0+                               OutsideConvexHull (Just edge) -> MutableOutsideHull (directedEdgeIdIndex edge)+                       ((vertex, Inserted) <$) <$> insertExistingVertexAtLocation @'ProbeOff mutable operation vertex thawedLocation+             case inserted of+               Left failure -> pure (Left failure)+               Right (vertex, disposition) -> do+                 case disposition of+                   Inserted -> addCounter operation CounterUniquePoints 1+                   AlreadyPresent -> do+                     writeVertexData mutable vertex vertexData+                     addCounter operation CounterExistingPoints 1+                     addCounter operation CounterDuplicatePoints 1+                 pure (Right (vertex, disposition))+          )+      pure+        InsertionResult+          { insertionTriangulation = frozen+          , insertionVertex = VertexId (fromIntegral vertex)+          , insertionDisposition = disposition+          , insertionStats = withFrozenLocationStats walked stats+          }++-- | Publish a payload replacement without opening a transaction.+--+-- A position already resident changes exactly one thing: the payload slot the+-- vertex already occupies. No coordinate, no half-edge, no constraint flag and+-- no face record differs, so the five unboxed planes are the ones the argument+-- already holds rather than copies taken out of it — which is what a thaw costs+-- and what this exists to refuse. They are immutable values; nothing reached+-- from here is a mutable buffer, and 'boxedUpdate' materializes a fresh page+-- for the one it rewrites, leaving the argument's own directory intact.+--+-- The location counters are the frozen walk's, not a thawed walk's. They+-- describe the walk that actually ran.+replaceResidentPayload+  :: Triangulation mode vertex directed undirected face+  -> VertexId+  -> LocationStats+  -> vertex+  -> InsertionResult mode vertex directed undirected face+replaceResidentPayload triangulation resident walked vertexData =+  InsertionResult+    { insertionTriangulation =+        triangulation+          { triVertexData =+              boxedUpdate (vertexIdIndex resident) vertexData (triVertexData triangulation)+          }+    , insertionVertex = resident+    , insertionDisposition = AlreadyPresent+    , insertionStats =+        withFrozenLocationStats+          walked+          emptyBuildStats+            { statInputPoints = 1+            , statExistingPoints = 1+            , statDuplicatePoints = 1+            }+    }++-- | Add the frozen locator's observation to the local topology interpreter's+-- operation-owned counters. Direct frozen-site insertion contributes no mutable+-- walk; the degenerate fallback contributes its real mutable walk rather than+-- having it erased from the published result.+withFrozenLocationStats :: LocationStats -> BuildStats -> BuildStats+withFrozenLocationStats walked stats =+  stats+    { statLocationWalkSteps = locationWalkSteps walked + statLocationWalkSteps stats+    , statLocationMaxWalk = max (locationWalkSteps walked) (statLocationMaxWalk stats)+    , statLocationFallbacks = (if locationUsedFallback walked then 1 else 0) + statLocationFallbacks stats+    }++-- | Apply a batch in one page transaction. Duplicate positions are processed+-- in input order, so their last payload wins exactly as repeated 'insert'+-- calls would, while topology is inserted only once per new position.+insertMany+  :: forall mode vertex directed undirected face+   . HasPosition vertex+  => Triangulation mode vertex directed undirected face+  -> V.Vector vertex+  -> Either BuildError (BuildResult mode vertex directed undirected face)+insertMany triangulation input = do+  validateVertices input+  (mapped, frozen, stats) <-+    runTransaction id DenseTransaction triangulation (V.length input) $ \mutable operation -> do+      table <- newMutablePointIndex (pointCapacity mutable)+      seeded <- seedPointTable mutable table+      case seeded of+        Left failure -> pure (Left failure)+        Right () -> do+          mapping <- newPrimArray (V.length input)+          freshBuffer <- MUV.new (V.length input)+          filled <- fill mutable operation table mapping freshBuffer 0 0 0 0+          case filled of+            Left failure -> pure (Left failure)+            Right (sumX, sumY, freshCount) -> do+              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)+                  else do+                    let !scale = recip (fromIntegral freshCount)+                    arena <-+                      fillRadialArena+                        mutable+                        (sumX * scale)+                        (sumY * scale)+                        (MUV.unsafeRead freshBuffer)+                        freshCount+                    orderedArena <- radiallyOrderArena arena+                    circleSweepInsert mutable operation orderedArena+              case inserted of+                Left failure -> pure (Left failure)+                Right seedCount -> do+                  setCounter operation CounterSpatialSeedPoints seedCount+                  Right <$> unsafeFreezePrimArray mapping+  pure+    BuildResult+      { buildTriangulation = frozen+      , buildInputVertices = mapped+      , buildStats = stats+      }+ where+  fill+    :: forall s+     . MutableDcel s vertex directed undirected face+    -> OperationState s+    -> MutablePointIndex s+    -> MutablePrimArray s Word32+    -> MUV.MVector s Word32+    -> Int+    -> Double+    -> Double+    -> Int+    -> ST s (Either BuildError (Double, Double, Int))+  fill mutable operation table mapping freshBuffer !index !sumX !sumY !freshCount+    | index >= V.length input = pure (Right (sumX, sumY, freshCount))+    | otherwise = do+        let !vertexData = input V.! index+        claimed <- claimPosition mutable table (position vertexData) vertexData+        case claimed of+          Left failure -> pure (Left failure)+          Right (FreshPosition vertex canonicalX canonicalY) -> do+            writePrimArray mapping index (fromIntegral vertex)+            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+-- arenas and consumed in place by the sweep. The squared distance is stated+-- against the ingress-accumulated centre, in the widened comparison format.+fillRadialArena+  :: MutableDcel s vertex directed undirected face+  -> Double+  -> Double+  -> (Int -> ST s Word32)+  -> Int+  -> ST s (MUV.MVector s (Double, Double, Double, Word32))+fillRadialArena mutable centerX centerY lookupId count = do+  arena <- MUV.new count+  forM_ [0 .. count - 1] $ \index -> do+    raw <- lookupId index+    x <- readPointX mutable (unpackIndex raw)+    y <- readPointY mutable (unpackIndex raw)+    let !wideX = x+        !wideY = y+        !deltaX = centerX - wideX+        !deltaY = centerY - wideY+    MUV.unsafeWrite arena index (deltaX * deltaX + deltaY * deltaY, wideX, wideY, raw)+  pure arena++-- | Claim a position for the vertex the arena would append next, or answer the+-- vertex already holding it. The claim is written before the append, so the two+-- must stay adjacent: nothing may consume a vertex slot in between.+claimPosition+  :: MutableDcel s vertex directed undirected face+  -> MutablePointIndex s+  -> Point+  -> vertex+  -> ST s (Either BuildError PositionClaim)+claimPosition mutable table rawPoint vertexData =+  case rawPoint of+    Point x y -> do+      let !canonicalX = canonicalCoordinate x+          !canonicalY = canonicalCoordinate y+      slot <- nextVertexSlot mutable+      let !candidate = nextVertexSlotIndex slot+      owner <-+        resolveMutablePoint+          table+          (readPointX mutable)+          (readPointY mutable)+          canonicalX+          canonicalY+          candidate+      case owner of+        Left failure -> pure (Left failure)+        Right (Just existing) -> pure (Right (ResidentPosition existing))+        Right Nothing -> do+          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+  :: MutableDcel s vertex directed undirected face+  -> MutablePointIndex s+  -> ST s (Either BuildError ())+seedPointTable mutable table = do+  existing <- pointCount mutable+  seedMutablePointIndex+    table+    existing+    (readPointX mutable)+    (readPointY mutable)++validateVertices :: HasPosition vertex => V.Vector vertex -> Either BuildError ()+validateVertices vertices =+  V.iforM_ vertices (\index vertexData -> validatePoint (Just index) (position vertexData))
+ src-build/Moonlight/Triangulation/Internal/Capacity.hs view
@@ -0,0 +1,18 @@+-- | Admissibility of a requested vertex count against the packed index limit.+module Moonlight.Triangulation.Internal.Capacity+  ( ensureCapacity+  ) where++import Moonlight.Triangulation.Internal.PackedIndex (indexLimit)+import Moonlight.Triangulation.Internal.Types (BuildError (..))++ensureCapacity :: Int -> Either BuildError ()+ensureCapacity count+  | count < 0 || count > maximumVertexCapacity = Left (CapacityExceeded count)+  | otherwise = Right ()++-- Mutable allocation reserves @8n + 16@ directed-edge slots. Every topology+-- handle is packed below 'indexLimit', so admissibility is stated against that+-- actual representation bound rather than the machine 'Int' bound.+maximumVertexCapacity :: Int+maximumVertexCapacity = (indexLimit - 16) `quot` 8
+ src-build/Moonlight/Triangulation/Internal/Cdt/Admission.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Immutable admission of one requested segment against the sparse+-- constrained-edge section, decided without thawing topology.+module Moonlight.Triangulation.Internal.Cdt.Admission+  ( ConstraintAdmission (..)+  , constraintAdmission+  , segmentBoxesAreDisjoint+  ) where++import qualified Data.IntSet as IntSet+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Internal.Predicates (segmentsProperlyCross)+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types++-- | Immutable admission descends through the sparse constrained-edge section,+-- not through every ordinary edge in the requested corridor. Constraint+-- cardinality is the lawful index here: rejection depends only on a proper+-- crossing with an existing protected segment, while shared endpoints,+-- duplicate segments, and collinear overlap remain recoverable by the mutable+-- corridor algebra. Accepted singleton requests descend once more inside their+-- sealed transaction; the overwhelmingly common rejected request stops here+-- without thawing topology.+data ConstraintAdmission+  = ConstraintBlocked !UndirectedEdgeId+  | ConstraintAdmitted++constraintAdmission+  :: Triangulation 'Constrained vertex directed undirected face+  -> VertexId+  -> VertexId+  -> ConstraintAdmission+constraintAdmission triangulation from to =+  IntSet.foldr firstBlocking ConstraintAdmitted (triConstraintEdges triangulation)+ where+  !requestFrom = Dcel.vertexPoint triangulation from+  !requestTo = Dcel.vertexPoint triangulation to++  firstBlocking raw later =+    let !edge = UndirectedEdgeId (fromIntegral raw)+        (!edgeFromId, !edgeToId) = Dcel.undirectedEndpoints triangulation edge+     in if+          from == edgeFromId+            || from == edgeToId+            || to == edgeFromId+            || to == edgeToId+          then later+          else+            let !edgeFrom = Dcel.vertexPoint triangulation edgeFromId+                !edgeTo = Dcel.vertexPoint triangulation edgeToId+             in if segmentBoxesAreDisjoint requestFrom requestTo edgeFrom edgeTo+                  then later+                  else+                    if segmentsProperlyCross requestFrom requestTo edgeFrom edgeTo+                      then ConstraintBlocked edge+                      else later++segmentBoxesAreDisjoint+  :: Point+  -> Point+  -> Point+  -> Point+  -> Bool+segmentBoxesAreDisjoint (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy) =+  max ax bx < min cx dx+    || max cx dx < min ax bx+    || max ay by < min cy dy+    || max cy dy < min ay by+{-# INLINE segmentBoxesAreDisjoint #-}
+ src-build/Moonlight/Triangulation/Internal/Cdt/Batch.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | The batch interpreter: many constraint requests in order inside one sealed+-- dense transaction, with rejection carried as a value.+module Moonlight.Triangulation.Internal.Cdt.Batch+  ( recoverConstraints+  , recoverConstraintBatch+  , finalizeConstraintBatch+  , initialConstraintBatchStats+  , interpretConstraintRequest+  , interpretConstraintRequests+  ) where++import Control.Monad.ST (ST)+import Data.Either (isRight)+import qualified Data.Vector as V+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Internal.Cdt.Combinators (foldWhileM)+import Moonlight.Triangulation.Internal.Cdt.Query (validateEndpoints)+import Moonlight.Triangulation.Internal.Cdt.Recovery (applyMutableConstraint)+import Moonlight.Triangulation.Internal.Cdt.Types+import Moonlight.Triangulation.Internal.Growable+  ( GrowableWord32+  , newGrowableWord32+  )+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( OperationState )+import Moonlight.Triangulation.Internal.Paged (TransactionShape (DenseTransaction))+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Transaction (runTransaction)+import Moonlight.Triangulation.Internal.Types (ConstraintMode (..))++-- | Interpret constraint requests in order inside one sealed mutable DCEL+-- transaction. Rejections are values because an earlier accepted request can+-- lawfully obstruct a later request; structural recovery failures remain typed+-- errors and prevent a partially rewritten mesh from escaping. The public batch+-- interpreter amortizes dense materialization; known singleton repair sites+-- reuse this algebra under the sparse persistent-page interpretation.+recoverConstraints+  :: Triangulation 'Constrained vertex directed undirected face+  -> V.Vector (VertexId, VertexId)+  -> Either (CdtError) (ConstraintBatchResult vertex directed undirected face)+recoverConstraints triangulation requests+  | V.null requests =+      Right+        ConstraintBatchResult+          { constraintBatchTriangulation = triangulation+          , constraintBatchOutcomes = V.empty+          , constraintBatchStats = initialConstraintBatchStats 0+          }+  | otherwise =+      recoverConstraintBatch+        triangulation+        requests++recoverConstraintBatch+  :: Triangulation 'Constrained vertex directed undirected face+  -> V.Vector (VertexId, VertexId)+  -> Either (CdtError) (ConstraintBatchResult vertex directed undirected face)+recoverConstraintBatch triangulation requests = do+  V.mapM_ (uncurry (validateEndpoints triangulation)) requests+  (completed, frozen, _) <-+    runTransaction+      CdtBuildError+      DenseTransaction+      triangulation+      0+      (interpretConstraintRequests requests)+  pure (finalizeConstraintBatch frozen completed)+{-# INLINE recoverConstraintBatch #-}++-- | Interpret a complete constraint request section against an already-open+-- transaction. Both ordinary recovery and asymmetric constrained extension+-- use this one interpreter; callers decide only which request section is+-- resident before it begins.+interpretConstraintRequests+  :: V.Vector (VertexId, VertexId)+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> ST s (Either (CdtError) ConstraintBatchAccumulator)+interpretConstraintRequests requests mutable operation = do+  programWords <- newGrowableWord32 256+  let initialAccumulator =+        ConstraintBatchAccumulator+          { accumulatedConstraintOutcomes = []+          , accumulatedConstraintStats =+              initialConstraintBatchStats (V.length requests)+          }+  foldWhileM+    isRight+    (interpretConstraintRequest programWords mutable operation)+    (Right initialAccumulator)+    requests+{-# INLINE interpretConstraintRequests #-}++-- | Materialize the ordinary recovery receipt only after the enclosing+-- transaction has frozen. The mutable accumulator cannot escape as a partial+-- constrained mesh.+finalizeConstraintBatch+  :: Triangulation 'Constrained vertex directed undirected face+  -> ConstraintBatchAccumulator+  -> ConstraintBatchResult vertex directed undirected face+finalizeConstraintBatch frozen completed =+  ConstraintBatchResult+    { constraintBatchTriangulation = frozen+    , constraintBatchOutcomes = V.fromList (reverse (accumulatedConstraintOutcomes completed))+    , constraintBatchStats = accumulatedConstraintStats completed+    }+{-# INLINE finalizeConstraintBatch #-}++initialConstraintBatchStats :: Int -> ConstraintBatchStats+initialConstraintBatchStats requestCount =+  ConstraintBatchStats+    { constraintBatchRequests = requestCount+    , constraintBatchAccepted = 0+    , constraintBatchRejected = 0+    , constraintBatchCorridors = 0+    , constraintBatchReusedFaces = 0+    , constraintBatchCrossedEdges = 0+    }++interpretConstraintRequest+  :: GrowableWord32 s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Either (CdtError) ConstraintBatchAccumulator+  -> (VertexId, VertexId)+  -> ST s (Either (CdtError) ConstraintBatchAccumulator)+interpretConstraintRequest _ _ _ rejected@(Left _) _ = pure rejected+interpretConstraintRequest programWords mutable operation (Right accumulator) (from, to) = do+  applied <- applyMutableConstraint programWords mutable operation from to+  pure $ case applied of+    Left obstruction -> Left obstruction+    Right (MutableConstraintRejected blocking) ->+      let previousStats = accumulatedConstraintStats accumulator+       in Right+            accumulator+              { accumulatedConstraintOutcomes =+                  ConstraintRejected blocking : accumulatedConstraintOutcomes accumulator+              , accumulatedConstraintStats =+                  previousStats+                    { constraintBatchRejected = constraintBatchRejected previousStats + 1+                    }+              }+    Right (MutableConstraintAccepted request) ->+      let previousStats = accumulatedConstraintStats accumulator+       in Right+            accumulator+              { accumulatedConstraintOutcomes =+                  ConstraintAccepted+                    (V.fromList (reverse (accumulatedRequestPath request)))+                    (accumulatedRequestAddedEdges request)+                    : accumulatedConstraintOutcomes accumulator+              , accumulatedConstraintStats =+                  previousStats+                    { constraintBatchAccepted = constraintBatchAccepted previousStats + 1+                    , constraintBatchCorridors =+                        constraintBatchCorridors previousStats + accumulatedRequestCorridors request+                    , constraintBatchReusedFaces =+                        constraintBatchReusedFaces previousStats + accumulatedRequestReusedFaces request+                    , constraintBatchCrossedEdges =+                        constraintBatchCrossedEdges previousStats + accumulatedRequestCrossedEdges request+                    }+              }
+ src-build/Moonlight/Triangulation/Internal/Cdt/Build.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Constrained bulk loading: an unconstrained load promoted to the+-- constrained layer, then driven through the batch corridor interpreter.+module Moonlight.Triangulation.Internal.Cdt.Build+  ( fromDelaunay+  , constrainedDelaunay+  , constrainedDelaunayMaximal+  ) where++import Data.Bifunctor (first)+import qualified Data.Vector as V+import Data.Primitive.PrimArray (PrimArray, indexPrimArray, sizeofPrimArray)+import Data.Word (Word32)+import Moonlight.Triangulation.BulkLoad (delaunay)+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Internal.Cdt.Batch (recoverConstraints)+import Moonlight.Triangulation.Internal.Cdt.Types+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types++-- | Promote an unconstrained mesh into the constrained layer with no marked edges.+fromDelaunay+  :: Triangulation 'Unconstrained vertex directed undirected face+  -> Triangulation 'Constrained vertex directed undirected face+fromDelaunay = promoteConstrained++-- | Build a constrained triangulation, refusing the complete request when any+-- input constraint cannot be admitted.+constrainedDelaunay+  :: HasPosition vertex+  => ElementDefaults directed undirected face+  -> V.Vector vertex+  -> V.Vector (Int, Int)+  -> Either (CdtError) (BuildResult 'Constrained vertex directed undirected face)+constrainedDelaunay defaults inputVertices constraints = do+  result <- constrainedDelaunayMaximal defaults inputVertices constraints+  if V.null (cdtRejectedConstraints result)+    then Right (cdtAcceptedBuild result)+    else Left (ConstraintInputConflicts (cdtRejectedConstraints result))++-- | Stable constrained bulk loading. Duplicate input vertices are rerouted to+-- the first surviving handle. Every proper constraint conflict is returned in+-- input order; accepted constraints remain in the result.+constrainedDelaunayMaximal+  :: HasPosition vertex+  => ElementDefaults directed undirected face+  -> V.Vector vertex+  -> V.Vector (Int, Int)+  -> Either (CdtError) (CdtBuildResult vertex directed undirected face)+constrainedDelaunayMaximal defaults inputVertices constraints = do+  built <- first CdtBuildError (delaunay defaults inputVertices)+  let !mapping = buildInputVertices built+      !initial = fromDelaunay (buildTriangulation built)+  requests <- V.mapM (mapConstraintRequest mapping) constraints+  batch <- recoverConstraints initial requests+  let rejected =+        V.mapMaybe+          (\(request, outcome) ->+            case outcome of+              ConstraintAccepted _ _ -> Nothing+              ConstraintRejected _ -> Just request+          )+          (V.zip constraints (constraintBatchOutcomes batch))+  pure+    CdtBuildResult+      { cdtAcceptedBuild =+          BuildResult+            { buildTriangulation = constraintBatchTriangulation batch+            , buildInputVertices = mapping+            , buildStats = buildStats built+            }+      , cdtRejectedConstraints = rejected+      }+ where+  mapConstraintRequest+    :: PrimArray Word32+    -> (Int, Int)+    -> Either (CdtError) (VertexId, VertexId)+  mapConstraintRequest mapping (fromIndex, toIndex) =+    (,)+      <$> mapConstraintEndpoint mapping fromIndex+      <*> mapConstraintEndpoint mapping toIndex++  mapConstraintEndpoint+    :: PrimArray Word32+    -> Int+    -> Either (CdtError) VertexId+  mapConstraintEndpoint mapping endpointIndex+    | endpointIndex >= 0 && endpointIndex < sizeofPrimArray mapping =+        Right (VertexId (indexPrimArray mapping endpointIndex))+    | otherwise =+        Left (ConstraintEndpointIndexOutOfRange endpointIndex (sizeofPrimArray mapping))
+ src-build/Moonlight/Triangulation/Internal/Cdt/Combinators.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DataKinds #-}++-- | Bounded monadic folding, refusable transaction sequencing, and the handle+-- and error coercions the constrained layer shares.+module Moonlight.Triangulation.Internal.Cdt.Combinators+  ( foldWhileM+  , bindMutable+  , asConstraintStep+  ) where++import Moonlight.Triangulation.Internal.Cdt.Types (CdtError (..))+import Moonlight.Triangulation.Internal.Types (BuildError)++-- | Monadic left fold whose continuation is supplied by a lazy right fold.+-- The state predicate decides descent before the next effect is constructed,+-- so graph walks stop at their authoritative local answer without mutable loop+-- control or traversing the unused safety suffix.+foldWhileM+  :: (Foldable container, Monad monad)+  => (state -> Bool)+  -> (state -> item -> monad state)+  -> state+  -> container item+  -> monad state+foldWhileM shouldContinue step initial items =+  foldr+    (\item continuation state ->+      if shouldContinue state+        then step state item >>= continuation+        else pure state+    )+    pure+    items+    initial+{-# INLINE foldWhileM #-}++-- | Sequence two refusable transaction steps. Refusal short-circuits, so a+-- transaction that abandons never reaches its publication; writing the bind+-- once is what keeps the constraint verbs from nesting their case analysis+-- five deep.+bindMutable :: Monad monad => monad (Either failure a) -> (a -> monad (Either failure b)) -> monad (Either failure b)+bindMutable step continue = do+  outcome <- step+  case outcome of+    Left failure -> pure (Left failure)+    Right value -> continue value+{-# INLINE bindMutable #-}++-- | Relabel a step whose refusal is a build failure, so it composes with the+-- constraint layer's own.+asConstraintStep :: Functor f => f (Either BuildError a) -> f (Either (CdtError) a)+asConstraintStep = fmap (either (Left . CdtBuildError) Right)+{-# INLINE asConstraintStep #-}
+ src-build/Moonlight/Triangulation/Internal/Cdt/Corridor.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | The corridor walk: one traversal of the requested segment that yields+-- either the first oriented blocking witness or a complete recovery program.+module Moonlight.Triangulation.Internal.Cdt.Corridor+  ( constraintWorkspaceFor+  , scanMutableConstraint+  , advanceMutablePlan+  , continueMutablePlan+  , beginMutableRecover+  , finishMutableRecover+  , settleMutableProgram+  , mutablePlanIsActive+  , writeConstraintProgram+  , readConstraintProgram+  , existingProgramTag+  , recoverProgramTag+  ) where++import Control.Monad.ST (ST)+import Data.Bits (xor)+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.IntersectionIterator (Intersection (..))+import Moonlight.Triangulation.Internal.Cdt.Combinators (foldWhileM)+import Moonlight.Triangulation.Internal.Cdt.Corridor.Trace (nextMutableIntersection)+import Moonlight.Triangulation.Internal.Cdt.Types+import Moonlight.Triangulation.Internal.Growable+  ( GrowableWord32+  , clearGrowable+  , readGrowable+  , writeGrowable+  )+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.Types (Point)++-- | The walk budget bounds a corridor through the mesh as it stands, so it is+-- taken per request rather than per transaction: a verb that inserts before it+-- recovers has changed the mesh the budget describes. Recovery itself adds+-- neither vertex nor edge, so a batch reads the same number every time.+constraintWorkspaceFor+  :: GrowableWord32 s+  -> MutableDcel s vertex directed undirected face+  -> ST s (ConstraintWorkspace s)+constraintWorkspaceFor constraintProgramWords mutable = do+  halfEdges <- directedEdgeCount mutable+  vertices <- pointCount mutable+  pure+    ConstraintWorkspace+      { constraintProgramWords+      , constraintWalkBudget = 2 * halfEdges + vertices + 8+      }++writeConstraintProgram :: ConstraintWorkspace s -> Int -> Int -> ST s ()+writeConstraintProgram ConstraintWorkspace{constraintProgramWords} index value =+  writeGrowable constraintProgramWords index (fromIntegral value)+{-# INLINE writeConstraintProgram #-}++readConstraintProgram :: ConstraintWorkspace s -> Int -> ST s Int+readConstraintProgram ConstraintWorkspace{constraintProgramWords} index =+  fromIntegral <$> readGrowable constraintProgramWords index+{-# INLINE readConstraintProgram #-}++-- | Walk one corridor once, gluing the local observations into either the+-- first oriented blocking witness or a complete recovery program. The former+-- admission/planning pair traversed every admitted corridor twice and could+-- disagree if either walk evolved independently; this scanner is their single+-- semantic owner.+scanMutableConstraint+  :: ConstraintWorkspace s+  -> MutableDcel s vertex directed undirected face+  -> VertexId+  -> VertexId+  -> ST s (Either (CdtError) MutableConstraintScan)+scanMutableConstraint workspace@ConstraintWorkspace{constraintProgramWords, constraintWalkBudget} mutable from to = do+  clearGrowable constraintProgramWords+  lineFrom <- pointAt mutable (vertexIdIndex from)+  lineTo <- pointAt mutable (vertexIdIndex to)+  initialCursor <- beginMutableRecover workspace 0 from 0 False+  walked <-+    foldWhileM+      mutablePlanIsActive+      (advanceMutablePlan workspace mutable lineFrom lineTo to)+      (MutablePlanActive (VertexIntersection from) initialCursor)+      [1 .. constraintWalkBudget]+  pure $ case walked of+    MutablePlanComplete plan -> Right (MutableConstraintScanAdmitted plan)+    MutablePlanBlocked blocking -> Right (MutableConstraintScanBlocked blocking)+    MutablePlanFailed obstruction -> Left (ConstraintCorridorObstructed obstruction)+    MutablePlanActive _ _ ->+      Left+        ( ConstraintCorridorObstructed+            (CorridorWalkDidNotTerminate constraintWalkBudget)+        )++advanceMutablePlan+  :: ConstraintWorkspace s+  -> MutableDcel s vertex directed undirected face+  -> Point+  -> Point+  -> VertexId+  -> MutablePlanWalk+  -> Int+  -> ST s MutablePlanWalk+advanceMutablePlan _ _ _ _ _ complete@(MutablePlanComplete _) _ = pure complete+advanceMutablePlan _ _ _ _ _ blocked@(MutablePlanBlocked _) _ = pure blocked+advanceMutablePlan _ _ _ _ _ failed@(MutablePlanFailed _) _ = pure failed+advanceMutablePlan workspace mutable lineFrom lineTo target (MutablePlanActive event cursor) _ =+  case event of+    EdgeIntersection directed -> do+      constrained <- readConstraint mutable (directedEdgeIdIndex directed)+      if constrained+        then pure (MutablePlanBlocked directed)+        else do+          writeConstraintProgram workspace (mutableCursorWriteAt cursor) (directedEdgeIdIndex directed)+          continueMutablePlan+            workspace+            mutable+            lineFrom+            lineTo+            target+            event+            cursor+              { mutableCursorWriteAt = mutableCursorWriteAt cursor + 1+              , mutableCursorConflictCount = mutableCursorConflictCount cursor + 1+              , mutableCursorAfterOverlap = False+              }+    VertexIntersection vertex+      | mutableCursorAfterOverlap cursor ->+          continueMutablePlan+            workspace+            mutable+            lineFrom+            lineTo+            target+            event+            cursor{mutableCursorAfterOverlap = False}+      | vertex == mutableCursorAt cursor ->+          continueMutablePlan+            workspace+            mutable+            lineFrom+            lineTo+            target+            event+            cursor{mutableCursorAfterOverlap = False}+      | otherwise -> do+          finished <- finishMutableRecover workspace vertex cursor+          nextCursor <-+            beginMutableRecover+              workspace+              (mutableCursorWriteAt finished)+              vertex+              (mutableCursorPieceCount finished)+              False+          continueMutablePlan workspace mutable lineFrom lineTo target event nextCursor+    EdgeOverlap rawDirected -> do+      let rawEdge = directedEdgeIdIndex rawDirected+      rawOrigin <- readOrigin mutable rawEdge+      rawDestination <- readOrigin mutable (rawEdge `xor` 1)+      let current = vertexIdIndex (mutableCursorAt cursor)+          oriented+            | rawOrigin == current = Just rawEdge+            | rawDestination == current = Just (rawEdge `xor` 1)+            | otherwise = Nothing+      case oriented of+        Nothing ->+          pure+            ( MutablePlanFailed+                ( CorridorBoundaryMissing+                    (mutableCursorAt cursor)+                    (VertexId (fromIntegral rawOrigin))+                )+            )+        Just edge -> do+          prefix <-+            if mutableCursorConflictCount cursor == 0+              then pure cursor+              else finishMutableRecover workspace (mutableCursorAt cursor) cursor+          let !existingAt =+                if mutableCursorConflictCount cursor == 0+                  then mutableCursorHeader cursor+                  else mutableCursorWriteAt prefix+              !edgeDestination =+                VertexId+                  ( fromIntegral+                      (if edge == rawEdge then rawDestination else rawOrigin)+                  )+              !pieceCount = mutableCursorPieceCount prefix + 1+              !nextHeader = existingAt + 2+          writeConstraintProgram workspace existingAt existingProgramTag+          writeConstraintProgram workspace (existingAt + 1) edge+          nextCursor <-+            beginMutableRecover+              workspace+              nextHeader+              edgeDestination+              pieceCount+              True+          continueMutablePlan workspace mutable lineFrom lineTo target event nextCursor++continueMutablePlan+  :: ConstraintWorkspace s+  -> MutableDcel s vertex directed undirected face+  -> Point+  -> Point+  -> VertexId+  -> Intersection+  -> MutableProgramCursor+  -> ST s MutablePlanWalk+continueMutablePlan workspace mutable lineFrom lineTo target event cursor = do+  following <- nextMutableIntersection mutable lineFrom lineTo event+  case following of+    Just nextEvent -> pure (MutablePlanActive nextEvent cursor)+    Nothing -> MutablePlanComplete <$> settleMutableProgram workspace target cursor++beginMutableRecover+  :: ConstraintWorkspace s+  -> Int+  -> VertexId+  -> Int+  -> Bool+  -> ST s MutableProgramCursor+beginMutableRecover workspace header from pieceCount afterOverlap = do+  writeConstraintProgram workspace header recoverProgramTag+  writeConstraintProgram workspace (header + 1) (vertexIdIndex from)+  writeConstraintProgram workspace (header + 2) 0+  writeConstraintProgram workspace (header + 3) 0+  pure+    MutableProgramCursor+      { mutableCursorAt = from+      , mutableCursorHeader = header+      , mutableCursorWriteAt = header + 4+      , mutableCursorConflictCount = 0+      , mutableCursorPieceCount = pieceCount+      , mutableCursorAfterOverlap = afterOverlap+      }++finishMutableRecover+  :: ConstraintWorkspace s+  -> VertexId+  -> MutableProgramCursor+  -> ST s MutableProgramCursor+finishMutableRecover workspace to cursor = do+  writeConstraintProgram workspace (mutableCursorHeader cursor + 2) (vertexIdIndex to)+  writeConstraintProgram workspace (mutableCursorHeader cursor + 3) (mutableCursorConflictCount cursor)+  pure+    cursor+      { mutableCursorAt = to+      , mutableCursorPieceCount = mutableCursorPieceCount cursor + 1+      }++settleMutableProgram+  :: ConstraintWorkspace s+  -> VertexId+  -> MutableProgramCursor+  -> ST s MutableConstraintProgram+settleMutableProgram workspace target cursor+  | mutableCursorAt cursor == target =+      pure+        MutableConstraintProgram+          { mutableProgramWordCount = mutableCursorHeader cursor+          , mutableProgramPieceCount = mutableCursorPieceCount cursor+          }+  | otherwise = do+      finished <- finishMutableRecover workspace target cursor+      pure+        MutableConstraintProgram+          { mutableProgramWordCount = mutableCursorWriteAt finished+          , mutableProgramPieceCount = mutableCursorPieceCount finished+          }++existingProgramTag :: Int+existingProgramTag = 0++recoverProgramTag :: Int+recoverProgramTag = 1++mutablePlanIsActive :: MutablePlanWalk -> Bool+mutablePlanIsActive (MutablePlanActive _ _) = True+mutablePlanIsActive _ = False
+ src-build/Moonlight/Triangulation/Internal/Cdt/Corridor/Trace.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Local direction tracing inside the thawed mesh: where a directed line+-- leaves the vertex or edge it currently stands on.+module Moonlight.Triangulation.Internal.Cdt.Corridor.Trace+  ( MutableVertexOut (..)+  , MutableVertexTrace (..)+  , MutableEdgeOut (..)+  , nextMutableIntersection+  , traceMutableDirectionOutOfVertex+  , advanceMutableVertexTrace+  , traceMutableDirectionOutOfEdge+  , mutableEdgeIntersectsNonCollinear+  , mutableVertexTraceIsSearching+  ) where++import Control.Monad.ST (ST)+import Data.Bits (xor)+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.IntersectionIterator+import Moonlight.Triangulation.Internal.Cdt.Combinators (foldWhileM)+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.Predicates+  ( onClosedSegment+  , orient2d+  , orient2dCoordinates+  )+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Math (projectionFactor)++data MutableVertexOut+  = MutableVertexOutHull+  | MutableVertexOutOverlap {-# UNPACK #-} !Int+  | MutableVertexOutEdge {-# UNPACK #-} !Int++data MutableVertexTrace+  = MutableVertexTraceSearching {-# UNPACK #-} !Int !Ordering+  | MutableVertexTraceComplete !MutableVertexOut++data MutableEdgeOut+  = MutableEdgeOutHull+  | MutableEdgeOutVertex {-# UNPACK #-} !Int+  | MutableEdgeOutEdge {-# UNPACK #-} !Int+  | MutableEdgeOutNone++nextMutableIntersection+  :: MutableDcel s vertex directed undirected face+  -> Point+  -> Point+  -> Intersection+  -> ST s (Maybe Intersection)+nextMutableIntersection mutable lineFrom lineTo current =+  case current of+    EdgeIntersection directed -> do+      edgeOut <- traceMutableDirectionOutOfEdge mutable (directedEdgeIdIndex directed) lineFrom lineTo+      pure $ case edgeOut of+        MutableEdgeOutHull -> Nothing+        MutableEdgeOutVertex vertex ->+          Just (VertexIntersection (VertexId (fromIntegral vertex)))+        MutableEdgeOutEdge edge ->+          Just (EdgeIntersection (DirectedEdgeId (fromIntegral edge)))+        MutableEdgeOutNone -> Nothing+    VertexIntersection vertex -> do+      currentPoint <- pointAt mutable (vertexIdIndex vertex)+      if currentPoint == lineTo+        then pure Nothing+        else do+          vertexOut <- traceMutableDirectionOutOfVertex mutable (vertexIdIndex vertex) lineTo+          case vertexOut of+            MutableVertexOutHull -> pure Nothing+            MutableVertexOutOverlap edge ->+              pure (Just (EdgeOverlap (DirectedEdgeId (fromIntegral edge))))+            MutableVertexOutEdge edge -> do+              edgeFrom <- edgeOriginPoint mutable edge+              edgeTo <- edgeOriginPoint mutable (edge `xor` 1)+              pure+                ( if orient2d edgeFrom edgeTo lineTo == LT+                    then Nothing+                    else Just (EdgeIntersection (DirectedEdgeId (fromIntegral edge)))+                )+    EdgeOverlap directed+      | lineFrom == lineTo -> pure Nothing+      | otherwise -> do+          destination <- readOrigin mutable (directedEdgeIdIndex directed `xor` 1)+          destinationPoint <- pointAt mutable destination+          pure+            ( if onClosedSegment lineFrom lineTo destinationPoint+                then Just (VertexIntersection (VertexId (fromIntegral destination)))+                else Nothing+            )++traceMutableDirectionOutOfVertex+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> Point+  -> ST s MutableVertexOut+traceMutableDirectionOutOfVertex mutable vertex target = do+  start <- readVertexOut mutable vertex+  if start < 0+    then pure MutableVertexOutHull+    else do+      currentPoint <- pointAt mutable vertex+      startTarget <- edgeOriginPoint mutable (start `xor` 1)+      halfEdges <- directedEdgeCount mutable+      let startSide = orient2d currentPoint startTarget target+          rotateCounterClockwise = startSide == GT+      traced <-+        foldWhileM+          mutableVertexTraceIsSearching+          (advanceMutableVertexTrace mutable currentPoint target rotateCounterClockwise)+          (MutableVertexTraceSearching start startSide)+          [0 .. halfEdges]+      pure $ case traced of+        MutableVertexTraceComplete result -> result+        MutableVertexTraceSearching _ _ -> MutableVertexOutHull++advanceMutableVertexTrace+  :: MutableDcel s vertex directed undirected face+  -> Point+  -> Point+  -> Bool+  -> MutableVertexTrace+  -> Int+  -> ST s MutableVertexTrace+advanceMutableVertexTrace _ _ _ _ complete@(MutableVertexTraceComplete _) _ = pure complete+advanceMutableVertexTrace mutable currentPoint target rotateCounterClockwise (MutableVertexTraceSearching current currentSide) _ = do+  currentTarget <- edgeOriginPoint mutable (current `xor` 1)+  if currentSide == EQ && projectionFactor currentPoint currentTarget target >= 0+    then pure (MutableVertexTraceComplete (MutableVertexOutOverlap current))+    else do+      following <-+        if rotateCounterClockwise+          then (`xor` 1) <$> readPrevious mutable current+          else readNext mutable (current `xor` 1)+      followingTarget <- edgeOriginPoint mutable (following `xor` 1)+      let followingSide = orient2d currentPoint followingTarget target+      if followingSide == EQ && projectionFactor currentPoint followingTarget target >= 0+        then pure (MutableVertexTraceComplete (MutableVertexOutOverlap following))+        else do+          faceBetween <-+            readFace mutable (if rotateCounterClockwise then current else following)+          if faceBetween == 0+            then pure (MutableVertexTraceComplete MutableVertexOutHull)+            else+              if rotateCounterClockwise == (followingSide == LT)+                then do+                  segment <-+                    if rotateCounterClockwise+                      then readNext mutable current+                      else readPrevious mutable (current `xor` 1)+                  pure+                    ( MutableVertexTraceComplete+                        (MutableVertexOutEdge (segment `xor` 1))+                    )+                else pure (MutableVertexTraceSearching following followingSide)++traceMutableDirectionOutOfEdge+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> Point+  -> Point+  -> ST s MutableEdgeOut+traceMutableDirectionOutOfEdge mutable edge lineFrom lineTo = do+  incident <- readFace mutable edge+  if incident == 0+    then pure MutableEdgeOutHull+    else do+      edgePrevious <- readPrevious mutable edge+      edgeNext <- readNext mutable edge+      edgeOrigin <- edgeOriginPoint mutable edge+      oppositeVertex <- edgeOriginPoint mutable edgePrevious+      let !originSide = orient2d lineFrom lineTo edgeOrigin+          !oppositeSide = orient2d lineFrom lineTo oppositeVertex+      if originSide == EQ || oppositeSide == EQ+        then classifyDegenerate edgePrevious edgeNext+        else+          if originSide == oppositeSide+            then do+              nextOrigin <- edgeOriginPoint mutable edgeNext+              let !outgoing = edgeNext `xor` 1+                  !targetSide = orient2d oppositeVertex nextOrigin lineTo+              pure+                ( if targetSide == LT+                    then MutableEdgeOutNone+                    else MutableEdgeOutEdge outgoing+                )+            else do+              let !outgoing = edgePrevious `xor` 1+                  !targetSide = orient2d edgeOrigin oppositeVertex lineTo+              pure+                ( if targetSide == LT+                    then MutableEdgeOutNone+                    else MutableEdgeOutEdge outgoing+                )+ where+  classifyDegenerate edgePrevious edgeNext = do+    previousIntersects <- mutableEdgeIntersectsNonCollinear mutable lineFrom lineTo edgePrevious+    nextIntersects <- mutableEdgeIntersectsNonCollinear mutable lineFrom lineTo edgeNext+    case (previousIntersects, nextIntersects) of+      (True, False) -> pure (MutableEdgeOutEdge (edgePrevious `xor` 1))+      (False, True) -> pure (MutableEdgeOutEdge (edgeNext `xor` 1))+      (True, True) -> MutableEdgeOutVertex <$> readOrigin mutable edgePrevious+      (False, False) -> pure MutableEdgeOutNone++mutableEdgeIntersectsNonCollinear+  :: MutableDcel s vertex directed undirected face+  -> Point+  -> Point+  -> Int+  -> ST s Bool+mutableEdgeIntersectsNonCollinear+  mutable+  (Point lineFromX lineFromY)+  (Point lineToX lineToY)+  edge = do+    edgeFromVertex <- readOrigin mutable edge+    edgeToVertex <- readOrigin mutable (edge `xor` 1)+    Point edgeFromX edgeFromY <- pointAt mutable edgeFromVertex+    Point edgeToX edgeToY <- pointAt mutable edgeToVertex+    let !lineFromSide =+          orient2dCoordinates+            edgeFromX edgeFromY edgeToX edgeToY lineFromX lineFromY+        !lineToSide =+          orient2dCoordinates+            edgeFromX edgeFromY edgeToX edgeToY lineToX lineToY+        !edgeFromSide =+          orient2dCoordinates+            lineFromX lineFromY lineToX lineToY edgeFromX edgeFromY+        !edgeToSide =+          orient2dCoordinates+            lineFromX lineFromY lineToX lineToY edgeToX edgeToY+    pure+      ( lineFromSide /= lineToSide+          && edgeFromSide /= edgeToSide+      )++mutableVertexTraceIsSearching :: MutableVertexTrace -> Bool+mutableVertexTraceIsSearching (MutableVertexTraceSearching _ _) = True+mutableVertexTraceIsSearching _ = False
+ src-build/Moonlight/Triangulation/Internal/Cdt/Query.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Read-only interrogation of the constrained layer, over both the published+-- mesh and the thawed one, plus the endpoint validity the verbs share.+module Moonlight.Triangulation.Internal.Cdt.Query+  ( constraintEdges+  , constraintStorageBytes+  , existsConstraint+  , canAddConstraint+  , intersectsConstraint+  , getConflictingEdgesBetweenPoints+  , getConflictingEdgesBetweenVertices+  , findDirectedEdge+  , findMutableEdge+  , validateEndpoints+  , validVertex+  ) where++import Control.Monad.ST (ST)+import Data.Bits (xor)+import qualified Data.IntSet as IntSet+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.IntersectionIterator+import Moonlight.Triangulation.Internal.Cdt.Admission+  ( ConstraintAdmission (..)+  , constraintAdmission+  )+import Moonlight.Triangulation.Internal.Cdt.Types (CdtError (..))+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.Paged (pagedLength)+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types++-- | Marked undirected edges in ascending identifier order.+constraintEdges+  :: Triangulation 'Constrained vertex directed undirected face+  -> [UndirectedEdgeId]+constraintEdges =+  fmap (UndirectedEdgeId . fromIntegral)+    . IntSet.toAscList+    . triConstraintEdges+{-# INLINE constraintEdges #-}++-- | Bytes occupied by the dense constraint marker plane.+constraintStorageBytes+  :: Triangulation 'Constrained vertex directed undirected face+  -> Integer+constraintStorageBytes = toInteger . pagedLength . triConstraint++-- | Whether a marked edge directly joins two admitted vertices.+existsConstraint+  :: Triangulation 'Constrained vertex directed undirected face+  -> VertexId+  -> VertexId+  -> Bool+existsConstraint triangulation from to =+  case findDirectedEdge triangulation from to of+    Just edge -> Dcel.isConstraintEdge triangulation (asUndirected edge)+    Nothing -> False++-- | Whether a segment can be admitted without crossing a resident constraint.+canAddConstraint+  :: Triangulation 'Constrained vertex directed undirected face+  -> VertexId+  -> VertexId+  -> Bool+canAddConstraint triangulation from to =+  from /= to+    && validVertex triangulation from+    && validVertex triangulation to+    && case constraintAdmission triangulation from to of+      ConstraintBlocked _ -> False+      ConstraintAdmitted -> True++-- | Whether a query segment properly crosses a resident constraint.+intersectsConstraint+  :: Triangulation 'Constrained vertex directed undirected face+  -> QueryPoint+  -> QueryPoint+  -> Bool+intersectsConstraint triangulation from to =+  case foldCorridorBetweenPoints triangulation from to firstBlocking () of+    Just (Left ()) -> True+    Just (Right ()) -> False+    Nothing -> not (null (getConflictingEdgesBetweenPoints triangulation from to))+ where+  firstBlocking :: () -> Intersection -> Either () ()+  firstBlocking _ (EdgeIntersection edge)+    | Dcel.isConstraintEdge triangulation (asUndirected edge) = Left ()+  firstBlocking _ _ = Right ()++-- | Resident constrained edges properly crossed by a query segment.+getConflictingEdgesBetweenPoints+  :: Triangulation 'Constrained vertex directed undirected face+  -> QueryPoint+  -> QueryPoint+  -> [DirectedEdgeId]+getConflictingEdgesBetweenPoints triangulation from to =+  [ edge+  | EdgeIntersection edge <- lineIntersections triangulation from to+  , Dcel.isConstraintEdge triangulation (asUndirected edge)+  ]++-- | Resident constrained edges crossed between two admitted vertices.+getConflictingEdgesBetweenVertices+  :: Triangulation 'Constrained vertex directed undirected face+  -> VertexId+  -> VertexId+  -> [DirectedEdgeId]+getConflictingEdgesBetweenVertices triangulation from to+  | not (validVertex triangulation from && validVertex triangulation to) = []+  | otherwise =+      [ edge+      | EdgeIntersection edge <- lineIntersectionsBetweenVertices triangulation from to+      , Dcel.isConstraintEdge triangulation (asUndirected edge)+      ]++-- | Find an oriented edge joining two admitted vertices.+findDirectedEdge :: Triangulation 'Constrained vertex directed undirected face -> VertexId -> VertexId -> Maybe DirectedEdgeId+findDirectedEdge triangulation from to =+  case filter ((== to) . Dcel.destination triangulation) (Dcel.vertexOutgoingEdges triangulation from) of+    edge : _ -> Just edge+    [] -> Nothing++-- | Find an oriented edge in a thawed triangulation.+findMutableEdge :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s (Maybe Int)+findMutableEdge mutable from to = do+  start <- readVertexOut mutable from+  halfEdges <- directedEdgeCount mutable+  if start < 0+    then pure Nothing+    else go (halfEdges + 1) start start False+ where+  go !remaining !start !edge !visited+    | remaining <= 0 = pure Nothing+    | visited && edge == start = pure Nothing+    | otherwise = do+        destination <- readOrigin mutable (edge `xor` 1)+        if destination == to+          then pure (Just edge)+          else do+            previousEdge <- readPrevious mutable edge+            go (remaining - 1) start (previousEdge `xor` 1) True++-- | Validate that both constraint endpoints belong to the mesh.+validateEndpoints :: Triangulation 'Constrained vertex directed undirected face -> VertexId -> VertexId -> Either (CdtError) ()+validateEndpoints triangulation from to+  | not (validVertex triangulation from) = Left (InvalidConstraintVertex from)+  | not (validVertex triangulation to) = Left (InvalidConstraintVertex to)+  | otherwise = Right ()++-- | Whether a vertex handle is admitted by the triangulation.+validVertex :: Triangulation 'Constrained vertex directed undirected face -> VertexId -> Bool+validVertex triangulation (VertexId vertex) = fromIntegral vertex < Dcel.numVertices triangulation
+ src-build/Moonlight/Triangulation/Internal/Cdt/Recovery.hs view
@@ -0,0 +1,397 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Interpretation of a recovery program against the thawed mesh: conflict+-- strips are flipped away segment by segment and the constraints are set.+module Moonlight.Triangulation.Internal.Cdt.Recovery+  ( ConflictRecovery (..)+  , applyMutableConstraint+  , emptyConstraintRequest+  , recoverMutableRequest+  , recoverMutableProgramPiece+  , recordRecoveredSegment+  , resolveConflictStrip+  , mutableEdgeCrosses+  ) where++import Control.Monad.ST (ST)+import Data.Bits (xor)+import Data.Either (isRight)+import Data.Foldable (traverse_)+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Internal.Cdt.Combinators+  ( foldWhileM+  )+import Moonlight.Triangulation.Internal.Cdt.Corridor+  ( constraintWorkspaceFor+  , existingProgramTag+  , readConstraintProgram+  , recoverProgramTag+  , scanMutableConstraint+  )+import Moonlight.Triangulation.Internal.Cdt.Query (findMutableEdge)+import Moonlight.Triangulation.Internal.Cdt.Types+import Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite (flipEdge)+import Moonlight.Triangulation.Internal.DcelOperations.FlipRule (isFlippableEdge)+import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeEdges)+import Moonlight.Triangulation.Internal.Growable (GrowableWord32)+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , readScratch+  , writeScratch+  )+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Internal.Predicates (orient2dCoordinates)++data ConflictRecovery = ConflictRecovery+  { recoveredConstraintEdge :: {-# UNPACK #-} !Int+  , recoveredConstraintFresh :: !Bool+  }++-- | Admit one request against the thawed mesh and recover it. Every constraint+-- verb in this module reaches the topology through here; the callers differ+-- only in what they do with a rejection and in when they publish.+applyMutableConstraint+  :: GrowableWord32 s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> VertexId+  -> VertexId+  -> ST s (Either (CdtError) MutableConstraintOutcome)+applyMutableConstraint programWords mutable operation from to+  | from == to = pure (Right (MutableConstraintAccepted emptyConstraintRequest))+  | otherwise = do+      workspace <- constraintWorkspaceFor programWords mutable+      scanned <- scanMutableConstraint workspace mutable from to+      case scanned of+        Left failure -> pure (Left failure)+        Right (MutableConstraintScanBlocked blocking) ->+          pure (Right (MutableConstraintRejected (asUndirected blocking)))+        Right (MutableConstraintScanAdmitted program) ->+          fmap MutableConstraintAccepted+            <$> recoverMutableRequest workspace mutable operation program++emptyConstraintRequest :: ConstraintRequestAccumulator+emptyConstraintRequest =+  ConstraintRequestAccumulator+    { accumulatedRequestPath = []+    , accumulatedRequestAddedEdges = 0+    , accumulatedRequestCorridors = 0+    , accumulatedRequestReusedFaces = 0+    , accumulatedRequestCrossedEdges = 0+    }++recoverMutableRequest+  :: ConstraintWorkspace s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> MutableConstraintProgram+  -> ST s (Either (CdtError) ConstraintRequestAccumulator)+recoverMutableRequest workspace mutable operation program = do+  interpreted <-+    foldWhileM+      isRight+      (recoverMutableProgramPiece workspace mutable operation (mutableProgramWordCount program))+      ( Right+          ConstraintProgramAccumulator+            { accumulatedProgramCursor = 0+            , accumulatedProgramRequest = emptyConstraintRequest+            }+      )+      [1 .. mutableProgramPieceCount program]+  pure $ case interpreted of+    Left obstruction -> Left obstruction+    Right completed+      | accumulatedProgramCursor completed == mutableProgramWordCount program ->+          Right (accumulatedProgramRequest completed)+      | otherwise ->+          Left+            ( ConstraintCorridorObstructed+                (CorridorProgramMalformed (accumulatedProgramCursor completed))+            )++recoverMutableProgramPiece+  :: ConstraintWorkspace s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Either (CdtError) ConstraintProgramAccumulator+  -> Int+  -> ST s (Either (CdtError) ConstraintProgramAccumulator)+recoverMutableProgramPiece _ _ _ _ failed@(Left _) _ = pure failed+recoverMutableProgramPiece workspace mutable operation wordCount (Right accumulator) _ = do+  let !cursor = accumulatedProgramCursor accumulator+      malformed =+        Left+          ( ConstraintCorridorObstructed+              (CorridorProgramMalformed cursor)+          )+  if cursor < 0 || cursor >= wordCount+    then pure malformed+    else do+      tag <- readConstraintProgram workspace cursor+      case tag of+        _+          | tag == existingProgramTag && cursor + 1 < wordCount -> do+              edge <- readConstraintProgram workspace (cursor + 1)+              fresh <- setConstraint mutable edge+              pure+                ( Right+                    accumulator+                      { accumulatedProgramCursor = cursor + 2+                      , accumulatedProgramRequest =+                          recordRecoveredSegment+                            (accumulatedProgramRequest accumulator)+                            edge+                            fresh+                            0+                            0+                      }+                )+          | tag == recoverProgramTag && cursor + 3 < wordCount -> do+              rawFrom <- readConstraintProgram workspace (cursor + 1)+              rawTo <- readConstraintProgram workspace (cursor + 2)+              conflictCount <- readConstraintProgram workspace (cursor + 3)+              let !conflictStart = cursor + 4+                  !nextCursor = conflictStart + conflictCount+                  !from = VertexId (fromIntegral rawFrom)+                  !to = VertexId (fromIntegral rawTo)+              if conflictCount < 0 || nextCursor > wordCount+                then pure malformed+                else do+                  direct <- findMutableEdge mutable rawFrom rawTo+                  recovered <-+                    case direct of+                      Just edge -> do+                        fresh <- setConstraint mutable edge+                        pure+                          ( Right+                              ConflictRecovery+                                { recoveredConstraintEdge = edge+                                , recoveredConstraintFresh = fresh+                                }+                          )+                      Nothing+                        | conflictCount == 0 ->+                            pure+                              ( Left+                                  ( ConstraintCorridorObstructed+                                      (CorridorTargetMissing from to)+                                  )+                              )+                        | otherwise ->+                            resolveConflictStrip+                              workspace+                              mutable+                              operation+                              from+                              to+                              conflictStart+                              conflictCount+                  pure $ case recovered of+                    Left obstruction -> Left obstruction+                    Right recovery ->+                      Right+                        accumulator+                          { accumulatedProgramCursor = nextCursor+                          , accumulatedProgramRequest =+                              recordRecoveredSegment+                                (accumulatedProgramRequest accumulator)+                                (recoveredConstraintEdge recovery)+                                (recoveredConstraintFresh recovery)+                                conflictCount+                                (if conflictCount == 0 then 0 else conflictCount + 1)+                          }+          | otherwise -> pure malformed++recordRecoveredSegment+  :: ConstraintRequestAccumulator+  -> Int+  -> Bool+  -> Int+  -> Int+  -> ConstraintRequestAccumulator+recordRecoveredSegment accumulator edge fresh crossed reusedFaces =+  accumulator+    { accumulatedRequestPath = DirectedEdgeId (fromIntegral edge) : accumulatedRequestPath accumulator+    , accumulatedRequestAddedEdges =+        accumulatedRequestAddedEdges accumulator + if fresh then 1 else 0+    , accumulatedRequestCorridors =+        accumulatedRequestCorridors accumulator + if crossed == 0 then 0 else 1+    , accumulatedRequestReusedFaces =+        accumulatedRequestReusedFaces accumulator + reusedFaces+    , accumulatedRequestCrossedEdges =+        accumulatedRequestCrossedEdges accumulator + crossed+    }++resolveConflictStrip+  :: ConstraintWorkspace s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> VertexId+  -> VertexId+  -> Int+  -> Int+  -> ST s (Either (CdtError) ConflictRecovery)+resolveConflictStrip workspace mutable operation from to conflictStart stripLength = do+  fromPoint <- pointAt mutable (vertexIdIndex from)+  toPoint <- pointAt mutable (vertexIdIndex to)+  traverse_+    (\index -> do+      edge <- readConstraintProgram workspace (conflictStart + index)+      writeScratch operation index edge+    )+    [0 .. stripLength - 1]+  recovered <-+    recover+      stripLength+      safetyBudget+      0+      0+      stripLength+      stripLength+      []+      fromPoint+      toPoint+  case recovered of+    Left failure -> pure (Left failure)+    Right (edge, flipped) -> do+      fresh <- setConstraint mutable edge+      legalizeEdges mutable operation flipped+      pure+        ( Right+            ConflictRecovery+              { recoveredConstraintEdge = edge+              , recoveredConstraintFresh = fresh+              }+        )+ where+  safetyBudget = max 64 (32 * (stripLength + 1) * (stripLength + 1))++  -- The corridor is an ordered section through the current triangulation.+  -- Until an original section is dequeued, no flip can have changed that+  -- edge's endpoints: flips only repurpose the identity being flipped, and+  -- requeued identities remain behind every unseen original in this FIFO.+  -- Consequently the first visit inherits the crossing proof established by+  -- the corridor walk. Only requeued edges require the predicate again.+  recover !capacity !remaining !stalled !headIndex !pendingCount !unseenOriginalCount !flipped !fromPoint !toPoint+    | remaining <= 0 =+        pure+          ( Left+              ( ConstraintRecoverySafetyBudgetExhausted+                  from+                  to+                  safetyBudget+                  (safetyBudget - remaining)+              )+          )+    | pendingCount <= 0 = do+        direct <- findMutableEdge mutable (vertexIdIndex from) (vertexIdIndex to)+        case direct of+          Just edge -> pure (Right (edge, flipped))+          Nothing ->+            pure+              (Left (ConstraintRecoveryStripExhausted from to stripLength))+    | otherwise = do+        edge <- readScratch operation headIndex+        let !nextHead = advance capacity headIndex+            !restCount = pendingCount - 1+            !nextUnseenOriginalCount = max 0 (unseenOriginalCount - 1)+        stillCrosses <-+          if unseenOriginalCount > 0+            then pure True+            else mutableEdgeCrosses mutable fromPoint toPoint edge+        if not stillCrosses+          then recover capacity (remaining - 1) 0 nextHead restCount nextUnseenOriginalCount flipped fromPoint toPoint+          else do+            flippable <- isFlippableEdge mutable edge+            if flippable+              then do+                rewritten <- flipEdge mutable edge+                case rewritten of+                  Left obstruction -> pure (Left (CdtBuildError obstruction))+                  Right () -> do+                    addCounter operation CounterEdgeFlips 1+                    crossesAfterFlip <- mutableEdgeCrosses mutable fromPoint toPoint edge+                    if crossesAfterFlip+                      then do+                        enqueue capacity nextHead restCount edge+                        recover+                          capacity+                          (remaining - 1)+                          0+                          nextHead+                          (restCount + 1)+                          nextUnseenOriginalCount+                          (edge : flipped)+                          fromPoint+                          toPoint+                      else recover capacity (remaining - 1) 0 nextHead restCount nextUnseenOriginalCount (edge : flipped) fromPoint toPoint+              else do+                enqueue capacity nextHead restCount edge+                let !nextCount = restCount + 1+                    !nextStalled = stalled + 1+                if nextStalled >= nextCount+                  then+                    pure+                      ( Left+                          ( ConstraintRecoveryStripUnflippable+                              from+                              to+                              (DirectedEdgeId (fromIntegral edge))+                              nextCount+                          )+                      )+                  else recover capacity (remaining - 1) nextStalled nextHead nextCount nextUnseenOriginalCount flipped fromPoint toPoint++  enqueue !capacity !headIndex !count !edge =+    writeScratch operation (wrap capacity (headIndex + count)) edge++  advance :: Int -> Int -> Int+  advance !capacity !index+    | index + 1 == capacity = 0+    | otherwise = index + 1++  wrap :: Int -> Int -> Int+  wrap !capacity !index+    | index >= capacity = index - capacity+    | otherwise = index++mutableEdgeCrosses+  :: MutableDcel s vertex directed undirected face+  -> Point+  -> Point+  -> Int+  -> ST s Bool+mutableEdgeCrosses+  mutable+  (Point lineFromX lineFromY)+  (Point lineToX lineToY)+  edge = do+    edgeFromVertex <- readOrigin mutable edge+    edgeToVertex <- readOrigin mutable (edge `xor` 1)+    Point edgeFromX edgeFromY <- pointAt mutable edgeFromVertex+    Point edgeToX edgeToY <- pointAt mutable edgeToVertex+    let !edgeFromSide =+          orient2dCoordinates+            lineFromX lineFromY lineToX lineToY edgeFromX edgeFromY+        !edgeToSide =+          orient2dCoordinates+            lineFromX lineFromY lineToX lineToY edgeToX edgeToY+        !lineFromSide =+          orient2dCoordinates+            edgeFromX edgeFromY edgeToX edgeToY lineFromX lineFromY+        !lineToSide =+          orient2dCoordinates+            edgeFromX edgeFromY edgeToX edgeToY lineToX lineToY+    pure+      ( opposite edgeFromSide edgeToSide+          && opposite lineFromSide lineToSide+      )+ where+  opposite LT GT = True+  opposite GT LT = True+  opposite _ _ = False
+ src-build/Moonlight/Triangulation/Internal/Cdt/Region.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DataKinds #-}++-- | The two-sided reading of the constrained domain: which faces lie outside+-- the protected boundary and which lie within it.+module Moonlight.Triangulation.Internal.Cdt.Region+  ( outerRegionFaces+  , boundedRegionFaces+  ) where++import qualified Data.IntSet as IntSet+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.FloodFillIterator (facesAtEvenBarrierDepth)+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (innerFaces)+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types++-- | Inner faces at even minimum constraint-crossing depth from the outer face.+outerRegionFaces+  :: Triangulation 'Constrained vertex directed undirected face+  -> [FaceId]+-- Crossing depth, not bare reachability. A face lies outside the constrained+-- domain when the fewest constraints separating it from the outer face is even,+-- so the hole of an annulus (two crossings) is outside exactly as its exterior+-- (none) is. Reachability alone is the depth-zero layer and calls that hole+-- domain, which would mesh it.+outerRegionFaces triangulation =+  facesAtEvenBarrierDepth triangulation (Dcel.isConstraintEdge triangulation)++-- | Inner faces enclosed at odd constraint-crossing depth.+boundedRegionFaces+  :: Triangulation 'Constrained vertex directed undirected face+  -> [FaceId]+boundedRegionFaces triangulation =+  [ face+  | face <- innerFaces triangulation+  , not (IntSet.member (faceIdIndex face) outside)+  ]+ where+  outside = IntSet.fromList (fmap faceIdIndex (outerRegionFaces triangulation))
+ src-build/Moonlight/Triangulation/Internal/Cdt/Segment.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | The singleton segment verbs: glue one segment or a polyline, and retire a+-- constraint, each inside one sealed transaction.+module Moonlight.Triangulation.Internal.Cdt.Segment+  ( addConstraintEdge+  , addConstraintEdges+  , removeConstraintEdge+  , retireConstraintEdge+  ) where++import Control.Monad.ST (ST)+import Data.Bifunctor (first)+import qualified Data.Vector as V+import Data.Primitive.PrimArray (indexPrimArray, sizeofPrimArray)+import Moonlight.Triangulation.BulkLoad (insertMany)+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Internal.Cdt.Admission+  ( ConstraintAdmission (..)+  , constraintAdmission+  )+import Moonlight.Triangulation.Internal.Cdt.Batch (recoverConstraints)+import Moonlight.Triangulation.Internal.Cdt.Combinators+  ( asConstraintStep+  , bindMutable+  )+import Moonlight.Triangulation.Internal.Cdt.Recovery (applyMutableConstraint)+import Moonlight.Triangulation.Internal.Cdt.Site+  ( lookupExistingConstraintEndpoint+  , placeConstraintEndpoint+  )+import Moonlight.Triangulation.Internal.Cdt.Types+import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeEdges)+import Moonlight.Triangulation.Internal.Growable+  ( GrowableWord32+  , newGrowableWord32+  )+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState (OperationState)+import Moonlight.Triangulation.Internal.Paged (TransactionShape (LocalTransaction))+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Transaction (runUnmeasuredTransaction)+import Moonlight.Triangulation.Internal.Types++-- | Site both endpoints and glue the segment between them, in one transaction.+-- A refused request publishes nothing, so the caller's triangulation still+-- stands and the endpoints it would have sited are not among its vertices.+addConstraintEdge+  :: forall vertex directed undirected face+   . HasPosition vertex+  => Triangulation 'Constrained vertex directed undirected face+  -> vertex+  -> vertex+  -> Either (CdtError) (ConstraintResult vertex directed undirected face)+addConstraintEdge triangulation fromVertex toVertex = do+  result <-+    case (fromExisting, toExisting) of+      (Just from, Just to) ->+        case constraintAdmission triangulation from to of+          ConstraintBlocked blocking -> Left (ConstraintIntersection blocking)+          ConstraintAdmitted ->+            applyConstraintToExistingEndpoints+              triangulation+              from+              fromVertex+              to+              toVertex+      _ -> addConstraintWithEndpointPlacement fromExisting toExisting+  pure result+ where+  !fromPoint = position fromVertex+  !toPoint = position toVertex+  !fromExisting = lookupExistingConstraintEndpoint triangulation fromPoint+  !toExisting = lookupExistingConstraintEndpoint triangulation toPoint++  addConstraintWithEndpointPlacement existingFrom existingTo = do+    (request, frozen) <-+      runUnmeasuredTransaction+        CdtBuildError+        LocalTransaction+        triangulation+        (missingEndpointCount existingFrom + missingEndpointCount existingTo)+        $ \mutable operation -> do+            programWords <- newGrowableWord32 256+            asConstraintStep+              (placeOrReuseConstraintEndpoint mutable operation existingFrom fromPoint fromVertex)+              `bindMutable` \from ->+                asConstraintStep+                  (placeOrReuseConstraintEndpoint mutable operation existingTo toPoint toVertex)+                  `bindMutable` \to ->+                    recoverConstraintRequest programWords mutable operation from to+    pure (publishConstraintResult frozen request)++  missingEndpointCount :: Maybe VertexId -> Int+  missingEndpointCount = maybe 1 (const 0)++  placeOrReuseConstraintEndpoint+    :: MutableDcel s vertex directed undirected face+    -> OperationState s+    -> Maybe VertexId+    -> Point+    -> vertex+    -> ST s (Either BuildError VertexId)+  placeOrReuseConstraintEndpoint mutable operation existing point payload =+    case existing of+      Just vertex -> do+        writeVertexData mutable (vertexIdIndex vertex) payload+        pure (Right vertex)+      Nothing -> placeConstraintEndpoint mutable operation Nothing point payload++-- | The common singleton case already owns both sites. Resolve them before+-- opening topology, then retain the original payload semantics in the+-- transaction. The corridor worker is unchanged; only two redundant point+-- locations and two unused vertex-capacity reservations disappear.+applyConstraintToExistingEndpoints+  :: Triangulation 'Constrained vertex directed undirected face+  -> VertexId+  -> vertex+  -> VertexId+  -> vertex+  -> Either (CdtError) (ConstraintResult vertex directed undirected face)+applyConstraintToExistingEndpoints triangulation from fromPayload to toPayload =+  do+    (request, frozen) <-+      runUnmeasuredTransaction CdtBuildError LocalTransaction triangulation 0 $ \mutable operation -> do+        programWords <- newGrowableWord32 256+        writeVertexData mutable (vertexIdIndex from) fromPayload+        writeVertexData mutable (vertexIdIndex to) toPayload+        recoverConstraintRequest programWords mutable operation from to+    pure (publishConstraintResult frozen request)++recoverConstraintRequest+  :: GrowableWord32 s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> VertexId+  -> VertexId+  -> ST s (Either CdtError ConstraintRequestAccumulator)+recoverConstraintRequest programWords mutable operation from to =+  applyMutableConstraint programWords mutable operation from to+    `bindMutable` \applied ->+      case applied of+        MutableConstraintRejected blocking ->+          pure (Left (ConstraintIntersection blocking))+        MutableConstraintAccepted request -> pure (Right request)+{-# INLINE recoverConstraintRequest #-}++-- | Attach one accepted local result to the mesh published by the transaction.+publishConstraintResult+  :: Triangulation 'Constrained vertex directed undirected face+  -> ConstraintRequestAccumulator+  -> ConstraintResult vertex directed undirected face+publishConstraintResult frozen request =+  ConstraintRecoveryResult+    { constraintRecoveryTriangulation = frozen+    , constraintRecoveryPathReceipt = V.fromList (reverse (accumulatedRequestPath request))+    , constraintRecoveryAddedEdges = accumulatedRequestAddedEdges request+    }++-- | Insert a polyline's vertices and recover each adjacent segment as a+-- constraint, optionally closing the final segment back to the first.+addConstraintEdges+  :: HasPosition vertex+  => Triangulation 'Constrained vertex directed undirected face+  -> V.Vector vertex+  -> Bool+  -> Either (CdtError) (Triangulation 'Constrained vertex directed undirected face)+addConstraintEdges triangulation polylineVertices closed+  | V.null polylineVertices = Right triangulation+  | otherwise = do+      (withVertices, handles) <- insertPolylineVertices triangulation polylineVertices+      let adjacent = V.zip handles (V.drop 1 handles)+          closing =+            if closed && V.length handles > 1+              then+                case (handles V.!? (V.length handles - 1), handles V.!? 0) of+                  (Just finalVertex, Just firstVertex) ->+                    V.singleton (finalVertex, firstVertex)+                  _ -> V.empty+              else V.empty+      batch <- recoverConstraints withVertices (adjacent V.++ closing)+      case V.foldl' firstBlocking Nothing (constraintBatchOutcomes batch) of+        Nothing -> Right (constraintBatchTriangulation batch)+        Just blocking -> Left (ConstraintIntersection blocking)+ where+  firstBlocking found@(Just _) _ = found+  firstBlocking Nothing outcome =+    case outcome of+      ConstraintAccepted _ _ -> Nothing+      ConstraintRejected blocking -> Just blocking++insertPolylineVertices+  :: HasPosition vertex+  => Triangulation 'Constrained vertex directed undirected face+  -> V.Vector vertex+  -> Either (CdtError) (Triangulation 'Constrained vertex directed undirected face, V.Vector VertexId)+insertPolylineVertices triangulation points = do+  result <- first CdtBuildError (insertMany triangulation points)+  let !mapping = buildInputVertices result+  pure (buildTriangulation result, V.generate (sizeofPrimArray mapping) (VertexId . indexPrimArray mapping))++-- | Retire one constraint edge and restore local Delaunay legality.+removeConstraintEdge+  :: Triangulation 'Constrained vertex directed undirected face+  -> UndirectedEdgeId+  -> Either (CdtError) (Triangulation 'Constrained vertex directed undirected face)+removeConstraintEdge triangulation edge+  | undirectedEdgeIdIndex edge >= edgeCount =+      Left (ConstraintEdgeIndexOutOfRange edge edgeCount)+  -- An edge carrying no constraint has nothing to retire, and answering that+  -- without thawing is the difference between O(1) and a republished mesh.+  | not (Dcel.isConstraintEdge triangulation edge) = Right triangulation+  | otherwise = do+      (_, frozen) <-+        runUnmeasuredTransaction CdtBuildError LocalTransaction triangulation 0 $ \mutable operation ->+          retireConstraintEdge mutable operation edge+      pure frozen+ where+  edgeCount = Dcel.numUndirectedEdges triangulation++-- | Retire one constraint inside the open transaction and restore the Delaunay+-- property across the edge it protected.+retireConstraintEdge+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> UndirectedEdgeId+  -> ST s (Either (CdtError) ())+retireConstraintEdge mutable operation edge = do+  halfEdges <- directedEdgeCount mutable+  let !directed = directedEdgeIdIndex (normalizedDirected edge)+  if directed >= halfEdges+    then pure (Left (ConstraintEdgeIndexOutOfRange edge (halfEdges `quot` 2)))+    else do+      constrained <- readConstraint mutable directed+      if not constrained+        then pure (Right ())+        else do+          _ <- clearConstraint mutable directed+          legalizeEdges mutable operation [directed]+          pure (Right ())
+ src-build/Moonlight/Triangulation/Internal/Cdt/Site.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Siting of constraint endpoints: resolving a point to an existing handle,+-- and materializing one inside an open transaction when it has none.+module Moonlight.Triangulation.Internal.Cdt.Site+  ( lookupExistingConstraintEndpoint+  , placeConstraintEndpoint+  ) where++import Control.Monad.ST (ST)+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Insertion (insertVertexAtPoint)+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  )+import Moonlight.Triangulation.Internal.PointIndex (lookupPointIndex)+import Moonlight.Triangulation.Internal.Probe (Probe (..))+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Math++lookupExistingConstraintEndpoint+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> Maybe VertexId+lookupExistingConstraintEndpoint triangulation point =+  VertexId . fromIntegral+    <$> lookupPointIndex+      (triPointX triangulation)+      (triPointY triangulation)+      (triPointIndex triangulation)+      point++-- | Materialize one point in the open transaction. A payload standing at an+-- occupied position keeps that handle and overwrites the payload, which is what+-- the persistent insertion verb settled on.+--+-- The coordinates are checked here rather than by the callers, because a split+-- point is computed rather than supplied: @lineIntersection@ refuses only a+-- zero denominator, and a denominator merely close to zero answers a coordinate+-- no arena should hold.+placeConstraintEndpoint+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Maybe Int+  -> Point+  -> vertex+  -> ST s (Either BuildError VertexId)+placeConstraintEndpoint mutable operation hint point payload =+  case validatePoint Nothing point of+    Left failure -> pure (Left failure)+    Right _ -> do+      addCounter operation CounterInputPoints 1+      outcome <- insertVertexAtPoint @'ProbeOff mutable operation hint point payload+      case outcome of+        Left failure -> pure (Left failure)+        Right (vertex, disposition) -> do+          case disposition of+            AlreadyPresent -> do+              writeVertexData mutable vertex payload+              addCounter operation CounterExistingPoints 1+              addCounter operation CounterDuplicatePoints 1+            Inserted -> addCounter operation CounterUniquePoints 1+          pure (Right (VertexId (fromIntegral vertex)))
+ src-build/Moonlight/Triangulation/Internal/Cdt/Split.hs view
@@ -0,0 +1,472 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | The splitting program: corridors that divide every constraint they cross,+-- driven across as few sealed transactions as the vertex reservation allows.+module Moonlight.Triangulation.Internal.Cdt.Split+  ( addConstraintAndSplit+  , addConstraintsAndSplit+  ) where++import Control.Monad.ST (ST)+import Data.Bits (xor)+import qualified Data.List as List+import qualified Data.Vector as V+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Internal.Cdt.Combinators+  ( asConstraintStep+  , bindMutable+  )+import Moonlight.Triangulation.Internal.Cdt.Corridor+  ( constraintWorkspaceFor+  , scanMutableConstraint+  )+import Moonlight.Triangulation.Internal.Cdt.Query+  ( findMutableEdge+  , getConflictingEdgesBetweenVertices+  , validateEndpoints+  )+import Moonlight.Triangulation.Internal.Cdt.Recovery+  ( applyMutableConstraint+  , recoverMutableRequest+  )+import Moonlight.Triangulation.Internal.Cdt.Segment (retireConstraintEdge)+import Moonlight.Triangulation.Internal.Cdt.Site (placeConstraintEndpoint)+import Moonlight.Triangulation.Internal.Cdt.Types+import Moonlight.Triangulation.Internal.Growable+  ( GrowableWord32+  , newGrowableWord32+  )+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState (OperationState)+import Moonlight.Triangulation.Internal.Paged+  ( TransactionShape (DenseTransaction, LocalTransaction)+  )+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Transaction (runUnmeasuredTransaction)+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Math++-- | The part of a splitting request that does not move: the payload maker, the+-- endpoints the failure report must name, the iteration budget, and the+-- transaction's vertex reservation, past which the corridor suspends rather+-- than writes.+data SplitRequest vertex = SplitRequest+  { splitRequestMakeVertex :: !(Point -> vertex)+  , splitRequestFrom :: !VertexId+  , splitRequestTo :: !VertexId+  , splitRequestBudget :: {-# UNPACK #-} !Int+  , splitRequestVertexBound :: {-# UNPACK #-} !Int+  }++-- | The part that does: how much budget is left, which vertex the unrecovered+-- remainder starts at, and the path and edge count accumulated behind it. The+-- path runs newest-first and is reversed once, at publication.+data SplitCursor = SplitCursor+  { splitCursorRemaining :: {-# UNPACK #-} !Int+  , splitCursorAt :: !VertexId+  , splitCursorPath :: ![DirectedEdgeId]+  , splitCursorAdded :: {-# UNPACK #-} !Int+  }++-- | How a corridor run ends inside its transaction: settled at the target, or+-- suspended mid-corridor because the next division would outgrow the vertex+-- reservation. A suspension is not a refusal; the driver publishes,+-- re-reserves against the published mesh, and resumes at the cursor.+data SplitStep+  = SplitSettled !SplitCursor+  | SplitSuspended !SplitCursor++-- | What one settled request leaves behind.+data SplitReceipt = SplitReceipt+  { splitReceiptPath :: !(V.Vector DirectedEdgeId)+  , splitReceiptAdded :: {-# UNPACK #-} !Int+  }++-- | Glue the requested segment, dividing every constraint it crosses at the+-- crossing point rather than refusing it. One transaction carries the whole+-- corridor: a singleton is a batch of one under the shared driver.+addConstraintAndSplit+  :: (Point -> vertex)+  -> Triangulation 'Constrained vertex directed undirected face+  -> VertexId+  -> VertexId+  -> Either (CdtError) (ConstraintResult vertex directed undirected face)+addConstraintAndSplit makeVertex triangulation from to = do+  (published, receipts) <-+    driveConstraintSplits LocalTransaction makeVertex triangulation (V.singleton (from, to))+  pure+    ( case receipts V.!? 0 of+        Just receipt ->+          ConstraintRecoveryResult+            { constraintRecoveryTriangulation = published+            , constraintRecoveryPathReceipt = splitReceiptPath receipt+            , constraintRecoveryAddedEdges = splitReceiptAdded receipt+            }+        Nothing -> ConstraintRecoveryResult published V.empty 0+    )++-- | Divide every requested segment inside as few transactions as the vertex+-- reservation allows: usually one, which is the referent semantics for a+-- splitting batch. Nothing is republished between corridors unless a corridor+-- crosses constraints created by an earlier request in the same batch --+-- growth no census against the base can see. In that one case the corridor+-- suspends, the chunk publishes, and the driver re-reserves against the+-- published mesh and resumes at the suspended cursor.+addConstraintsAndSplit+  :: (Point -> vertex)+  -> Triangulation 'Constrained vertex directed undirected face+  -> V.Vector (VertexId, VertexId)+  -> Either (CdtError) (ConstraintSplitBatchResult vertex directed undirected face)+addConstraintsAndSplit makeVertex triangulation requests = do+  (published, receipts) <- driveConstraintSplits DenseTransaction makeVertex triangulation requests+  pure+    ConstraintRecoveryResult+      { constraintRecoveryTriangulation = published+      , constraintRecoveryPathReceipt = V.map splitReceiptPath receipts+      , constraintRecoveryAddedEdges = V.sum (V.map splitReceiptAdded receipts)+      }++-- | The obstruction census for one request against a published mesh: how many+-- constrained crossings its corridor holds, and the first of them. The first+-- crossing is a valid local section of the next transaction before any rewrite+-- occurs, so a chunk's first request carries it across the thaw boundary+-- instead of immediately rediscovering it; every later request rescans,+-- because earlier corridors may have rewritten the topology the witness names.+splitCensus+  :: Triangulation 'Constrained vertex directed undirected face+  -> (VertexId, VertexId)+  -> (Int, Maybe DirectedEdgeId)+splitCensus triangulation (from, to)+  | from == to = (0, Nothing)+  | otherwise =+      List.foldl'+        countCrossing+        (0, Nothing)+        (getConflictingEdgesBetweenVertices triangulation from to)+ where+  countCrossing :: (Int, Maybe DirectedEdgeId) -> DirectedEdgeId -> (Int, Maybe DirectedEdgeId)+  countCrossing (!count, firstCrossing) crossing =+    ( count + 1+    , case firstCrossing of+        Just first -> Just first+        Nothing -> Just crossing+    )++-- | Interpret splitting requests in order across as few sealed transactions as+-- possible. Each chunk reserves against the exact obstruction census of every+-- remaining request, so a chunk always settles at least its first request:+-- that census ran against the very mesh the chunk thawed and is exact before+-- any in-session rewrite. Termination follows.+driveConstraintSplits+  :: forall vertex directed undirected face.+     TransactionShape+  -> (Point -> vertex)+  -> Triangulation 'Constrained vertex directed undirected face+  -> V.Vector (VertexId, VertexId)+  -> Either+      (CdtError)+      ( Triangulation 'Constrained vertex directed undirected face+      , V.Vector SplitReceipt+      )+driveConstraintSplits shape makeVertex base requests = do+  V.mapM_ (uncurry (validateEndpoints base)) requests+  if V.all (uncurry (==)) requests+    then Right (base, V.replicate (V.length requests) emptySplitReceipt)+    else advance base 0 [] Nothing+ where+  emptySplitReceipt = SplitReceipt V.empty 0++  advance+    :: Triangulation 'Constrained vertex directed undirected face+    -> Int+    -> [SplitReceipt]+    -> Maybe SplitCursor+    -> Either+        CdtError+        ( Triangulation 'Constrained vertex directed undirected face+        , V.Vector SplitReceipt+        )+  advance triangulation start settled resumed+    | start >= V.length requests =+        Right (triangulation, V.fromList (reverse settled))+    | otherwise = do+        let remaining = V.drop start requests+            firstRound = start == 0 && case resumed of+              Nothing -> True+              Just _ -> False+            -- The opening chunk reserves optimistically -- one crossing per+            -- request -- rather than walking every corridor for an exact+            -- census before any work begins. A request that outgrows the+            -- reservation suspends mid-corridor with its partial work kept,+            -- and the next round censuses exactly against the published mesh,+            -- so heavy batches pay at most one speculative chunk.+            censuses+              | firstRound = V.replicate (V.length remaining) (1, Nothing)+              | otherwise = V.map (splitCensus triangulation) remaining+            !reservedSites = V.sum (V.map fst censuses)+            !additionalCapacity = 2 * reservedSites + 8+            -- The walk budget bounds divisions per request; constraints born+            -- inside the chunk are covered by the reservation term.+            !budget =+              2 * (Dcel.numConstraints triangulation + 2 * reservedSites + V.length remaining)+                + Dcel.numUndirectedEdges triangulation+                + 8+        ((receipts, suspended), published) <-+          runUnmeasuredTransaction+            CdtBuildError+            shape+            triangulation+            additionalCapacity+            $ \mutable operation -> do+            programWords <- newGrowableWord32 32+            runSplitChunk+              makeVertex+              mutable+              operation+              programWords+              remaining+              censuses+              (pointCapacity mutable)+              budget+              resumed+        advance published (start + length receipts) (receipts ++ settled) suspended++-- | One sealed transaction over a prefix of the remaining requests. Receipts+-- run newest-first; a suspension carries no receipt, so the settled count is+-- exactly the receipt count.+runSplitChunk+  :: (Point -> vertex)+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> GrowableWord32 s+  -> V.Vector (VertexId, VertexId)+  -> V.Vector (Int, Maybe DirectedEdgeId)+  -> Int+  -> Int+  -> Maybe SplitCursor+  -> ST s (Either CdtError ([SplitReceipt], Maybe SplitCursor))+runSplitChunk makeVertex mutable operation programWords requests censuses capacity budget resumed =+  go 0 [] resumed+ where+  go offset receipts pending+    | offset >= V.length requests = pure (Right (receipts, Nothing))+    | otherwise =+        let (from, to) = requests V.! offset+        in case pending of+             Nothing+               | from == to ->+                   go (offset + 1) (SplitReceipt V.empty 0 : receipts) Nothing+             _ ->+               let witness = if offset == 0 then snd (censuses V.! 0) else Nothing+                   cursor = case pending of+                     Just resumedCursor -> resumedCursor+                     Nothing -> SplitCursor budget from [] 0+                   request =+                     SplitRequest+                       { splitRequestMakeVertex = makeVertex+                       , splitRequestFrom = from+                       , splitRequestTo = to+                       , splitRequestBudget = budget+                       , splitRequestVertexBound = capacity+                       }+               in splitConstraintCorridor request programWords mutable operation witness cursor+                    `bindMutable` \step ->+                      case step of+                        SplitSettled settledCursor ->+                          go (offset + 1) (receiptOf settledCursor : receipts) Nothing+                        SplitSuspended suspendedCursor ->+                          pure (Right (receipts, Just suspendedCursor))++  receiptOf cursor =+    SplitReceipt+      { splitReceiptPath = V.fromList (reverse (splitCursorPath cursor))+      , splitReceiptAdded = splitCursorAdded cursor+      }++splitConstraintCorridor+  :: SplitRequest vertex+  -> GrowableWord32 s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Maybe DirectedEdgeId+  -> SplitCursor+  -> ST s (Either (CdtError) SplitStep)+splitConstraintCorridor request programWords mutable operation initialCrossing initialCursor =+  case initialCrossing of+    Just crossing -> divide initialCursor crossing+    Nothing -> descend initialCursor+ where+  !target = splitRequestTo request++  descend cursor+    | splitCursorRemaining cursor <= 0 =+        pure+          ( Left+              ( ConstraintSplitBudgetExhausted+                  (splitRequestFrom request)+                  target+                  (splitRequestBudget request)+              )+          )+    | otherwise = do+        workspace <- constraintWorkspaceFor programWords mutable+        scanMutableConstraint workspace mutable (splitCursorAt cursor) target+          `bindMutable` \scanned ->+            case scanned of+              MutableConstraintScanAdmitted program ->+                recoverMutableRequest workspace mutable operation program+                  `bindMutable` \final ->+                    pure+                      ( Right+                          ( SplitSettled+                              (advanceCursor cursor (splitCursorRemaining cursor) target final)+                          )+                      )+              MutableConstraintScanBlocked crossing -> divide cursor crossing++  divide cursor crossing = do+    occupied <- pointCount mutable+    if occupied + 2 > splitRequestVertexBound request+      then pure (Right (SplitSuspended cursor))+      else divideWithin cursor crossing++  divideWithin cursor crossing = do+    let !crossingEdge = directedEdgeIdIndex crossing+        !oldConstraint = asUndirected crossing+    segmentFrom <- pointAt mutable (vertexIdIndex (splitCursorAt cursor))+    segmentTo <- pointAt mutable (vertexIdIndex target)+    oldFrom <- readOrigin mutable crossingEdge+    oldTo <- readOrigin mutable (crossingEdge `xor` 1)+    edgeFrom <- pointAt mutable oldFrom+    edgeTo <- pointAt mutable oldTo+    -- The split point lies on the crossing edge, so both its incident faces+    -- already contain it and the exact walk settles on its first probe. Without+    -- this the locate is unhinted, and an unhinted locate descends vertex by+    -- vertex from the arena's first face -- a distance that grows with the mesh+    -- while the corridor it is splitting stays a fixed few faces wide. A hull+    -- edge carries the outer face on one side, which the locator would refuse.+    incidentFace <- readFace mutable crossingEdge+    twinFace <- readFace mutable (crossingEdge `xor` 1)+    let !splitHint = Just (if incidentFace > 0 then incidentFace else twinFace)+    let !oldEndpoints =+          ( VertexId (fromIntegral oldFrom)+          , VertexId (fromIntegral oldTo)+          )+    case lineIntersection crossing segmentFrom segmentTo edgeFrom edgeTo of+      Left indeterminate -> pure (Left indeterminate)+      Right splitPoint ->+        -- The split lands where the intersection says, not where a round trip+        -- through 'makeVertex' happens to put it.+        asConstraintStep+          ( placeConstraintEndpoint+              mutable+              operation+              splitHint+              splitPoint+              (splitRequestMakeVertex request splitPoint)+          )+          `bindMutable` \splitVertex ->+            repairIfRounded oldConstraint oldEndpoints splitVertex `bindMutable` \() ->+              applyMutableConstraint programWords mutable operation (splitCursorAt cursor) splitVertex+                `bindMutable` \prefix ->+                  case prefix of+                    MutableConstraintRejected blocking ->+                      pure (Left (ConstraintIntersection blocking))+                    MutableConstraintAccepted segment ->+                      descend+                        (advanceCursor cursor (splitCursorRemaining cursor - 1) splitVertex segment)++  repairIfRounded oldConstraint oldEndpoints splitVertex = do+    divided <- mutableEdgeWasSplit mutable oldConstraint oldEndpoints splitVertex+    if divided+      then pure (Right ())+      else repairRoundedSplit programWords mutable operation oldConstraint oldEndpoints splitVertex++  advanceCursor cursor remaining reached segment =+    cursor+      { splitCursorRemaining = remaining+      , splitCursorAt = reached+      , splitCursorPath = accumulatedRequestPath segment ++ splitCursorPath cursor+      , splitCursorAdded = splitCursorAdded cursor + accumulatedRequestAddedEdges segment+      }++-- | Whether the inserted vertex actually divided the constraint it was placed+-- on. It did if that constraint is gone — the split retired the identity — or+-- if both halves now carry one. Rounding can place the vertex somewhere that+-- leaves the old constraint standing and neither half glued.+mutableEdgeWasSplit+  :: MutableDcel s vertex directed undirected face+  -> UndirectedEdgeId+  -> (VertexId, VertexId)+  -> VertexId+  -> ST s Bool+mutableEdgeWasSplit mutable edge (from, to) splitVertex = do+  halfEdges <- directedEdgeCount mutable+  let !directed = directedEdgeIdIndex (normalizedDirected edge)+  stillConstrained <-+    if directed >= halfEdges+      then pure False+      else readConstraint mutable directed+  if not stillConstrained+    then pure True+    else do+      leading <- mutableConstraintBetween mutable from splitVertex+      if leading+        then mutableConstraintBetween mutable splitVertex to+        else pure False++mutableConstraintBetween+  :: MutableDcel s vertex directed undirected face+  -> VertexId+  -> VertexId+  -> ST s Bool+mutableConstraintBetween mutable from to = do+  found <- findMutableEdge mutable (vertexIdIndex from) (vertexIdIndex to)+  case found of+    Nothing -> pure False+    Just edge -> readConstraint mutable edge++-- | The split point rounded onto neither half of the constraint it was meant to+-- divide. Retire the stale identity and glue both halves against the vertex+-- that was actually sited. What this recovers is repair rather than the+-- requested segment, so it contributes nothing to the request's path.+repairRoundedSplit+  :: GrowableWord32 s+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> UndirectedEdgeId+  -> (VertexId, VertexId)+  -> VertexId+  -> ST s (Either (CdtError) ())+repairRoundedSplit programWords mutable operation oldEdge (from, to) splitVertex =+  retireConstraintEdge mutable operation oldEdge `bindMutable` \() ->+    glue from splitVertex `bindMutable` \() -> glue splitVertex to+ where+  glue start end =+    applyMutableConstraint programWords mutable operation start end `bindMutable` \recovered ->+      pure $ case recovered of+        MutableConstraintRejected blocking -> Left (ConstraintIntersection blocking)+        MutableConstraintAccepted _ -> Right ()++lineIntersection+  :: DirectedEdgeId+  -> Point+  -> Point+  -> Point+  -> Point+  -> Either (CdtError) (Point)+lineIntersection crossing (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy)+  | denominator == 0 =+      Left (ConstraintSplitIntersectionIndeterminate crossing)+  | otherwise =+      Right (canonicalPoint (Point (ax + t * rx) (ay + t * ry)))+ where+  rx = bx - ax+  ry = by - ay+  sx = dx - cx+  sy = dy - cy+  denominator = rx * sy - ry * sx+  t = ((cx - ax) * sy - (cy - ay) * sx) / denominator
+ src-build/Moonlight/Triangulation/Internal/Cdt/Types.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | The shared vocabulary of the constrained layer: its refusals, its published+-- results, and the transaction-local state its interpreters carry.+module Moonlight.Triangulation.Internal.Cdt.Types+  ( CdtError (..)+  , CanonicalSegment (..)+  , ConstraintConflict (..)+  , ConstrainedUnionError (..)+  , ConstrainedSeamSide (..)+  , ConstrainedSeamFaceEvidence (..)+  , ConstrainedSeamResult (..)+  , CorridorObstruction (..)+  , ConstraintRecoveryResult (..)+  , ConstraintResult+  , ConstraintOutcome (..)+  , ConstraintBatchStats (..)+  , ConstraintBatchResult (..)+  , ConstrainedExtensionResult (..)+  , ConstraintSplitBatchResult+  , ConstraintBatchAccumulator (..)+  , ConstraintRequestAccumulator (..)+  , ConstraintWorkspace (..)+  , MutableConstraintProgram (..)+  , MutableConstraintOutcome (..)+  , MutableProgramCursor (..)+  , MutablePlanWalk (..)+  , MutableConstraintScan (..)+  , ConstraintProgramAccumulator (..)+  , CdtBuildResult (..)+  ) where++import Control.DeepSeq (NFData)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Vector as V+import Moonlight.Triangulation.Internal.HandleDefs+  ( DirectedEdgeId+  , FaceId+  , UndirectedEdgeId+  , VertexId+  )+import Moonlight.Triangulation.Internal.Growable (GrowableWord32)+import Moonlight.Triangulation.Internal.Paged (PublicationStats)+import Moonlight.Triangulation.Internal.Representation (BuildResult, Triangulation)+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.IntersectionIterator (Intersection)+import GHC.Generics (Generic)++-- | Typed refusal surface for constrained construction and corridor recovery.+data CdtError+  = CdtBuildError !BuildError+  | InvalidConstraintVertex !VertexId+  | ConstraintIntersection !UndirectedEdgeId+  | ConstraintInputConflicts !(V.Vector (Int, Int))+  | ConstraintCorridorObstructed !CorridorObstruction+  | ConstraintBatchCardinalityMismatch+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+  | ConstraintEndpointIndexOutOfRange+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+  | ConstraintSplitBudgetExhausted+      !VertexId+      !VertexId+      {-# UNPACK #-} !Int+  | ConstraintSplitIntersectionIndeterminate+      !DirectedEdgeId+  | ConstraintEdgeIndexOutOfRange+      !UndirectedEdgeId+      {-# UNPACK #-} !Int+  | ConstraintRecoverySafetyBudgetExhausted+      !VertexId+      !VertexId+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+  | ConstraintRecoveryStripExhausted+      !VertexId+      !VertexId+      {-# UNPACK #-} !Int+  | ConstraintRecoveryStripUnflippable+      !VertexId+      !VertexId+      !DirectedEdgeId+      {-# UNPACK #-} !Int+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Geometric identity of one constraint segment. The constructor is private:+-- endpoints are always canonical points in ascending order, so direction and+-- edge numbering cannot leak into union witnesses.+data CanonicalSegment = CanonicalSegment+  { -- | Lesser endpoint under the point ordering.+    segmentStart :: !(Point)+  , -- | Greater endpoint under the point ordering.+    segmentEnd :: !(Point)+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A pair of properly crossing constraints, ordered independently of operand+-- and traversal order.+data ConstraintConflict = ConstraintConflict+  { -- | Lesser segment under the canonical segment ordering.+    conflictFirstSegment :: !(CanonicalSegment)+  , -- | Greater segment under the canonical segment ordering.+    conflictSecondSegment :: !(CanonicalSegment)+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Complete obstruction surface for atomic constrained union.+data ConstrainedUnionError+  = ConstraintUnionConflicts !(NonEmpty (ConstraintConflict))+  | ConstraintUnionConstructionFailed !(CdtError)+  | ConstraintUnionSiteMissing !(Point)+  | ConstraintUnionNotSeparated+  -- | Local publication would otherwise enumerate a dense resident payload+  -- plane. Compact geometry-only payloads before requesting a seam.+  | ConstraintUnionRequiresGeometryOnlyPublication+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Source-local side presented to a separated seam's face-preservation+-- selector. The resident side keeps its handles; incoming face handles are+-- translated only inside the join interpreter.+data ConstrainedSeamSide+  = SeamResident+  | SeamIncoming+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Exact proof that one active source face survives as one target face. The+-- three points are stored in ascending order, so the witness is independent+-- of local face rotation and handle numbering.+data ConstrainedSeamFaceEvidence = ConstrainedSeamFaceEvidence+  { constrainedSeamSourceFace :: !FaceId+    -- ^ Face handle in the source operand.+  , constrainedSeamTargetFace :: !FaceId+    -- ^ Corresponding face handle in the published result.+  , constrainedSeamFaceFirstPoint :: !(Point)+    -- ^ Least vertex position under canonical point order.+  , constrainedSeamFaceSecondPoint :: !(Point)+    -- ^ Middle vertex position under canonical point order.+  , constrainedSeamFaceThirdPoint :: !(Point)+    -- ^ Greatest vertex position under canonical point order.+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Atomic publication of a source-preserving constrained seam and the proof+-- needed to transport solved face-indexed data. The receipt is derived during+-- the ordered append/seam interpretation; canonical numbering remains an+-- explicit observation rather than hidden work in this local operation.+data ConstrainedSeamResult vertex = ConstrainedSeamResult+  { constrainedSeamResultTriangulation+      :: !(Triangulation 'Constrained vertex () () ())+    -- ^ Published constrained union.+  , constrainedSeamLeftFaceCount :: {-# UNPACK #-} !Int+    -- ^ Stable size of the resident source face block. In selective mode this+    -- is a handle-partition witness, not proof that every resident face was+    -- selected.+  , constrainedSeamRightFaceEvidence+      :: !(V.Vector (ConstrainedSeamFaceEvidence))+    -- ^ Exact transport evidence only for selected incoming source faces.+  , constrainedSeamJoinFaces :: !(V.Vector FaceId)+    -- ^ Exact final J component, including rewritten exterior source filler.+  , constrainedSeamLeftConstraintCount :: {-# UNPACK #-} !Int+    -- ^ Stable number of left-source constraints.+  , constrainedSeamConstraintStats :: !ConstraintBatchStats+    -- ^ Constraint recovery work performed by the seam.+  , constrainedSeamBuildStats :: !BuildStats+    -- ^ Topology work performed by the seam.+  , constrainedSeamPublicationStats :: !PublicationStats+    -- ^ Page publication work measured by the transaction owner.+  , constrainedSeamCachedFrontierPointReads :: {-# UNPACK #-} !Int+    -- ^ Frontier point reads performed while interpreting the cached seam.+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++deriving stock instance Eq vertex => Eq (ConstrainedSeamResult vertex)+deriving stock instance Show vertex => Show (ConstrainedSeamResult vertex)++-- | Structural witness that corridor recovery could not complete.+data CorridorObstruction+  = CorridorWalkDidNotTerminate {-# UNPACK #-} !Int+  | CorridorBoundaryMissing !VertexId !VertexId+  | CorridorProgramMalformed {-# UNPACK #-} !Int+  | CorridorTargetMissing !VertexId !VertexId+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | One constrained publication and its path receipt. The path carrier names+-- whether the caller requested one recovered path or an ordered family; the+-- mesh and edge count have one representation in either case.+data ConstraintRecoveryResult pathReceipt vertex directed undirected face = ConstraintRecoveryResult+  { constraintRecoveryTriangulation :: !(Triangulation 'Constrained vertex directed undirected face)+    -- ^ Published constrained triangulation.+  , constraintRecoveryPathReceipt :: !pathReceipt+    -- ^ Recovered path evidence at the operation's requested multiplicity.+  , constraintRecoveryAddedEdges :: {-# UNPACK #-} !Int+    -- ^ Edges created while recovering the path evidence.+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++deriving stock instance+  (Eq pathReceipt, Eq vertex, Eq directed, Eq undirected, Eq face)+  => Eq (ConstraintRecoveryResult pathReceipt vertex directed undirected face)+deriving stock instance+  (Show pathReceipt, Show vertex, Show directed, Show undirected, Show face)+  => Show (ConstraintRecoveryResult pathReceipt vertex directed undirected face)++-- | Atomic result of admitting one constraint segment.+type ConstraintResult vertex directed undirected face =+  ConstraintRecoveryResult (V.Vector DirectedEdgeId) vertex directed undirected face++-- | Per-request outcome in a constraint batch.+data ConstraintOutcome+  = ConstraintAccepted+      !(V.Vector DirectedEdgeId)+      {-# UNPACK #-} !Int+  | ConstraintRejected+      !UndirectedEdgeId+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Aggregate work and disposition counts for a constraint batch.+data ConstraintBatchStats = ConstraintBatchStats+  { constraintBatchRequests :: {-# UNPACK #-} !Int+    -- ^ Requests interpreted.+  , constraintBatchAccepted :: {-# UNPACK #-} !Int+    -- ^ Requests admitted.+  , constraintBatchRejected :: {-# UNPACK #-} !Int+    -- ^ Requests refused by an existing constraint.+  , constraintBatchCorridors :: {-# UNPACK #-} !Int+    -- ^ Recovery corridors opened.+  , constraintBatchReusedFaces :: {-# UNPACK #-} !Int+    -- ^ Existing faces retained while recovering corridors.+  , constraintBatchCrossedEdges :: {-# UNPACK #-} !Int+    -- ^ Edges crossed while tracing corridors.+  }+  deriving stock (Eq, Show, Read, Generic)+  deriving anyclass (NFData)++-- | Atomic publication of one constraint batch and its receipts.+data ConstraintBatchResult vertex directed undirected face = ConstraintBatchResult+  { constraintBatchTriangulation :: !(Triangulation 'Constrained vertex directed undirected face)+    -- ^ Published constrained triangulation.+  , constraintBatchOutcomes :: !(V.Vector ConstraintOutcome)+    -- ^ Outcomes in request order.+  , constraintBatchStats :: !ConstraintBatchStats+    -- ^ Aggregate work performed by the batch.+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++deriving stock instance+  (Eq vertex, Eq directed, Eq undirected, Eq face)+  => Eq (ConstraintBatchResult vertex directed undirected face)+deriving stock instance+  (Show vertex, Show directed, Show undirected, Show face)+  => Show (ConstraintBatchResult vertex directed undirected face)++-- | Receipt of one asymmetric constrained extension. The triangulation and+-- all telemetry arise from the same sealed transaction: base sites were+-- resident, incoming sites were inserted, and only incoming constraints were+-- interpreted. A later refinement is deliberately a separate operation over+-- this immutable result, not a hidden continuation of this transaction.+data ConstrainedExtensionResult vertex directed undirected face = ConstrainedExtensionResult+  { constrainedExtensionConstraintBatch :: {-# UNPACK #-} !(ConstraintBatchResult vertex directed undirected face)+    -- ^ Published extension and incoming-constraint receipts.+  , constrainedExtensionBuildStats :: !BuildStats+    -- ^ Topology work performed by the extension.+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++deriving stock instance+  (Eq vertex, Eq directed, Eq undirected, Eq face)+  => Eq (ConstrainedExtensionResult vertex directed undirected face)+deriving stock instance+  (Show vertex, Show directed, Show undirected, Show face)+  => Show (ConstrainedExtensionResult vertex directed undirected face)++-- | One published mesh carrying every requested division. The paths are+-- per-request receipts in traversal order; a later request may have rewritten+-- topology an earlier path names, which is the same as-traversed reading the+-- singleton path already carries.+type ConstraintSplitBatchResult vertex directed undirected face =+  ConstraintRecoveryResult (V.Vector (V.Vector DirectedEdgeId)) vertex directed undirected face++data ConstraintBatchAccumulator = ConstraintBatchAccumulator+  { accumulatedConstraintOutcomes :: ![ConstraintOutcome]+  , accumulatedConstraintStats :: !ConstraintBatchStats+  }++data ConstraintRequestAccumulator = ConstraintRequestAccumulator+  { accumulatedRequestPath :: ![DirectedEdgeId]+  , accumulatedRequestAddedEdges :: {-# UNPACK #-} !Int+  , accumulatedRequestCorridors :: {-# UNPACK #-} !Int+  , accumulatedRequestReusedFaces :: {-# UNPACK #-} !Int+  , accumulatedRequestCrossedEdges :: {-# UNPACK #-} !Int+  }++data ConstraintWorkspace s = ConstraintWorkspace+  { constraintProgramWords :: !(GrowableWord32 s)+  , constraintWalkBudget :: {-# UNPACK #-} !Int+  }++data MutableConstraintProgram = MutableConstraintProgram+  { mutableProgramWordCount :: {-# UNPACK #-} !Int+  , mutableProgramPieceCount :: {-# UNPACK #-} !Int+  }++-- | What one request did to the thawed mesh. A rejection is a value: the batch+-- interpreter records it and carries on, the singleton verbs abandon the+-- transaction on it, and both readings are lawful because an accepted request+-- may lawfully obstruct a later one.+data MutableConstraintOutcome+  = MutableConstraintRejected !UndirectedEdgeId+  | MutableConstraintAccepted !ConstraintRequestAccumulator++data MutableProgramCursor = MutableProgramCursor+  { mutableCursorAt :: !VertexId+  , mutableCursorHeader :: {-# UNPACK #-} !Int+  , mutableCursorWriteAt :: {-# UNPACK #-} !Int+  , mutableCursorConflictCount :: {-# UNPACK #-} !Int+  , mutableCursorPieceCount :: {-# UNPACK #-} !Int+  , mutableCursorAfterOverlap :: !Bool+  }++data MutablePlanWalk+  = MutablePlanActive !Intersection !MutableProgramCursor+  | MutablePlanComplete !MutableConstraintProgram+  | MutablePlanBlocked !DirectedEdgeId+  | MutablePlanFailed !CorridorObstruction++data MutableConstraintScan+  = MutableConstraintScanBlocked !DirectedEdgeId+  | MutableConstraintScanAdmitted !MutableConstraintProgram++data ConstraintProgramAccumulator = ConstraintProgramAccumulator+  { accumulatedProgramCursor :: {-# UNPACK #-} !Int+  , accumulatedProgramRequest :: !ConstraintRequestAccumulator+  }++-- | Result of maximal constrained construction, including rejected requests.+data CdtBuildResult vertex directed undirected face = CdtBuildResult+  { cdtAcceptedBuild :: {-# UNPACK #-} !(BuildResult 'Constrained vertex directed undirected face)+    -- ^ Canonical build result containing every admitted constraint.+  , cdtRejectedConstraints :: !(V.Vector (Int, Int))+    -- ^ Input-index pairs that could not be admitted.+  }+  deriving stock (Generic)+  deriving anyclass (NFData)
+ src-build/Moonlight/Triangulation/Internal/Cdt/Union.hs view
@@ -0,0 +1,445 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Canonical constraint segments and the atomic partial union of two+-- constrained meshes, retaining or combining their site annotations.+module Moonlight.Triangulation.Internal.Cdt.Union+  ( canonicalSegment+  , constraintSegments+  , unionConstrainedWith+  , unionConstrained+  , joinSeparatedConstrained+  , extendConstrainedWith+  , segmentRequest+  , firstRejected+  , completeConstraintConflicts+  , orderedConflict+  , crossingIsRepresented+  ) where++import Control.Monad.ST (ST)+import qualified Data.Bifunctor as Bifunctor+import Data.Either (isRight)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Vector as V+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Internal.Canonical (canonicalize)+import Moonlight.Triangulation.Insertion (insertAdmittedPointCombining)+import Moonlight.Triangulation.Refinement (validateRefinementParameters)+import Moonlight.Triangulation.Internal.Cdt.Batch+  ( finalizeConstraintBatch+  , interpretConstraintRequests+  , recoverConstraints+  )+import Moonlight.Triangulation.Internal.Cdt.Build (fromDelaunay)+import Moonlight.Triangulation.Internal.Cdt.Combinators (foldWhileM)+import Moonlight.Triangulation.Internal.Cdt.Query (constraintEdges)+import Moonlight.Triangulation.IntersectionIterator (foldCorridorBetweenPoints)+import Moonlight.Triangulation.Internal.Cdt.Types+import Moonlight.Triangulation.Internal.Join.Seam+  ( executeConstrainedSeam+  , planSeam+  , seamExecutionBuildStats+  , seamExecutionPublicationStats+  , seamExecutionCachedFrontierPointReads+  , seamExecutionLeftFaceCount+  , seamExecutionJoinFaces+  , seamExecutionRightFaceEvidence+  , seamExecutionTriangulation+  )+import Moonlight.Triangulation.Internal.Join.SiteSet+  ( SiteSet+  , delaunayFromSiteSet+  , siteSetAssocs+  , siteSetFromTriangulation+  , siteSetPoints+  , siteSetSize+  , siteSetUnionWith+  )+import Moonlight.Triangulation.Internal.BoxedPaged (boxedFill)+import Moonlight.Triangulation.Internal.Paged (TransactionShape (DenseTransaction, LocalTransaction))+import Moonlight.Triangulation.Internal.Predicates+  ( onClosedSegment+  , segmentsProperlyCross+  )+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Mutable (MutableDcel)+import Moonlight.Triangulation.Internal.OperationState (OperationState)+import Moonlight.Triangulation.Internal.Transaction (runTransaction)+import Moonlight.Triangulation.Internal.Types++canonicalSegment :: Point -> Point -> CanonicalSegment+canonicalSegment from to+  | from <= to = CanonicalSegment from to+  | otherwise = CanonicalSegment to from+{-# INLINE canonicalSegment #-}++-- | Geometry of the constraint section, deduplicated and canonically ordered.+constraintSegments+  :: Triangulation 'Constrained vertex directed undirected face+  -> V.Vector (CanonicalSegment)+constraintSegments triangulation =+  V.fromList+    ( Set.toAscList+        ( Set.fromList+            [ canonicalSegment+                (Dcel.vertexPoint triangulation from)+                (Dcel.vertexPoint triangulation to)+            | edge <- constraintEdges triangulation+            , let (from, to) = Dcel.undirectedEndpoints triangulation edge+            ]+        )+    )++-- | Atomic partial union of constrained meshes. Coincident sites combine+-- their annotations before construction. Complete canonical conflict+-- witnesses descend first; a successful branch then reaches the existing+-- batch corridor interpreter exactly once.+unionConstrainedWith+  :: (annotation -> annotation -> annotation)+  -> Triangulation 'Constrained annotation () () ()+  -> Triangulation 'Constrained annotation () () ()+  -> Either+      (ConstrainedUnionError)+      (Triangulation 'Constrained annotation () () ())+unionConstrainedWith combine left right =+  case NonEmpty.nonEmpty (Set.toAscList conflicts) of+    Just witnesses -> Left (ConstraintUnionConflicts witnesses)+    Nothing -> do+      unconstrained <-+        Bifunctor.first+          (ConstraintUnionConstructionFailed . CdtBuildError)+          (delaunayFromSiteSet unionSites)+      requests <- traverse (segmentRequest unconstrained) (V.toList segments)+      recovered <-+        Bifunctor.first ConstraintUnionConstructionFailed+          (recoverConstraints (fromDelaunay unconstrained) (V.fromList requests))+      case firstRejected (constraintBatchOutcomes recovered) of+        Just blocking ->+          Left+            ( ConstraintUnionConstructionFailed+                (ConstraintIntersection blocking)+            )+        Nothing ->+          Bifunctor.first+            (ConstraintUnionConstructionFailed . CdtBuildError)+            (canonicalize (constraintBatchTriangulation recovered))+ where+  leftSites = siteSetFromTriangulation left+  rightSites = siteSetFromTriangulation right+  unionSites = siteSetUnionWith combine leftSites rightSites+  segments =+    V.fromList+      ( Set.toAscList+          ( Set.union+              (Set.fromList (V.toList (constraintSegments left)))+              (Set.fromList (V.toList (constraintSegments right)))+          )+      )+  conflicts = completeConstraintConflicts unionSites segments+{-# INLINE unionConstrainedWith #-}++-- | Atomic partial union specialized to geometry-only constrained meshes.+unionConstrained+  :: Triangulation 'Constrained () () () ()+  -> Triangulation 'Constrained () () () ()+  -> Either+      (ConstrainedUnionError)+      (Triangulation 'Constrained () () () ())+unionConstrained = unionConstrainedWith (\_ _ -> ())+{-# INLINE unionConstrained #-}++-- | Join two strictly separated constrained triangulations with the caller's+-- left mesh resident. The right source is appended and only their common+-- tangent corridor and its selected-face-free exterior cavity are legalized.+-- The selector sees source-local handles on an explicit resident/incoming+-- side; selected face handles and constraint contours are immutable barriers.+-- Passing a selector that is always true retains the preserve-all law and its+-- typed incompatibility when the seam requires a source-face rewrite. The+-- result carries the exact final J component plus transport evidence only for+-- selected incoming faces.+-- The resident operand must have gone through 'geometryOnlyPublication'; a+-- dense boxed payload section would make local freeze enumerate the resident+-- world and is refused as a typed obstruction.+--+-- The published constraint section is exactly the source constraints union+-- the synthetic lower and upper seam bridge paths. Those paths are certified+-- perimeter constraints for the joined world and are subdivided locally when+-- an edge-length law requests it; the operation does not perform a global+-- constraint scan or canonicalization.+--+-- Strict separation in one admitted chart (x, or the orientation-preserving+-- y chart used by the seam planner) proves that the two site sets have no+-- coincident point, so annotations are copied from their source mesh and+-- never combined.+joinSeparatedConstrained+  :: (ConstrainedSeamSide -> FaceId -> Bool)+  -> RefinementParameters+  -> Triangulation 'Constrained annotation () () ()+  -> Triangulation 'Constrained annotation () () ()+  -> Either+      (ConstrainedUnionError)+      (ConstrainedSeamResult annotation)+joinSeparatedConstrained sourceFacePreserved parameters left right = do+  Bifunctor.first+    (ConstraintUnionConstructionFailed . CdtBuildError)+    (validateRefinementParameters parameters)+  seamPlan <- maybe (Left ConstraintUnionNotSeparated) Right (planSeam left right)+  vertexDefault <- ensureDefaultedPayloads left right+  seamExecution <-+    Bifunctor.first+      (ConstraintUnionConstructionFailed . CdtBuildError)+      ( executeConstrainedSeam+          sourceFacePreserved+          parameters+          vertexDefault+          seamPlan+          left+          right+      )+  let published = seamExecutionTriangulation seamExecution+  pure+    ConstrainedSeamResult+      { constrainedSeamResultTriangulation = published+      , constrainedSeamLeftFaceCount = seamExecutionLeftFaceCount seamExecution+      , constrainedSeamRightFaceEvidence = seamExecutionRightFaceEvidence seamExecution+      , constrainedSeamJoinFaces = seamExecutionJoinFaces seamExecution+      , constrainedSeamLeftConstraintCount = Dcel.numConstraints left+      , constrainedSeamConstraintStats = ConstraintBatchStats 0 0 0 0 0 0+      , constrainedSeamBuildStats = seamExecutionBuildStats seamExecution+      , constrainedSeamPublicationStats = seamExecutionPublicationStats seamExecution+      , constrainedSeamCachedFrontierPointReads = seamExecutionCachedFrontierPointReads seamExecution+      }++ensureDefaultedPayloads+  :: Triangulation 'Constrained annotation () () ()+  -> Triangulation 'Constrained annotation () () ()+  -> Either ConstrainedUnionError annotation+ensureDefaultedPayloads left right =+  case+      ( boxedFill (triVertexData left)+      , boxedFill (triDirectedData left)+      , boxedFill (triUndirectedData left)+      , boxedFill (triFaceData left)+      , boxedFill (triVertexData right)+      , boxedFill (triDirectedData right)+      , boxedFill (triUndirectedData right)+      , boxedFill (triFaceData right)+      ) of+    ( Just vertexDefault+      , Just _+      , Just _+      , Just _+      , Just _+      , Just _+      , Just _+      , Just _+      ) -> Right vertexDefault+    _ -> Left ConstraintUnionRequiresGeometryOnlyPublication++-- | Extend one already-resident constrained triangulation with one new+-- constrained section. This is intentionally asymmetric: the base mesh is+-- thawed once, extension sites are inserted into it, and only the extension's+-- constraint section is replayed. Unlike 'unionConstrainedWith', it neither+-- rebuilds a canonical site set nor replays base constraints, because both+-- would erase the physical distinction between solved base and new work.+--+-- Incoming constraint recovery is itself the spatial conflict authority. It+-- walks only the incoming corridors against the resident base and returns a+-- typed intersection obstruction. Re-running the canonical all-pairs union+-- preflight here would make a tiny extension quadratic in the base. Any+-- structural or recovery obstruction abandons the transaction before a+-- partially extended mesh can be published.+extendConstrainedWith+  :: (annotation -> annotation -> annotation)+  -> Triangulation 'Constrained annotation () () ()+  -> Triangulation 'Constrained annotation () () ()+  -> Either+      (ConstrainedUnionError)+      (ConstrainedExtensionResult annotation () () ())+extendConstrainedWith combine base extension = do+    (completed, extended, buildStats) <-+      runTransaction+        (ConstraintUnionConstructionFailed . CdtBuildError)+        transactionShape+        base+        (siteSetSize extensionSites)+        (insertAndRecoverExtension combine extensionSites extensionSegments)+    pure+      ConstrainedExtensionResult+        { constrainedExtensionConstraintBatch = finalizeConstraintBatch extended completed+        , constrainedExtensionBuildStats = buildStats+        }+ where+  extensionSites = siteSetFromTriangulation extension+  extensionSegments = constraintSegments extension+  transactionShape =+    case V.uncons extensionSegments of+      Just (segment, remaining)+        | Dcel.numVertices base >= 200000+        , siteSetSize extensionSites <= 128+        , V.null remaining+        , residentCorridorIsEmpty segment -> LocalTransaction+      _ -> DenseTransaction+  residentCorridorIsEmpty segment =+    foldCorridorBetweenPoints+      base+      (QueryPoint (segmentStart segment))+      (QueryPoint (segmentEnd segment))+      (\_ _ -> Left ())+      ()+      == Just (Right ())+{-# INLINE extendConstrainedWith #-}++insertAndRecoverExtension+  :: (annotation -> annotation -> annotation)+  -> SiteSet annotation+  -> V.Vector (CanonicalSegment)+  -> MutableDcel s annotation () () ()+  -> OperationState s+  -> ST s (Either (ConstrainedUnionError) ConstraintBatchAccumulator)+insertAndRecoverExtension combine extensionSites extensionSegments mutable operation = do+  placed <- insertExtensionSites combine extensionSites mutable operation+  case placed of+    Left obstruction -> pure (Left obstruction)+    Right handles ->+      case traverse (segmentRequestFromHandles handles) (V.toList extensionSegments) of+        Left obstruction -> pure (Left obstruction)+        Right requests -> do+          interpreted <-+            fmap+              (Bifunctor.first ConstraintUnionConstructionFailed)+              (interpretConstraintRequests (V.fromList requests) mutable operation)+          case interpreted of+            Left obstruction -> pure (Left obstruction)+            Right completed ->+              case firstRejected (accumulatorOutcomes completed) of+                Just blocking ->+                  pure+                    ( Left+                        ( ConstraintUnionConstructionFailed+                            (ConstraintIntersection blocking)+                        )+                    )+                Nothing -> pure (Right completed)++insertExtensionSites+  :: forall s annotation+   . (annotation -> annotation -> annotation)+  -> SiteSet annotation+  -> MutableDcel s annotation () () ()+  -> OperationState s+  -> ST s (Either (ConstrainedUnionError) (Map.Map (Point) VertexId))+insertExtensionSites combine extensionSites mutable operation =+  fmap+    (fmap (Map.fromDistinctAscList . reverse))+    ( foldWhileM+        isRight+        insertOne+        (Right [])+        (siteSetAssocs extensionSites)+    )+ where+  insertOne+    :: Either (ConstrainedUnionError) [(Point, VertexId)]+    -> (QueryPoint, annotation)+    -> ST s (Either (ConstrainedUnionError) [(Point, VertexId)])+  insertOne rejected@(Left _) _ = pure rejected+  insertOne (Right accumulated) (queryPoint, annotation) =+    fmap+      ( Bifunctor.first (ConstraintUnionConstructionFailed . CdtBuildError)+          . fmap+            ( \(vertex, _) ->+                ( queryPointValue queryPoint+                , VertexId (fromIntegral vertex)+                ) : accumulated+            )+      )+      (insertAdmittedPointCombining combine Nothing mutable operation queryPoint annotation)++accumulatorOutcomes :: ConstraintBatchAccumulator -> V.Vector ConstraintOutcome+accumulatorOutcomes = V.fromList . reverse . accumulatedConstraintOutcomes+{-# INLINE accumulatorOutcomes #-}++segmentRequest+  :: Triangulation mode annotation () () ()+  -> CanonicalSegment+  -> Either (ConstrainedUnionError) (VertexId, VertexId)+segmentRequest triangulation segment =+  segmentRequestFromHandles handles segment+ where+  handles =+    Map.fromList+      [ ( Dcel.vertexPoint triangulation vertex+        , vertex+        )+      | raw <- [0 .. Dcel.numVertices triangulation - 1]+      , let vertex = VertexId (fromIntegral raw)+      ]++segmentRequestFromHandles+  :: Map.Map (Point) VertexId+  -> CanonicalSegment+  -> Either (ConstrainedUnionError) (VertexId, VertexId)+segmentRequestFromHandles handles segment =+  case+      ( Map.lookup (segmentStart segment) handles+      , Map.lookup (segmentEnd segment) handles+      ) of+    (Just from, Just to) -> Right (from, to)+    (Nothing, _) -> Left (ConstraintUnionSiteMissing (segmentStart segment))+    (_, Nothing) -> Left (ConstraintUnionSiteMissing (segmentEnd segment))++firstRejected :: V.Vector ConstraintOutcome -> Maybe UndirectedEdgeId+firstRejected =+  V.foldr+    (\outcome later ->+       case outcome of+         ConstraintAccepted _ _ -> later+         ConstraintRejected blocking -> Just blocking+    )+    Nothing++completeConstraintConflicts+  :: SiteSet annotation+  -> V.Vector (CanonicalSegment)+  -> Set.Set (ConstraintConflict)+completeConstraintConflicts unionSites segments =+  Set.fromList+    [ orderedConflict leftSegment rightSegment+    | leftIndex <- [0 .. V.length segments - 1]+    , rightIndex <- [leftIndex + 1 .. V.length segments - 1]+    , let leftSegment = segments V.! leftIndex+    , let rightSegment = segments V.! rightIndex+    , segmentsProperlyCross+        (segmentStart leftSegment)+        (segmentEnd leftSegment)+        (segmentStart rightSegment)+        (segmentEnd rightSegment)+    , not (crossingIsRepresented unionSites leftSegment rightSegment)+    ]++orderedConflict+  :: CanonicalSegment+  -> CanonicalSegment+  -> ConstraintConflict+orderedConflict left right+  | left <= right = ConstraintConflict left right+  | otherwise = ConstraintConflict right left++crossingIsRepresented+  :: SiteSet annotation+  -> CanonicalSegment+  -> CanonicalSegment+  -> Bool+crossingIsRepresented sites first second =+  V.any+    (\point ->+       onClosedSegment (segmentStart first) (segmentEnd first) point+         && onClosedSegment (segmentStart second) (segmentEnd second) point+    )+    (siteSetPoints sites)
+ src-build/Moonlight/Triangulation/Internal/CircleSweep.hs view
@@ -0,0 +1,931 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -O3 -fllvm -optlo-O3 -optlc-O3 #-}++module Moonlight.Triangulation.Internal.CircleSweep+  ( RadiallyOrderedArena+  , radiallyOrderArena+  , radiallyOrderGeometry+  , circleSweepInsert+  ) where++import Control.Monad (forM_, when)+import Control.Monad.ST (ST)+import Data.Bits ((.&.), shiftL, shiftR, xor)+import qualified Data.Vector.Algorithms.Intro as Intro+import qualified Data.Vector.Algorithms.Radix as Radix+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32, Word64)+import GHC.Float (castDoubleToWord64)+import Moonlight.Triangulation.Internal.HandleDefs (DirectedEdgeId (..))+import Moonlight.Triangulation.Insertion (insertExistingVertex)+import Moonlight.Triangulation.Internal.DcelOperations.Hull+  ( ReservedSweepCells+  , SweepCellCursor+  , SweepInsertion (..)+  , closeOuterTurnReserved+  , commitReservedSweepConnections+  , fixHullConvexity+  , initialSweepCellCursor+  , insertOutsideHullAtEdge+  , reserveSweepCells+  )+import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena+  ( seedGenericPairInArena+  )+import Moonlight.Triangulation.Internal.DcelOperations.Chain+  ( connectAscendingLineArena+  , prepareAscendingLineArena+  )+import Moonlight.Triangulation.Internal.DcelOperations.Normalize+  ( LegalizationDrain (..)+  , drainDenseUnconstrainedGenericLegalization+  )+import Moonlight.Triangulation.Internal.Mutable+  ( DenseMutableDcel+  , MutableDcel+  , connectedCount+  , 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.PackedIndex (noIndex, unpackIndex)+import Moonlight.Triangulation.Internal.Probe (Probe (..))+import Moonlight.Triangulation.Internal.Predicates (orient2dCoordinates)+import Moonlight.Triangulation.Types (BuildError (..))++-- | The hull is an angular index over the DCEL outer-face cycle. The cycle+-- itself already owns hull adjacency, so left and right walking is+-- 'readPrevious'/'readNext' on the live mesh and this record only caches what+-- topology cannot state: the pseudo-angle of each outer edge's origin and the+-- bucket anchors accelerating the predecessor search. An outer edge's key is+-- its origin's @(angle, x, y)@ with the edge id as the final tie-break; the+-- angle lives in 'hullAngleByEdge' and the coordinates are re-read from the+-- immutable origin only when two cached angles compare exactly equal. Slots+-- of edges that have left the outer cycle are never read again, so the cache+-- needs no invalidation, and there is no second ring beside the authoritative+-- one.+data Hull s = Hull+  { hullCenterX :: {-# UNPACK #-} !Double+  , hullCenterY :: {-# UNPACK #-} !Double+  , hullBucketCapacity :: {-# UNPACK #-} !Int+  , hullAngleByEdge :: !(MUV.MVector s Double)+  }++-- | 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++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++-- | Vertex ids after their 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. Coordinates remain owned+-- by the DCEL rather than being duplicated in the sweep input.+newtype RadiallyOrderedArena s = RadiallyOrderedArena+  (MUV.MVector s Word32)++radiallyOrderArena+  :: MUV.MVector s (Double, Double, Double, Word32)+  -> ST s (RadiallyOrderedArena s)+radiallyOrderArena arena = do+  Intro.sort arena+  let (_, _, _, vertices) = MUV.unzip4 arena+  pure (RadiallyOrderedArena vertices)+{-# INLINE radiallyOrderArena #-}++-- | Order the geometry-only ingress by moving only its existing vertex-id+-- plane. Stable radix descent first orders the high 36 bits of each binary64+-- distance. Every equal-prefix fibre is then normalized by the complete+-- historical @(distance, x, y, vertex)@ order, recovering the discarded low+-- 28 bits before the fibres glue into the authoritative radial order. The key+-- coordinates remain in their immutable planes, so the sole linear scratch+-- plane is four bytes per site rather than a second copy of every radial+-- record.+--+-- Coordinate admission bounds every squared distance to a finite,+-- non-negative binary64 value, whose unsigned word order is numeric order.+radiallyOrderGeometry+  :: U.Vector Double+  -> U.Vector Double+  -> U.Vector Double+  -> MUV.MVector s Word32+  -> ST s (RadiallyOrderedArena s)+radiallyOrderGeometry distances pointXs pointYs vertices = do+  Radix.sortBy+    radialPassCount+    radialBucketCount+    (radialDistanceBucket distances)+    vertices+  when (MUV.length vertices > 1) $ do+    first <- MUV.unsafeRead vertices 0+    let !firstPrefix = geometryDistancePrefix distances first+    (!finalFibreStart, _) <-+      MUV.ifoldM'+        (\(!fibreStart, !distancePrefix) relativeIndex vertex ->+           let !nextPrefix = geometryDistancePrefix distances vertex+               !index = relativeIndex + 1+            in if nextPrefix == distancePrefix+                 then pure (fibreStart, distancePrefix)+                 else do+                   sortGeometryPrefixFibre+                     distances+                     pointXs+                     pointYs+                     vertices+                     fibreStart+                     index+                   pure (index, nextPrefix)+        )+        (0, firstPrefix)+        (MUV.unsafeSlice 1 (MUV.length vertices - 1) vertices)+    sortGeometryPrefixFibre+      distances+      pointXs+      pointYs+      vertices+      finalFibreStart+      (MUV.length vertices)+  pure (RadiallyOrderedArena vertices)+{-# INLINE radiallyOrderGeometry #-}++radialPassCount :: Int+radialPassCount = 3++radialBucketCount :: Int+radialBucketCount = 1 `shiftL` radialPassWidth++radialPassWidth :: Int+radialPassWidth = 12++radialPrefixDiscardedBits :: Int+radialPrefixDiscardedBits = 64 - radialPassCount * radialPassWidth++radialBucketMask :: Word64+radialBucketMask = fromIntegral (radialBucketCount - 1)++radialDistanceBucket :: U.Vector Double -> Int -> Word32 -> Int+radialDistanceBucket distances pass vertex =+  fromIntegral+    ( (castDoubleToWord64 (geometryDistance distances vertex)+         `shiftR` (radialPrefixDiscardedBits + radialPassWidth * pass)+      )+        .&. radialBucketMask+    )+{-# INLINE radialDistanceBucket #-}++geometryDistancePrefix :: U.Vector Double -> Word32 -> Word64+geometryDistancePrefix distances vertex =+  castDoubleToWord64 (geometryDistance distances vertex)+    `shiftR` radialPrefixDiscardedBits+{-# INLINE geometryDistancePrefix #-}++geometryDistance :: U.Vector Double -> Word32 -> Double+geometryDistance distances vertex = U.unsafeIndex distances (fromIntegral vertex)+{-# INLINE geometryDistance #-}++compareGeometryVertex+  :: U.Vector Double+  -> U.Vector Double+  -> U.Vector Double+  -> Word32+  -> Word32+  -> Ordering+compareGeometryVertex distances pointXs pointYs left right =+  case compare (geometryDistance distances left) (geometryDistance distances right) of+    EQ ->+      case compare (coordinateAt pointXs left) (coordinateAt pointXs right) of+        EQ ->+          case compare (coordinateAt pointYs left) (coordinateAt pointYs right) of+            EQ -> compare left right+            yOrder -> yOrder+        xOrder -> xOrder+    distanceOrder -> distanceOrder+{-# INLINE compareGeometryVertex #-}++coordinateAt :: U.Vector Double -> Word32 -> Double+coordinateAt coordinates vertex = U.unsafeIndex coordinates (fromIntegral vertex)+{-# INLINE coordinateAt #-}++sortGeometryPrefixFibre+  :: U.Vector Double+  -> U.Vector Double+  -> U.Vector Double+  -> MUV.MVector s Word32+  -> Int+  -> Int+  -> ST s ()+sortGeometryPrefixFibre distances pointXs pointYs vertices start end =+  when (end - start > 1) $+    Intro.sortBy+      (compareGeometryVertex distances pointXs pointYs)+      (MUV.unsafeSlice start (end - start) vertices)+{-# INLINE sortGeometryPrefixFibre #-}++-- | Circle sweep over one mutable DCEL, consuming one radial vertex order.+-- Coordinates are read from the authoritative dense DCEL. Insertions+-- initially close only acute hull turns. One terminal Graham pass restores+-- full convexity, so construction does not repeatedly pay for global+-- convexity that no intermediate observer can see.+circleSweepInsert+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> 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+  :: forall s vertex directed undirected face+   . DenseMutableDcel s vertex directed undirected face+  -> OperationState s+  -> MUV.MVector s Word32+  -> ST s (Either BuildError Int)+circleSweepInsertDense dense operation arena+  | MUV.length arena == 0 = pure (Right 0)+  | otherwise = do+      residentCount <- connectedCount mutable+      ascendingLine <-+        if residentCount == 0+          then prepareAscendingLineArena dense arena+          else pure Nothing+      case ascendingLine of+        Just line -> connectAscendingLineArena dense operation line+        Nothing -> circleSweepInsertArea dense operation arena+ where+  !mutable = denseMutableOwner dense+{-# INLINE circleSweepInsertDense #-}++circleSweepInsertArea+  :: forall s vertex directed undirected face+   . DenseMutableDcel s vertex directed undirected face+  -> OperationState s+  -> MUV.MVector s Word32+  -> ST s (Either BuildError Int)+circleSweepInsertArea dense operation arena = do+      let !ordered = MUV.length arena+      seed <- insertSeed 0+      case seed of+        Left failure -> pure (Left failure)+        Right seedCount -> do+          faces <- faceCount mutable+          if faces <= 1 || seedCount >= ordered+            then pure (Right seedCount)+            else do+              (centerX, centerY) <- seedCentre dense+              reservedOutcome <- reserveSweepCells dense (ordered - seedCount)+              case reservedOutcome of+                Left failure -> pure (Left failure)+                Right reserved -> do+                  builtHull <- buildHull dense operation centerX centerY+                  case builtHull of+                    Left failure -> pure (Left failure)+                    Right (!hull, !initialHullIndex) -> do+                      initialLegalizationArena <- legalizationArena operation+                      let !initialCursor = initialSweepCellCursor reserved+                      inserted <-+                        insertRemaining+                          reserved+                          initialCursor+                          initialLegalizationArena+                          hull+                          initialHullIndex+                          ordered+                          seedCount+                          (0 :: Int)+                          (0 :: Int)+                          (0 :: Int)+                          (0 :: Int)+                      case inserted of+                        Left failure -> pure (Left failure)+                        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 skippedCount 0+                              pure (seedCount <$ insertedSkipped)+ where+  !mutable = denseMutableOwner dense++  insertSeed !index+    | index >= MUV.length arena = pure (Right index)+    | otherwise = do+        raw <- MUV.unsafeRead arena index+        result <- insertExistingVertex @'ProbeOff mutable operation (unpackIndex raw)+        case result of+          Left failure -> pure (Left failure)+          Right () -> do+            faces <- faceCount mutable+            if faces > 1+              then pure (Right (index + 1))+              else insertSeed (index + 1)++  insertRemaining+    :: ReservedSweepCells s vertex directed undirected face+    -> SweepCellCursor+    -> LegalizationArena s+    -> Hull s+    -> HullIndex s+    -> Int+    -> Int+    -> Int+    -> Int+    -> Int+    -> Int+    -> ST s (Either BuildError (Int, Int, Int, Int, SweepCellCursor, LegalizationArena s))+  insertRemaining !reserved !cursor !candidateArena !hull !hullIndex !ordered !index !skippedCount !fastCount !flips !maxDepth+    | index >= ordered = pure (Right (skippedCount, fastCount, flips, maxDepth, cursor, candidateArena))+    | otherwise = do+        raw <- MUV.unsafeRead arena index+        let !vertex = unpackIndex raw+        queryXWide <- denseReadPointX dense vertex+        queryYWide <- denseReadPointY dense vertex+        let !queryAngle =+              pseudoAngle (hullCenterX hull) (hullCenterY hull) queryXWide queryYWide+        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+                reserved+                cursor+                dense+                hull+                hullIndex+                candidateArena+                edge+                fromVertex+                toVertex+                vertex+                queryXWide+                queryYWide+                queryAngle+            case deferred of+              DeferredInsertionFailure failure -> pure (Left failure)+              DeferredInsertionSuccess !newFlips !newMaxDepth !nextCursor !nextArena !nextHullIndex ->+                insertRemaining+                  reserved+                  nextCursor+                  nextArena+                  hull+                  nextHullIndex+                  ordered+                  (index + 1)+                  skippedCount+                  (fastCount + 1)+                  (flips + newFlips)+                  (max maxDepth newMaxDepth)+          else do+            -- The radial order is consumed monotonically, so its processed+            -- prefix is dead. Compact deferred vertices into that prefix+            -- instead of allocating a second linear arena.+            MUV.unsafeWrite arena skippedCount raw+            insertRemaining reserved cursor candidateArena hull hullIndex ordered (index + 1) (skippedCount + 1) fastCount flips maxDepth++  insertSkipped !count = go+   where+    go !index+      | index >= count = pure (Right ())+      | otherwise = do+          vertex <- fromIntegral <$> MUV.unsafeRead arena index+          inserted <- insertExistingVertex @'ProbeOff mutable operation vertex+          case inserted of+            Left failure -> pure (Left failure)+            Right () -> go (index + 1)++-- | The hull centre: the centroid of the first inner face, in the widened+-- comparison format, computed exactly as @centroid@ states it.+seedCentre+  :: DenseMutableDcel s vertex directed undirected face+  -> ST s (Double, Double)+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+-- the first face's centroid — a collinear chain closed by its apex — so the+-- cycle is already the angular order the predecessor search assumes; what+-- remains is caching each edge's angle and anchoring the buckets.+buildHull+  :: DenseMutableDcel s vertex directed undirected face+  -> OperationState s+  -> Double+  -> Double+  -> 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+      | count <= 0 -> pure (Left CircleSweepHullEmpty)+      | otherwise -> do+          let !capacity = max (count + 4) (pointCapacity mutable + 8)+          hullAngleByEdge <- MUV.new (halfEdgeCapacity mutable)+          let hull =+                Hull+                  { hullCenterX = centerX+                  , hullCenterY = centerY+                  , hullBucketCapacity = capacity+                  , hullAngleByEdge+                  }+          forM_ [0 .. count - 1] $ \index -> do+            edge <- readScratch operation index+            origin <- denseReadOrigin dense edge+            x <- denseReadPointX dense origin+            y <- denseReadPointY dense origin+            MUV.unsafeWrite hullAngleByEdge edge (pseudoAngle centerX centerY x y)+          hullIndex <- rebuildBuckets dense hull count (initialBucketCount count capacity)+          pure (Right (hull, hullIndex))++collectOuterEdges+  :: DenseMutableDcel s vertex directed undirected face+  -> OperationState s+  -> ST s (Either BuildError Int)+collectOuterEdges dense operation = do+  let !mutable = denseMutableOwner dense+  start <- denseReadFaceEdge dense 0+  if start < 0+    then pure (Right 0)+    else do+      bound <- directedEdgeCount mutable+      go (bound + 1) start start False 0+ where+  go !remaining !start !edge !seen !count+    | remaining <= 0 =+        pure+          ( Left+              ( OuterCycleDidNotTerminate+                  (DirectedEdgeId (fromIntegral start))+                  (DirectedEdgeId (fromIntegral edge))+                  count+              )+          )+    | seen && edge == start = pure (Right count)+    | otherwise = do+        writeScratch operation count edge+        following <- denseReadNext dense edge+        go (remaining - 1) start following True (count + 1)++initialBucketCount :: Int -> Int -> Int+initialBucketCount active capacity =+  min capacity (nextPowerOfTwo (max 8 ((active + 1) `quot` 2)))++nextPowerOfTwo :: Int -> Int+nextPowerOfTwo requested = go 1+ where+  target = max 1 requested+  go !value+    | value >= target = value+    | value > maxBound `quot` 2 = maxBound+    | otherwise = go (value * 2)++readAngle :: Hull s -> Int -> ST s Double+readAngle hull edge = MUV.unsafeRead (hullAngleByEdge hull) edge+{-# INLINE readAngle #-}++rebuildBuckets :: 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 noIndex+  start <- denseReadFaceEdge dense 0+  let go !remaining !edge+        | remaining <= 0 = pure ()+        | otherwise = do+            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 :: 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+  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 #-}++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 ()+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.+edgeAtMostAtAngle+  :: DenseMutableDcel s vertex directed undirected face+  -> Int+  -> Double+  -> Double+  -> Double+  -> Double+  -> Int+  -> ST s Bool+edgeAtMostAtAngle dense edge angle queryAngle queryX queryY tie =+  case compare angle queryAngle of+    LT -> pure True+    GT -> pure False+    EQ -> do+      origin <- denseReadOrigin dense edge+      x <- denseReadPointX dense origin+      case compare x queryX of+        LT -> pure True+        GT -> pure False+        EQ -> do+          y <- denseReadPointY dense origin+          case compare y queryY of+            LT -> pure True+            GT -> pure False+            EQ -> pure (edge <= tie)+{-# INLINE edgeAtMostAtAngle #-}++-- | 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+  :: DenseMutableDcel s vertex directed undirected face+  -> Hull s+  -> HullIndex s+  -> Double+  -> Double+  -> Double+  -> ST s Int+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 == noIndex+    then denseReadFaceEdge dense 0+    else adjustFromBoundary bucket (unpackIndex raw)+ where+  adjustFromBoundary !bucket !initial = do+    initialAngle <- readAngle hull initial+    initialAtMost <- cyclicAtMost bucket initial initialAngle+    if initialAtMost+      then advance active initial initialAngle+      else retreat active initial+   where+    cyclicAtMost boundaryBucket edge angle =+      if boundaryBucket == 0 && angle > queryAngle+        then pure True+        else edgeAtMostAtAngle dense edge angle queryAngle queryX queryY maxBound++    advance !remaining !edge !edgeAngle+      | remaining <= 0 = pure initial+      | otherwise = do+          following <- denseReadNext dense 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 <- edgeAtMostAtAngle dense following followingAngle queryAngle queryX queryY maxBound+          if (not crossesSeam || seamPermitted) && followingAtMost+            then advance (remaining - 1) following followingAngle+            else pure edge++    retreat !remaining !edge+      | remaining <= 0 = pure initial+      | otherwise = do+          previous <- denseReadPrevious dense edge+          previousAngle <- readAngle hull previous+          previousAtMost <- cyclicAtMost bucket previous previousAngle+          if previousAtMost+            then advance remaining previous previousAngle+            else retreat (remaining - 1) previous++insertDeferred+  :: ReservedSweepCells s vertex directed undirected face+  -> SweepCellCursor+  -> DenseMutableDcel s vertex directed undirected face+  -> Hull s+  -> HullIndex s+  -> LegalizationArena s+  -> Int+  -> Int+  -> Int+  -> Int+  -> Double+  -> 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+    SweepInsertionFailure failure -> pure (DeferredInsertionFailure failure)+    SweepInsertion firstOuterEdge lastOuterEdge initialFlips initialMaxDepth arenaAfterInsertion cursorAfterInsertion ->+      insertDeferredBetween+        firstOuterEdge+        lastOuterEdge+        initialFlips+        initialMaxDepth+        arenaAfterInsertion+        cursorAfterInsertion+ where+  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+    -- over) and starts the last spoke at the inserted vertex, whose angle is the+    -- one the candidate search was already given. The tie-break is each fresh+    -- edge id itself.+    replacedAngle <- readAngle hull replacedEdge+    -- 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+    -- 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.+    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 !sectionArena !sectionCursor = do+    left <- denseReadPrevious dense current+    close <- shouldCloseLeftTurn dense hull insertedAngle insertedX insertedY left current+    if not close+      then pure (ClosedHullSection current closures top sectionArena sectionCursor)+      else do+        leftAngle <- readAngle hull left+        (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 !sectionArena !sectionCursor = do+    right <- denseReadNext dense current+    close <- shouldCloseRightTurn dense hull insertedAngle insertedX insertedY current right+    if not close+      then pure (ClosedHullSection current closures top sectionArena sectionCursor)+      else do+        currentAngle <- readAngle hull current+        (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 #-}++-- | 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+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+  middleAngle <- readAngle hull second+  -- Same-ray/acute compatibility rejects most local sections.  Settle that+  -- cheap obstruction before paying for the exact orientation predicate; the+  -- conjunction is unchanged, only its evaluation order is less profligate.+  if+    middleAngle /= insertedAngle+      && not (acuteAtMiddle fromX fromY middleX middleY insertedX insertedY)+    then pure False+    else pure (orient2dCoordinates fromX fromY middleX middleY insertedX insertedY == GT)+{-# 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+  middleAngle <- readAngle hull second+  -- Symmetric to the left-hand descent above: compatibility first, exact+  -- orientation only for sections that can actually glue.+  if+    middleAngle /= insertedAngle+      && not (acuteAtMiddle insertedX insertedY middleX middleY targetX targetY)+    then pure False+    else pure (orient2dCoordinates insertedX insertedY middleX middleY targetX targetY == GT)+{-# INLINE shouldCloseRightTurn #-}++-- Spade's deferred-convexity rule is local: close the turn when the angle at+-- the shared hull vertex is strictly below 90 degrees. Requiring the entire+-- triangle to be acute leaves avoidable star-hull work for the terminal pass.+acuteAtMiddle :: Double -> Double -> Double -> Double -> Double -> Double -> Bool+acuteAtMiddle ax ay bx by cx cy =+  let !ux = ax - bx+      !uy = ay - by+      !vx = cx - bx+      !vy = cy - by+      !dot = ux * vx + uy * vy+      !scale = max 1 (ux * ux + uy * uy + vx * vx + vy * vy)+   in dot > 64 * encodeFloat 1 (-52) * scale+{-# INLINE acuteAtMiddle #-}++-- Clockwise pseudo-angle in [0,4), matching the orientation of the outer-face+-- cycle.+pseudoAngle :: Double -> Double -> Double -> Double -> Double+pseudoAngle centerX centerY x y+  | norm == 0 = 0+  | raw >= 4 = 0+  | otherwise = raw+ where+  !dx = x - centerX+  !dy = y - centerY+  !norm = abs dx + abs dy+  !projection = dx / norm+  !raw = if dy > 0 then 1 + projection else 3 - projection+{-# INLINE pseudoAngle #-}
+ src-build/Moonlight/Triangulation/Internal/Excision.hs view
@@ -0,0 +1,461 @@+{-# LANGUAGE BangPatterns #-}++-- | Excision of a vertex from a thawed mesh: the removal kernel, stated over+-- the mutable arena and publishing nothing.+module Moonlight.Triangulation.Internal.Excision+  ( removeMutable+  ) where++import Control.Monad (forM, when)+import Control.Monad.ST (ST)+import Data.Bits (xor)+import Data.Foldable (traverse_)+import qualified Data.IntSet as IntSet+import Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite (flipEdge)+import Moonlight.Triangulation.Internal.DcelOperations.Legalize+  ( legalizeCavityFanScratch+  , legalizeEdges+  )+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , readScratch+  , writeScratch+  )+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Internal.Predicates (orient2d)++-- | The proved outgoing section of one ordinary removal. Its edges live in the+-- operation scratch arena in counter-clockwise order; the record carries only+-- the section's extent and the first outer-face incidence, if any.+data RemovalStar = RemovalStar {-# UNPACK #-} !Int !(Maybe Int)++removeMutable+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point)))+removeMutable mutable operation vertex = do+  faces <- faceCount mutable+  if faces <= 1+    then removeDegenerate mutable vertex+    else do+      collected <- collectRemovalStar mutable operation vertex+      case collected of+        Left obstruction -> pure (Left obstruction)+        Right (RemovalStar degree outerOutgoing) -> do+          case outerOutgoing of+            Nothing -> removeInterior mutable operation vertex degree+            Just hullEdge -> removeHull mutable operation vertex hullEdge++removeDegenerate+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point)))+removeDegenerate mutable vertex = do+  vertexCount <- pointCount mutable+  case vertexCount of+    0 ->+      pure+        (Left (RemovalEmptyTriangulation (VertexId (fromIntegral vertex))))+    1 -> do+      writeFaceEdge mutable 0 (-1)+      swapRemoveVertex mutable vertex+    2 -> do+      collected <- collectOutgoing mutable vertex+      case collected of+        Left obstruction -> pure (Left obstruction)+        Right outgoing ->+          case outgoing of+            [edge] -> do+              _ <- clearConstraint mutable edge+              removedEdge <- swapRemoveUndirectedEdge mutable (edge `quot` 2)+              case removedEdge of+                Left obstruction -> pure (Left obstruction)+                Right () -> do+                  let !other = if vertex == 0 then 1 else 0+                  writeVertexOut mutable other (-1)+                  writeFaceEdge mutable 0 (-1)+                  swapRemoveVertex mutable vertex+            _ ->+              pure+                ( Left+                    ( RemovalTwoPointDegreeMismatch+                        (VertexId (fromIntegral vertex))+                        (length outgoing)+                    )+                )+    _ -> removeCollinear mutable vertex++removeCollinear+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point)))+removeCollinear mutable vertex = do+  collected <- collectOutgoing mutable vertex+  case collected of+    Left obstruction -> pure (Left obstruction)+    Right outgoing ->+      case outgoing of+        [edge] -> do+          let !reversedEdge = edge `xor` 1+          target <- readOrigin mutable reversedEdge+          edgeNext <- readNext mutable edge+          writePrevious mutable edgeNext (edgeNext `xor` 1)+          writeNext mutable (edgeNext `xor` 1) edgeNext+          writeVertexOut mutable target edgeNext+          writeFaceEdge mutable 0 edgeNext+          _ <- clearConstraint mutable edge+          removedEdge <- swapRemoveUndirectedEdge mutable (edge `quot` 2)+          case removedEdge of+            Left obstruction -> pure (Left obstruction)+            Right () -> swapRemoveVertex mutable vertex+        [edge1, edge2] -> do+          let !t1 = edge1 `xor` 1+              !t1Reverse = edge1+              !t2 = edge2 `xor` 1+          constrained1 <- readConstraint mutable edge1+          constrained2 <- readConstraint mutable edge2+          edge2Next <- readNext mutable edge2+          edge2To <- readOrigin mutable t2+          t2Previous <- readPrevious mutable t2+          if edge2Next == t2+            then do+              writeNext mutable t1 t1Reverse+              writePrevious mutable t1Reverse t1+            else do+              writePrevious mutable edge2Next t1+              writeNext mutable t1 edge2Next+              writeNext mutable t2Previous t1Reverse+              writePrevious mutable t1Reverse t2Previous+          writeVertexOut mutable edge2To t1Reverse+          writeOrigin mutable t1Reverse edge2To+          -- The two segments meeting at the removed vertex are welded into+          -- one, and edge1's slot now spans both. It is neither of them.+          resetEdgeData mutable (edge1 `quot` 2)+          writeFaceEdge mutable 0 t1+          _ <- clearConstraint mutable edge1+          _ <- clearConstraint mutable edge2+          when (constrained1 || constrained2) $ do+            _ <- setConstraint mutable edge1+            pure ()+          removedVertex <- swapRemoveVertex mutable vertex+          case removedVertex of+            Left obstruction -> pure (Left obstruction)+            Right result -> do+              removedEdge <- swapRemoveUndirectedEdge mutable (edge2 `quot` 2)+              pure (result <$ removedEdge)+        _ ->+          pure+            ( Left+                ( RemovalCollinearDegreeMismatch+                    (VertexId (fromIntegral vertex))+                    (length outgoing)+                )+            )++removeInterior+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point)))+removeInterior mutable operation vertex degree = do+  traverse_ recordRing [0 .. degree - 1]+  capacity <- ensureCellCapacity mutable (max 0 (degree - 3)) (max 0 (degree - 2))+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> do+      -- Taken before the fan appends anything, so it separates the fan's own edges+      -- from the cavity border exactly, the way spade's is_new_edge does.+      !cavityFloor <- (`quot` 2) <$> directedEdgeCount mutable+      remeshed <- remeshRingScratch mutable operation degree+      case remeshed of+        Left obstruction -> pure (Left obstruction)+        Right newEdgeCount -> do+          legalizeCavityFanScratch+            mutable+            operation+            cavityFloor+            (3 * degree)+            newEdgeCount+          edgesToRemove <-+            traverse+              (readScratch operation . (degree +))+              [0 .. degree - 1]+          facesToRemove <-+            traverse+              (readScratch operation . (2 * degree +))+              [0 .. degree - 1]+          cleaned <- cleanupEdgesAndFaces mutable edgesToRemove facesToRemove+          case cleaned of+            Left obstruction -> pure (Left obstruction)+            Right () -> swapRemoveVertex mutable vertex+ where+  recordRing index = do+    edge <- readScratch operation index+    following <- readNext mutable edge+    face <- readFace mutable edge+    writeScratch operation index following+    writeScratch operation (degree + index) (edge `quot` 2)+    writeScratch operation (2 * degree + index) face++-- | Fan the cavity a removal leaves. The border arrives in ring order, which is+-- the order the fan consumes it in.+remeshRingScratch+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> ST s (Either BuildError Int)+remeshRingScratch mutable operation degree+  | degree < 3 = pure (Left (RemovalBorderTooShort degree))+  | otherwise = do+      inner0 <- readScratch operation 0+      fanOrigin <- readOrigin mutable inner0+      build fanOrigin 1 inner0 0+ where+  build !fanOrigin !index !innerEdge !newEdgeCount+    | index == degree - 2 = do+      innerNext <- readScratch operation index+      innerPrevious <- readScratch operation (index + 1)+      newFace <- addFace mutable innerEdge+      writeFace mutable innerEdge newFace+      writeFace mutable innerPrevious newFace+      writeFace mutable innerNext newFace+      writeNext mutable innerEdge innerNext+      writePrevious mutable innerNext innerEdge+      writePrevious mutable innerEdge innerPrevious+      writeNext mutable innerPrevious innerEdge+      writePrevious mutable innerPrevious innerNext+      writeNext mutable innerNext innerPrevious+      previousOrigin <- readOrigin mutable innerPrevious+      nextOrigin <- readOrigin mutable innerNext+      writeVertexOut mutable previousOrigin innerPrevious+      writeVertexOut mutable nextOrigin innerNext+      writeVertexOut mutable fanOrigin innerEdge+      pure (Right newEdgeCount)+    | index < degree - 2 = do+      outerEdge <- readScratch operation index+      outerFrom <- readOrigin mutable outerEdge+      outerTo <- readOrigin mutable (outerEdge `xor` 1)+      (newEdge, newTwin) <- addEdge mutable outerTo fanOrigin+      newFace <- addFace mutable newEdge+      writeNext mutable newEdge innerEdge+      writePrevious mutable newEdge outerEdge+      writeFace mutable newEdge newFace+      writeNext mutable newTwin 0+      writePrevious mutable newTwin 0+      writeFace mutable newTwin 0+      writeFace mutable outerEdge newFace+      writeNext mutable outerEdge newEdge+      writePrevious mutable outerEdge innerEdge+      writePrevious mutable innerEdge newEdge+      writeNext mutable innerEdge outerEdge+      writeFace mutable innerEdge newFace+      writeFaceEdge mutable newFace newEdge+      writeVertexOut mutable outerFrom outerEdge+      writeScratch operation (3 * degree + newEdgeCount) newEdge+      build+        fanOrigin+        (index + 1)+        newTwin+        (newEdgeCount + 1)+    | otherwise =+      pure (Left (RemovalBorderArityMismatch (degree - index)))++removeHull :: MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point)))+removeHull mutable operation vertex loopEnd = do+  loopStart <- counterClockwiseMutable mutable loopEnd+  loopEndNext <- readNext mutable loopEnd+  collected <- collectConvexStrip loopEnd loopStart [] []+  case collected of+    Left obstruction -> pure (Left obstruction)+    Right (!convexEdges, !edgesToValidate) -> do+      let !strip = convexEdges ++ [loopEndNext]+      (!edgesToRemove, !facesToRemove) <- disconnectStrip strip+      legalizeEdges mutable operation edgesToValidate+      cleaned <- cleanupEdgesAndFaces mutable edgesToRemove facesToRemove+      case cleaned of+        Left obstruction -> pure (Left obstruction)+        Right () -> swapRemoveVertex mutable vertex+ where+  collectConvexStrip !end !current !convexReversed !validate = do+    nextCurrent <- counterClockwiseMutable mutable current+    edge <- readNext mutable current+    repaired <- repairConvexity (edge : convexReversed) validate+    case repaired of+      Left obstruction -> pure (Left obstruction)+      Right (!repairedReversed, !validate') ->+        if nextCurrent == end+          then pure (Right (reverse repairedReversed, validate'))+          else collectConvexStrip end nextCurrent repairedReversed validate'++  repairConvexity !edgesReversed !validate =+    case edgesReversed of+      edge2 : edge1 : restReversed -> do+        target <- readOrigin mutable (edge2 `xor` 1)+        from <- edgeOriginPoint mutable edge1+        to <- edgeOriginPoint mutable (edge1 `xor` 1)+        targetPoint <- pointAt mutable target+        if orient2d from to targetPoint == GT+          then do+            previousEdge <- readPrevious mutable edge2+            let !toFlip = previousEdge `xor` 1+            rewritten <- flipEdge mutable toFlip+            case rewritten of+              Left obstruction -> pure (Left obstruction)+              Right () -> do+                addCounter operation CounterEdgeFlips 1+                repairConvexity (toFlip : restReversed) (toFlip : validate)+          else pure (Right (edgesReversed, validate))+      _ -> pure (Right (edgesReversed, validate))++  disconnectStrip strip = do+    removed <- forM strip $ \edge -> do+      previousSpoke <- readPrevious mutable edge+      face <- readFace mutable edge+      from <- readOrigin mutable edge+      ccw <- counterClockwiseMutable mutable edge+      predecessor <- readPrevious mutable ccw+      writeNext mutable predecessor edge+      writePrevious mutable edge predecessor+      writeFace mutable edge 0+      writeFaceEdge mutable 0 edge+      writeVertexOut mutable from edge+      pure (previousSpoke `quot` 2, face)+    pure (map fst removed, map snd removed)++cleanupEdgesAndFaces :: MutableDcel s vertex directed undirected face -> [Int] -> [Int] -> ST s (Either BuildError ())+cleanupEdgesAndFaces mutable rawEdges rawFaces = do+  let !edges = sortUniqueDesc rawEdges+      !faces = sortUniqueDesc (filter (> 0) rawFaces)+  removedEdges <- traverseUntilFailure (swapRemoveUndirectedEdge mutable) edges+  case removedEdges of+    Left obstruction -> pure (Left obstruction)+    Right () -> traverseUntilFailure (swapRemoveFace mutable) faces+ where+  traverseUntilFailure+    :: (Int -> ST s (Either BuildError ()))+    -> [Int]+    -> ST s (Either BuildError ())+  traverseUntilFailure action =+    foldr+      ( \item continuation -> do+          outcome <- action item+          case outcome of+            Left obstruction -> pure (Left obstruction)+            Right () -> continuation+      )+      (pure (Right ()))++-- | Descending, deduplicated. Both properties are load-bearing: swap-remove+-- must retire the high index first (a lower index shifts under it), and a+-- duplicated index would be retired twice.+--+-- A removal hands over its vertex's degree, which is small on ordinary meshes+-- and unbounded in the worst case, so the shape is chosen by size. Insertion+-- sort wins outright while the ring is short — measured 6.75 against+-- 8.24 KiB/removal for @IntSet@ on the n=10000 lane — and is quadratic, so a+-- high-degree ring goes to the ordered set that carries the asymptotics.+--+-- The lazy 'foldl' is deliberate: its accumulator is the output structure.+-- 'foldl'' forced each intermediate spine and measured 7.31 versus+-- 6.75 KiB/removal on the same lane.+sortUniqueDesc :: [Int] -> [Int]+sortUniqueDesc values+  | exceedsInsertionRing values = IntSet.toDescList (IntSet.fromList values)+  | otherwise = foldl insertUnique [] values+ where+  insertUnique :: [Int] -> Int -> [Int]+  insertUnique sorted value = go sorted+   where+    go [] = [value]+    go (first : rest) = case compare value first of+      GT -> value : first : rest+      EQ -> first : rest+      LT -> first : go rest++-- | Whether a ring is long enough to owe the ordered set its logarithm,+-- decided without measuring the whole list: the insertion path is chosen by+-- the prefix, never by a full traversal.+exceedsInsertionRing :: [Int] -> Bool+exceedsInsertionRing = not . null . drop insertionRingLimit++insertionRingLimit :: Int+insertionRingLimit = 32++collectRemovalStar+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> ST s (Either BuildError RemovalStar)+collectRemovalStar mutable operation vertex = do+  start <- readVertexOut mutable vertex+  if start < 0+    then pure (Right (RemovalStar 0 Nothing))+    else do+      halfEdges <- directedEdgeCount mutable+      let !budget = halfEdges + 1+          go !remaining !current !seen !degree !outerEdge+            | remaining <= 0 =+                pure+                  ( Left+                      ( RemovalOutgoingCycleDidNotTerminate+                          (VertexId (fromIntegral vertex))+                          (DirectedEdgeId (fromIntegral current))+                          budget+                      )+                  )+            | seen && current == start =+                pure (Right (RemovalStar degree outerEdge))+            | otherwise = do+                writeScratch operation degree current+                face <- readFace mutable current+                _ <- clearConstraint mutable current+                previousEdge <- readPrevious mutable current+                let !nextOuter =+                      case outerEdge of+                        Just edge -> Just edge+                        Nothing+                          | face == 0 -> Just current+                          | otherwise -> Nothing+                go+                  (remaining - 1)+                  (previousEdge `xor` 1)+                  True+                  (degree + 1)+                  nextOuter+      go budget start False 0 Nothing++collectOutgoing+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> ST s (Either BuildError [Int])+collectOutgoing mutable vertex = do+  start <- readVertexOut mutable vertex+  if start < 0+    then pure (Right [])+    else do+      halfEdges <- directedEdgeCount mutable+      let !budget = halfEdges + 1+          go !remaining !current !seen !result+            | remaining <= 0 =+                pure+                  ( Left+                      ( RemovalOutgoingCycleDidNotTerminate+                          (VertexId (fromIntegral vertex))+                          (DirectedEdgeId (fromIntegral current))+                          budget+                      )+                  )+            | seen && current == start = pure (Right (reverse result))+            | otherwise = do+                previousEdge <- readPrevious mutable current+                go (remaining - 1) (previousEdge `xor` 1) True (current : result)+      go budget start False []++counterClockwiseMutable :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+counterClockwiseMutable mutable edge = (`xor` 1) <$> readPrevious mutable edge
+ src-build/Moonlight/Triangulation/Internal/Join.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | The join of two triangulations: a Delaunay representative of the union of+-- their sites.+module Moonlight.Triangulation.Internal.Join+  ( joinNormalForm+  , joinBalanced+  ) where++import Control.Monad (void)+import Data.Foldable (traverse_)+import Data.List.NonEmpty (NonEmpty (..))+import Moonlight.Triangulation.BulkLoad (empty)+import Moonlight.Triangulation.Internal.Join.Plan+  ( PairPlan (..)+  , planPair+  )+import Moonlight.Triangulation.Internal.Join.Seam (executeSeam)+import Moonlight.Triangulation.Internal.Join.SiteSet+  ( SiteSet+  , rebuildCanonicalSiteSet+  , siteSetAssocs+  , siteSetSize+  )+import Moonlight.Triangulation.JoinSemilattice+  ( JoinSemilattice (joinAnnotations)+  )+import Moonlight.Triangulation.Internal.Session+  ( insertAdmittedVertexAtCombining+  , withLocalSession+  )+import Moonlight.Triangulation.Internal.Tournament+  ( interpretTournament+  , planTournament+  )+import Moonlight.Triangulation.Types++-- | A Delaunay representative of the union of two site sets.+--+-- Skewed operands descend through the existing local copy-on-write session, so+-- the larger operand's vertex handles and untouched pages survive. Comparable+-- operands may merge along a separating seam or rebuild from their combined+-- site set. Every schedule returns valid topology;+-- 'Moonlight.Triangulation.Canonical.canonicalize' is the+-- separate physical observation when construction-independent numbering is+-- required.+--+-- Empty and structurally identical operands return an existing value verbatim.+-- Algebraic agreement between all schedules is stated by equal canonical+-- observations; structural equality continues to describe exact resident+-- representation.+joinNormalForm+  :: JoinSemilattice annotation+  => Triangulation 'Unconstrained annotation () () ()+  -> Triangulation 'Unconstrained annotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+joinNormalForm left right = executePairPlan (planPair left right) left right++executePairPlan+  :: JoinSemilattice annotation+  => PairPlan annotation+  -> Triangulation 'Unconstrained annotation () () ()+  -> Triangulation 'Unconstrained annotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+executePairPlan pairPlan left right =+  case pairPlan of+    ReturnLeftOperand -> Right left+    ReturnRightOperand -> Right right+    InsertLeftIntoRight sites -> insertSites sites right+    InsertRightIntoLeft sites -> insertSites sites left+    MergeSeparated seamPlan -> executeSeam seamPlan left right+    RebuildCanonicalUnion sites -> rebuildCanonicalSiteSet sites++insertSites+  :: JoinSemilattice annotation+  => SiteSet annotation+  -> Triangulation 'Unconstrained annotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+insertSites sites base = do+  ((), inserted, _) <-+    withLocalSession+      base+      (siteSetSize sites)+      ( traverse_+          (\(point, annotation) ->+             void (insertAdmittedVertexAtCombining joinAnnotations point annotation)+          )+          (siteSetAssocs sites)+      )+  pure inserted++-- | Combine by a balanced tournament rather than by a fold.+--+-- Associativity and commutativity make every bracketing canonically equivalent,+-- so this is a cost choice and not a semantic one. A left fold republishes an+-- accumulator that grows by one shard per step and so rebuilds @Θ(nk)@ sites+-- over @k@ shards; halving the list rebuilds @Θ(n log k)@.+--+-- The specialization below is load-bearing rather than decorative. Without it+-- this function is the only one on the path that stays polymorphic, and every+-- join in the tournament pays for a dictionary while a caller's own fold at a+-- known element type does not. That alone cost a factor of two and hid the+-- advantage this function exists for.+--+-- The tournament retains the binary operation's shortcut and annotation-gluing+-- semantics rather than inventing a second n-ary implementation.+joinBalanced+  :: JoinSemilattice annotation+  => [Triangulation 'Unconstrained annotation () () ()]+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+joinBalanced [] = Right (empty unitElementDefaults)+joinBalanced (first : rest) =+  interpretTournament joinNormalForm (planTournament (first :| rest))+{-# SPECIALIZE joinBalanced+  :: [Triangulation 'Unconstrained () () () ()]+  -> Either BuildError (Triangulation 'Unconstrained () () () ()) #-}
+ src-build/Moonlight/Triangulation/Internal/Join/Plan.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | The sole physical planner for binary and n-ary joins. It derives exact+-- local compatibility facts, selects one schedule, and leaves execution to a+-- consumer; sequential and concurrent interpreters share the same tournament+-- tree rather than inventing pairing policies of their own.+module Moonlight.Triangulation.Internal.Join.Plan+  ( PairPlan (..)+  , planPair+  ) where++import Moonlight.Triangulation.Dcel (numVertices)+import Moonlight.Triangulation.Internal.BulkLoad (empty)+import Moonlight.Triangulation.Internal.Join.Seam (SeamPlan, planSeam)+import Moonlight.Triangulation.Internal.Join.SiteSet+  ( SiteSet+  , siteSetFromTriangulation+  , siteSetRelation+  , siteSetUnionWith+  )+import Moonlight.Triangulation.Internal.Representation (Triangulation)+import Moonlight.Triangulation.JoinSemilattice (JoinSemilattice (joinAnnotations))+import Moonlight.Triangulation.Internal.Types+  ( ConstraintMode (Unconstrained)+  , SiteRelation (..)+  , unitElementDefaults+  )++data PairPlan annotation+  = ReturnLeftOperand+  | ReturnRightOperand+  | InsertLeftIntoRight !(SiteSet annotation)+  | InsertRightIntoLeft !(SiteSet annotation)+  | MergeSeparated !SeamPlan+  | RebuildCanonicalUnion !(SiteSet annotation)++-- | Stage cheap facts before exact set classification. Empty and structurally+-- identical operands return verbatim; skewed pairs preserve the larger value+-- through local insertion before seam planning is considered.+planPair+  :: JoinSemilattice annotation+  => Triangulation 'Unconstrained annotation () () ()+  -> Triangulation 'Unconstrained annotation () () ()+  -> PairPlan annotation+planPair left right+  -- Two zero-site values may differ structurally; the package-owned empty is+  -- the identity, so preserve the other representative when only one is it.+  | leftCount == 0 && rightCount == 0 =+      if left == empty unitElementDefaults+        then ReturnRightOperand+        else ReturnLeftOperand+  | leftCount == 0 = ReturnRightOperand+  | rightCount == 0 = ReturnLeftOperand+  | left == right = ReturnLeftOperand+  | insertionIsCheaper leftCount rightCount = InsertLeftIntoRight leftSites+  | insertionIsCheaper rightCount leftCount = InsertRightIntoLeft rightSites+  | Just seamPlan <- planSeam left right = MergeSeparated seamPlan+  | otherwise =+      case siteSetRelation leftSites rightSites of+        EqualSites -> InsertLeftIntoRight leftSites+        LeftProperSubset -> InsertLeftIntoRight leftSites+        RightProperSubset -> InsertRightIntoLeft rightSites+        DisjointSites -> rebuildUnion+        PartialOverlap _ -> rebuildUnion+ where+  !leftCount = numVertices left+  !rightCount = numVertices right+  leftSites = siteSetFromTriangulation left+  rightSites = siteSetFromTriangulation right+  rebuildUnion =+    RebuildCanonicalUnion+      (siteSetUnionWith joinAnnotations leftSites rightSites)++-- A transaction reuses an existing topology only when the added side is small+-- enough that its expected local cavities beat one bulk sweep. This is an+-- internal cost estimate, deliberately not a caller-controlled threshold.+insertionIsCheaper :: Int -> Int -> Bool+insertionIsCheaper addition base = addition <= 64 || addition <= base `quot` 8+{-# INLINE insertionIsCheaper #-}
+ src-build/Moonlight/Triangulation/Internal/Join/Seam.hs view
@@ -0,0 +1,1395 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Linear seam construction for separated Delaunay triangulations. Admission+-- returns an opaque proof carrying the exact source order and tangents; the+-- executor therefore has no untyped precondition and owns no fallback.+module Moonlight.Triangulation.Internal.Join.Seam+  ( SeamPlan+  , planSeam+  , executeSeam+  , ConstrainedSeamExecution+  , seamExecutionTriangulation+  , seamExecutionBuildStats+  , seamExecutionPublicationStats+  , seamExecutionCachedFrontierPointReads+  , seamExecutionLeftFaceCount+  , seamExecutionRightFaceEvidence+  , seamExecutionJoinFaces+  , executeConstrainedSeam+  ) where++import Control.Applicative ((<|>))+import Control.Monad.ST (ST, runST)+import Data.Bits (finiteBitSize, xor)+import Data.Foldable (traverse_)+import qualified Data.IntSet as IntSet+import qualified Data.List as List+import qualified Data.Sequence as Seq+import qualified Data.Vector as V+import Moonlight.Triangulation.Dcel+  ( adjacentEdge+  , faceDirectedEdges+  , faceVertices+  , incidentFace+  , isConstraintEdge+  , numDirectedEdges+  , numFaces+  , numInnerFaces+  , numVertices+  , origin+  , previous+  , vertexOutEdge+  , vertexData+  )+import Moonlight.Triangulation.Internal.FloodFillIterator (floodFillFacesWithRejectedEdges)+import Moonlight.Triangulation.Internal.HandleDefs+  ( DirectedEdgeId (..)+  , FaceId (..)+  , UndirectedEdgeId (..)+  , VertexId (..)+  , directedPair+  )+import Moonlight.Triangulation.Internal.DcelOperations.Hull (closeOuterTurn)+import Moonlight.Triangulation.Internal.DcelOperations.Legalize+  ( legalizeEdges+  , legalizeEdgesPinned+  )+import Moonlight.Triangulation.Internal.DcelOperations.Subdivide+  ( splitBoundaryEdgeWithLegalization+  )+import Moonlight.Triangulation.Internal.DcelOperations.FlipRule (illegalDiagonal)+import Moonlight.Triangulation.Internal.Cdt.Combinators (bindMutable)+import Moonlight.Triangulation.Internal.Cdt.Query (constraintEdges)+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (CounterSteinerPoints)+  , OperationState+  , addCounter+  , freezeBuildStats+  , newOperationState+  )+import Moonlight.Triangulation.Internal.Paged+  ( PublicationStats+  , TransactionShape (LocalTransaction)+  , pagedUnsafeIndex+  )+import Moonlight.Triangulation.Internal.Representation+  ( SeamFrontierIndex (..)+  , Triangulation (..)+  , seamQuarterTurn+  , summarizeSeamChart+  )+import Moonlight.Triangulation.Internal.Cdt.Types+  ( ConstrainedSeamFaceEvidence (..)+  , ConstrainedSeamSide (..)+  )+import Moonlight.Triangulation.Internal.Types+  ( BuildError (..)+  , BuildStats+  , ConstraintMode (Constrained, Unconstrained)+  , InvariantViolation (..)+  , Point (..)+  , QueryPoint (queryPointValue)+  , RefinementParameters (..)+  , unitElementDefaults+  )+import Moonlight.Triangulation.Internal.Predicates+  ( inCircleCoordinates+  , orient2dCoordinates+  )+import Moonlight.Triangulation.Math (distance, midpoint, validatePoint)+import Moonlight.Triangulation.Internal.Transaction (runTransactionWithPublication)++-- | Proof that a particular pair can be copied and stitched by the seam+-- kernel. Constructors stay private so an unseparated pair cannot be handed to+-- the executor by accident.+data SeamPlan+  = -- | The operands are already in geometric left/right order.  The two+    -- retained frontiers are therefore the exact ones consumed by the zipper.+    SeamLeftBeforeRight !SeamTangents !SeamFrontierIndex !SeamFrontierIndex+  | -- | The input operands are reversed, but the retained frontiers remain in+    -- geometric left/right order rather than input-operand order.+    SeamRightBeforeLeft !SeamTangents !SeamFrontierIndex !SeamFrontierIndex++-- | Coordinate chart used by the separated seam.  The second chart is the+-- orientation-preserving quarter turn @(u,v) = (y,-x)@; exact predicates and+-- the zipper therefore remain unchanged while north/south admission reuses+-- the same tangent interpreter.+data SeamAxis+  = SeamAxisX+  | SeamAxisY+  deriving stock (Eq, Show)++planSeam+  :: Triangulation mode vertex () () ()+  -> Triangulation mode' vertex () () ()+  -> Maybe SeamPlan+planSeam left right = do+  leftFrontier <- triSeamFrontier left+  rightFrontier <- triSeamFrontier right+  planAxis SeamAxisX leftFrontier rightFrontier+    <|> planAxis SeamAxisY leftFrontier rightFrontier+ where+  planAxis axis leftFrontier rightFrontier =+    case separatedOrder axis left right leftFrontier rightFrontier of+      Just LeftBeforeRight ->+        (\tangents -> SeamLeftBeforeRight tangents leftFrontier rightFrontier)+          <$> seamTangents axis left leftFrontier right rightFrontier+      Just RightBeforeLeft ->+        (\tangents -> SeamRightBeforeLeft tangents rightFrontier leftFrontier)+          <$> seamTangents axis right rightFrontier left leftFrontier+      Nothing -> Nothing++-- | Execute a proved seam schedule. Numbering follows the schedule;+-- 'Moonlight.Triangulation.Dcel.canonicalize' remains the explicit+-- construction-independent observation.+executeSeam+  :: forall vertex+   . SeamPlan+  -> Triangulation 'Unconstrained vertex () () ()+  -> Triangulation 'Unconstrained vertex () () ()+  -> Either BuildError (Triangulation 'Unconstrained vertex () () ())+executeSeam plan left right =+  case plan of+    SeamLeftBeforeRight tangents _ _ ->+      fmap fst (mergeSeparated left right tangents)+    SeamRightBeforeLeft tangents _ _ ->+      fmap fst (mergeSeparated right left tangents)++-- | Result of the constrained seam kernel. Constraint flags are copied before+-- legalization, so source contour edges are immutable barriers while the+-- zipper constructs only the missing corridor.+data ConstrainedSeamExecution vertex = ConstrainedSeamExecution+  { seamExecutionTriangulation+      :: !(Triangulation 'Constrained vertex () () ())+  , seamExecutionBuildStats :: !BuildStats+  , seamExecutionPublicationStats :: !PublicationStats+  , seamExecutionCachedFrontierPointReads :: {-# UNPACK #-} !Int+  , seamExecutionLeftFaceCount :: {-# UNPACK #-} !Int+  , seamExecutionRightFaceEvidence :: !(V.Vector ConstrainedSeamFaceEvidence)+  , seamExecutionJoinFaces :: !(V.Vector FaceId)+  }++-- | Execute a proved seam while transporting both source constraint planes.+-- This is distinct from promoting the unconstrained result afterward: source+-- hull constraints must already be visible to seam legalization or the+-- legalization schedule could erase a solved source face before recovery had+-- a chance to mark it.+executeConstrainedSeam+  :: forall vertex+   . (ConstrainedSeamSide -> FaceId -> Bool)+  -> RefinementParameters+  -> vertex+  -> SeamPlan+  -> Triangulation 'Constrained vertex () () ()+  -> Triangulation 'Constrained vertex () () ()+  -> Either BuildError (ConstrainedSeamExecution vertex)+executeConstrainedSeam sourceFacePreserved parameters vertexDefault plan left right = do+  let (order, tangents, leftFrontier, rightFrontier) =+        case plan of+          SeamLeftBeforeRight selectedTangents selectedLeftFrontier selectedRightFrontier ->+            (GeometricBaseLeft, selectedTangents, selectedLeftFrontier, selectedRightFrontier)+          SeamRightBeforeLeft selectedTangents selectedLeftFrontier selectedRightFrontier ->+            (GeometricBaseRight, selectedTangents, selectedLeftFrontier, selectedRightFrontier)+  (triangulation, statistics, publicationStats, joinFaces) <-+    executeResidentConstrained+      targetFaceProtected+      parameters+      vertexDefault+      order+      left+      right+      leftFrontier+      rightFrontier+      tangents+  rightEvidence <-+    seamFaceEvidenceForSource+      right+      incomingFaceOffset+      rightEvidenceFaces+  pure+    ConstrainedSeamExecution+      { seamExecutionTriangulation = triangulation+      , seamExecutionBuildStats = statistics+      , seamExecutionPublicationStats = publicationStats+      , seamExecutionCachedFrontierPointReads =+          seamFrontierPointReads tangents+            + case refineMaxEdgeLength parameters of+              Nothing -> 0+              Just _ -> 4+      , seamExecutionLeftFaceCount = numInnerFaces left+      , seamExecutionRightFaceEvidence = rightEvidence+      , seamExecutionJoinFaces = joinFaces+      }+ where+  !residentFaceLimit = numFaces left+  !incomingFaceOffset = residentFaceLimit - 1+  !incomingFaceLimit = incomingFaceOffset + numFaces right++  targetFaceProtected rawFace+    | rawFace <= 0 = False+    | rawFace < residentFaceLimit =+        sourceFacePreserved SeamResident (FaceId (fromIntegral rawFace))+    | rawFace < incomingFaceLimit =+        sourceFacePreserved+          SeamIncoming+          (FaceId (fromIntegral (rawFace - incomingFaceOffset)))+    | otherwise = False++  rightEvidenceFaces =+    filter+      (sourceFacePreserved SeamIncoming)+      (fmap (FaceId . fromIntegral) [1 .. numFaces right - 1])++-- | Descend exactly the unprotected face component touched by the zipper.+-- This is the authoritative J section: it contains both newly allocated seam+-- faces and any source exterior filler lawfully retriangulated into them.+exactJoinFaces+  :: Triangulation 'Constrained vertex () () ()+  -> (Int -> Bool)+  -> V.Vector FaceId+  -> (V.Vector FaceId, [UndirectedEdgeId])+exactJoinFaces triangulation targetFaceProtected seeds =+  let (faces, rejectedPairs) =+        floodFillFacesWithRejectedEdges+          triangulation+          (V.toList seeds)+          canCross+   in (V.fromList faces, rejectedPairs)+ where+  canCross edge =+    not (isConstraintEdge triangulation edge)+      && not+        ( any+            targetFaceIsProtected+            (incidentInnerFaces triangulation edge)+        )++  targetFaceIsProtected (FaceId raw) =+    targetFaceProtected (fromIntegral raw)++-- | Certify only the J/selected-face overlap after local descent. A selected+-- source face is immutable; therefore an unconstrained overlap edge that still+-- requires a Delaunay flip is a genuine incompatibility, never permission to+-- rewrite the solved section.+certifyJoinBoundary+  :: Triangulation 'Constrained vertex () () ()+  -> [UndirectedEdgeId]+  -> Either BuildError ()+certifyJoinBoundary triangulation = traverse_ certifyPair+ where+  certifyPair edge =+    if isConstraintEdge triangulation edge+          || not (immutableEdgeRequiresFlip triangulation edge)+          then Right ()+          else Left (SeamSourceEdgeRequiresFlip edge)++incidentInnerFaces+  :: Triangulation mode vertex directed undirected face+  -> UndirectedEdgeId+  -> [FaceId]+incidentInnerFaces triangulation edge =+  filter (/= FaceId 0)+    [ incidentFace triangulation forward+    , incidentFace triangulation backward+    ]+ where+  (forward, backward) = directedPair edge++immutableEdgeRequiresFlip+  :: Triangulation mode vertex directed undirected face+  -> UndirectedEdgeId+  -> Bool+immutableEdgeRequiresFlip triangulation edge =+  leftFace /= FaceId 0+    && rightFace /= FaceId 0+    && 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+ where+  (forward, backward) = directedPair edge+  leftFace = incidentFace triangulation forward+  rightFace = incidentFace triangulation backward+  forwardPrevious = previous triangulation forward+  backwardPrevious = previous triangulation backward+  Point ax ay = vertexPointAt triangulation (origin triangulation forward)+  Point bx by = vertexPointAt triangulation (origin triangulation backward)+  Point cx cy = vertexPointAt triangulation (origin triangulation forwardPrevious)+  Point dx dy = vertexPointAt triangulation (origin triangulation backwardPrevious)++vertexPointAt+  :: Triangulation mode vertex directed undirected face+  -> VertexId+  -> Point+vertexPointAt triangulation (VertexId raw) =+  Point+    (triPointX triangulation `pagedUnsafeIndex` fromIntegral raw)+    (triPointY triangulation `pagedUnsafeIndex` fromIntegral raw)++data GeometricBaseOrder+  = GeometricBaseLeft+  | GeometricBaseRight+  deriving stock (Eq, Show)++-- | Finite local work required to turn the two synthetic perimeter bridges+-- into edge-bounded constrained paths.  The witness is derived while the+-- tangent endpoints still identify J exactly; after publication those edges+-- are ordinary constraints and must not be rediscovered by a global scan.+data SeamBridgeSubdivision = SeamBridgeSubdivision+  { seamLowerBridgeDepth :: {-# UNPACK #-} !Int+  , seamUpperBridgeDepth :: {-# UNPACK #-} !Int+  , seamBridgeAddedVertices :: {-# UNPACK #-} !Int+  }++planSeamBridgeSubdivision+  :: RefinementParameters+  -> Point+  -> Point+  -> Point+  -> Point+  -> Either BuildError SeamBridgeSubdivision+planSeamBridgeSubdivision parameters lowerLeft lowerRight upperLeft upperRight =+  case refineMaxEdgeLength parameters of+    Nothing -> Right (SeamBridgeSubdivision 0 0 0)+    Just maximumLength -> do+      let !lowerDepth = requiredBridgeSubdivisionDepth maximumLength lowerLeft lowerRight+          !upperDepth = requiredBridgeSubdivisionDepth maximumLength upperLeft upperRight+          !required =+            subdivisionVertexCount lowerDepth+              + subdivisionVertexCount upperDepth+      if required > toInteger (maxBound :: Int)+        then Left (CapacityExceeded maxBound)+        else do+          let !requiredVertices = fromInteger required+          available <-+            case (requiredVertices, refineMaxAdditionalVertices parameters) of+              (0, Nothing) -> Right 0+              (_, Nothing) -> Left RefinementDomainRequiresFiniteVertexBudget+              (_, Just budget) -> Right budget+          if requiredVertices <= available+            then+              Right+                SeamBridgeSubdivision+                  { seamLowerBridgeDepth = lowerDepth+                  , seamUpperBridgeDepth = upperDepth+                  , seamBridgeAddedVertices = requiredVertices+                  }+            else+              Left+                ( RefinementSeamBridgeBudgetExceeded+                    requiredVertices+                    available+                )+ where+  subdivisionVertexCount :: Int -> Integer+  subdivisionVertexCount depth = (2 :: Integer) ^ depth - 1++requiredBridgeSubdivisionDepth :: Double -> Point -> Point -> Int+requiredBridgeSubdivisionDepth maximumLength from to =+  descend 0 (distance from to)+ where+  descend !depth !currentLength+    | currentLength <= maximumLength = depth+    | depth >= finiteBitSize (0 :: Int) = depth+    | otherwise = descend (depth + 1) (0.5 * currentLength)++vertexPointForOuterEdge+  :: Triangulation mode vertex directed undirected face+  -> Int+  -> Point+vertexPointForOuterEdge triangulation edge =+  vertexPointAt+    triangulation+    (VertexId (fromIntegral (topologyAt triangulation (4 * edge))))++subdivideSeamBridge+  :: forall s vertex directed undirected face+   . (Int -> Bool)+  -> vertex+  -> Int+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> ST s (Either BuildError (Seq.Seq Int))+subdivideSeamBridge targetFaceProtected vertexDefault = descend+ where+  descend+    :: Int+    -> MutableDcel s vertex directed undirected face+    -> OperationState s+    -> Int+    -> ST s (Either BuildError (Seq.Seq Int))+  descend depth mutable operation outerEdge+    | depth <= 0 = pure (Right (Seq.singleton outerEdge))+    | otherwise = do+        fromVertex <- readOrigin mutable outerEdge+        toVertex <- readOrigin mutable (outerEdge `xor` 1)+        fromPoint <- pointAt mutable fromVertex+        toPoint <- pointAt mutable toVertex+        case validatePoint Nothing (midpoint fromPoint toPoint) of+          Left obstruction -> pure (Left obstruction)+          Right admitted ->+            let !splitPoint = queryPointValue admitted+             in if splitPoint == fromPoint || splitPoint == toPoint+                  then+                    pure+                      ( Left+                          ( RefinementSeamBridgeMidpointCollapsed+                              (UndirectedEdgeId (fromIntegral (outerEdge `quot` 2)))+                          )+                      )+                  else do+                    vertex <- appendVertex mutable splitPoint vertexDefault+                    splitBoundaryEdgeWithLegalization+                      (\target targetOperation _ firstCandidate secondCandidate ->+                         legalizeEdgesPinned+                           targetFaceProtected+                           target+                           targetOperation+                           [firstCandidate, secondCandidate]+                      )+                      mutable+                      operation+                      outerEdge+                      vertex+                      `bindMutable` \(firstOuter, secondOuter) -> do+                        addCounter operation CounterSteinerPoints 1+                        descend (depth - 1) mutable operation firstOuter+                          `bindMutable` \firstChain ->+                            fmap (fmap (firstChain Seq.><))+                              (descend (depth - 1) mutable operation secondOuter)++executeResidentConstrained+  :: forall vertex+   . (Int -> Bool)+  -> RefinementParameters+  -> vertex+  -> GeometricBaseOrder+  -> Triangulation 'Constrained vertex () () ()+  -> Triangulation 'Constrained vertex () () ()+  -> SeamFrontierIndex+  -> SeamFrontierIndex+  -> SeamTangents+  -> Either BuildError+      ( Triangulation 'Constrained vertex () () ()+      , BuildStats+      , PublicationStats+      , V.Vector FaceId+      )+executeResidentConstrained targetFaceProtected parameters vertexDefault order base extension leftFrontier rightFrontier tangents = do+  let !baseDirected = numDirectedEdges base+      !extensionDirected = numDirectedEdges extension+      !baseVertices = numVertices base+      (leftSource, rightSource, leftVertexOffset, rightVertexOffset, leftEdgeOffset, rightEdgeOffset) =+        case order of+          GeometricBaseLeft ->+            (base, extension, 0, baseVertices, 0, baseDirected)+          GeometricBaseRight ->+            (extension, base, baseVertices, 0, baseDirected, 0)+      SeamTangents+        { seamLowerLeft = SeamTangent _ lowerLeft+        , seamLowerRight = SeamTangent _ lowerRight+        , seamUpperLeft = SeamTangent _ upperLeft+        , seamUpperRight = SeamTangent _ upperRight+        } = tangents+  bridgePlan <-+    planSeamBridgeSubdivision+      parameters+      (vertexPointForOuterEdge leftSource lowerLeft)+      (vertexPointForOuterEdge rightSource lowerRight)+      (vertexPointForOuterEdge leftSource upperLeft)+      (vertexPointForOuterEdge rightSource upperRight)+  let !extensionVertices = numVertices extension+      !bridgeVertices = seamBridgeAddedVertices bridgePlan+  transactionAdditional <-+    if bridgeVertices > maxBound - extensionVertices+      then Left (CapacityExceeded maxBound)+      else Right (extensionVertices + bridgeVertices)+  ((newFaces, progress, upperBridgeChain, lowerBridgeChain), triangulation, statistics, publicationStats) <-+    runTransactionWithPublication+      id+      LocalTransaction+      base+      transactionAdditional+      (\mutable operation -> do+         appendSourceVertices mutable extension+         _ <- addEdgeBlock mutable (extensionDirected `quot` 2)+         _ <- addFaceBlock mutable (numFaces extension - 1)+         copySource+           mutable+           extension+           baseVertices+           baseDirected+           (numFaces base - 1)+         copySourceConstraints mutable baseDirected extension+         seamBase <-+           spliceLowerTangent+             mutable+             rightEdgeOffset+             (leftEdgeOffset + lowerLeft)+             lowerRight+         -- The two synthetic hull bridges are the certified perimeter of the+         -- published world.  Once a later extension consumes either bridge it+         -- becomes Γ, so fixing it now preserves the prior solve without a+         -- retrospective source rewrite.+         _ <- setConstraint mutable seamBase+         stitchSeamPinned+           targetFaceProtected+           mutable+           operation+           (Seq.length (seamFrontierEdges leftFrontier))+           (tangentIndex (seamLowerLeft tangents))+           (Seq.length (seamFrontierEdges rightFrontier))+           (tangentIndex (seamLowerRight tangents))+           seamBase+           (leftVertexOffset + topologyAt leftSource (4 * upperLeft))+           (rightVertexOffset + topologyAt rightSource (4 * upperRight))+           []+           []+           `bindMutable` \(upperBridge, newFaces, progress) -> do+             _ <- setConstraint mutable upperBridge+             subdivideSeamBridge+               targetFaceProtected+               vertexDefault+               (seamLowerBridgeDepth bridgePlan)+               mutable+               operation+               (seamBase `xor` 1)+               `bindMutable` \lowerBridgeChain ->+                 subdivideSeamBridge+                   targetFaceProtected+                   vertexDefault+                   (seamUpperBridgeDepth bridgePlan)+                   mutable+                   operation+                   upperBridge+                   `bindMutable` \upperBridgeChain ->+                     case Seq.lookup 0 upperBridgeChain of+                       Nothing -> pure (Left SeamFrontierUnavailable)+                       Just frontierStart -> do+                         writeFaceEdge mutable 0 frontierStart+                         pure+                           ( Right+                               (newFaces, progress, upperBridgeChain, lowerBridgeChain)+                           )+      )+  let newFaceSeeds = V.fromList (fmap (FaceId . fromIntegral) newFaces)+      (joinFaces, rejectedBoundaryPairs) =+        exactJoinFaces triangulation targetFaceProtected newFaceSeeds+  certifyJoinBoundary triangulation rejectedBoundaryPairs+  frontier <-+    combineSeamFrontier+      triangulation+      leftFrontier+      rightFrontier+      leftEdgeOffset+      rightEdgeOffset+      upperBridgeChain+      lowerBridgeChain+      progress+  let published :: Triangulation 'Constrained vertex () () ()+      published = triangulation{triSeamFrontier = Just frontier}+  pure+    ( published+    , statistics+    , publicationStats+    , joinFaces+    )++seamFaceEvidenceForSource+  :: Triangulation 'Constrained vertex () () ()+  -> Int+  -> [FaceId]+  -> Either BuildError (V.Vector ConstrainedSeamFaceEvidence)+seamFaceEvidenceForSource source targetOffset sourceFaces =+  V.fromList <$> traverse evidenceFor sourceFaces+ where+  evidenceFor sourceFace = do+    (first, second, third) <- facePoints source sourceFace+    let targetFace = FaceId (unFaceId sourceFace + fromIntegral targetOffset)+    Right+      ConstrainedSeamFaceEvidence+        { constrainedSeamSourceFace = sourceFace+        , constrainedSeamTargetFace = targetFace+        , constrainedSeamFaceFirstPoint = first+        , constrainedSeamFaceSecondPoint = second+        , constrainedSeamFaceThirdPoint = third+        }++  facePoints+    :: Triangulation mode sourceVertex directed undirected face+    -> FaceId+    -> Either BuildError (Point, Point, Point)+  facePoints triangulation faceHandle =+    case List.sort (fmap (vertexPointAt triangulation) (faceVertices triangulation faceHandle)) of+      [first, second, third] -> Right (first, second, third)+      _ -> Left (faceCardinalityFailure triangulation faceHandle)++  faceCardinalityFailure+    :: Triangulation mode sourceVertex directed undirected face+    -> FaceId+    -> BuildError+  faceCardinalityFailure triangulation faceHandle =+    case faceDirectedEdges triangulation faceHandle of+      edge : _ -> RefinementInputTopologyInvalid (InnerFaceNotTriangularAtEdge edge)+      [] -> RefinementInputTopologyInvalid (FaceMissingAdjacentEdge faceHandle)++data SeparatedOrder+  = LeftBeforeRight+  | RightBeforeLeft++separatedOrder+  :: SeamAxis+  -> Triangulation mode vertex directed undirected face+  -> Triangulation mode' vertex' directed' undirected' face'+  -> SeamFrontierIndex+  -> SeamFrontierIndex+  -> Maybe SeparatedOrder+separatedOrder axis left right leftFrontier rightFrontier+  | numInnerFaces left <= 0 || numInnerFaces right <= 0 = Nothing+  | chartMaximum axis leftFrontier < chartMinimum axis rightFrontier =+      Just LeftBeforeRight+  | chartMaximum axis rightFrontier < chartMinimum axis leftFrontier =+      Just RightBeforeLeft+  | otherwise = Nothing++chartMinimum :: SeamAxis -> SeamFrontierIndex -> Double+chartMinimum axis frontier =+  case axis of+    SeamAxisX -> seamFrontierXMinimum frontier+    SeamAxisY -> seamFrontierYMinimum frontier++chartMaximum :: SeamAxis -> SeamFrontierIndex -> Double+chartMaximum axis frontier =+  case axis of+    SeamAxisX -> seamFrontierXMaximum frontier+    SeamAxisY -> seamFrontierYMaximum frontier++-- The opposite-sign branch cannot overflow in its sum. The same-sign branch+-- cannot overflow in its difference.+data SeamTangent = SeamTangent+  {-# UNPACK #-} !Int+  {-# UNPACK #-} !Int++tangentIndex :: SeamTangent -> Int+tangentIndex (SeamTangent index _) = index+{-# INLINE tangentIndex #-}++data SeamTangents = SeamTangents+  { seamLowerLeft :: !SeamTangent+  , seamLowerRight :: !SeamTangent+  , seamUpperLeft :: !SeamTangent+  , seamUpperRight :: !SeamTangent+  , seamFrontierPointReads :: {-# UNPACK #-} !Int+  }++seamTangents+  :: SeamAxis+  -> Triangulation mode vertex directed undirected face+  -> SeamFrontierIndex+  -> Triangulation mode' vertex' directed' undirected' face'+  -> SeamFrontierIndex+  -> Maybe SeamTangents+seamTangents axis left leftFrontier right rightFrontier = do+  (lowerLeft, lowerRight, lowerReads) <- lowerTangent axis left leftFrontier right rightFrontier+  (upperLeft, upperRight, upperReads) <- upperTangent axis left leftFrontier right rightFrontier+  pure+    SeamTangents+      { seamLowerLeft = lowerLeft+      , seamLowerRight = lowerRight+      , seamUpperLeft = upperLeft+      , seamUpperRight = upperRight+      , seamFrontierPointReads = lowerReads + upperReads+      }++lowerTangent+  :: SeamAxis+  -> Triangulation mode vertex directed undirected face+  -> SeamFrontierIndex+  -> Triangulation mode' vertex' directed' undirected' face'+  -> SeamFrontierIndex+  -> Maybe (SeamTangent, SeamTangent, Int)+-- The walk carries both endpoints' coordinates: a step replaces exactly one+-- endpoint, and the replacement is the neighbour whose coordinates the step's+-- own test already read.+lowerTangent axis left leftFrontier right rightFrontier = do+  (leftStart, leftReads) <- frontierPointAtCount axis left leftFrontier leftStartIndex+  (rightStart, rightReads) <- frontierPointAtCount axis right rightFrontier rightStartIndex+  walk leftStartIndex leftStart rightStartIndex rightStart (leftReads + rightReads)+ where+  leftStartIndex :: Int+  rightStartIndex :: Int+  leftSize :: Int+  rightSize :: Int+  walk+    :: Int+    -> (Double, Double)+    -> Int+    -> (Double, Double)+    -> Int+    -> Maybe (SeamTangent, SeamTangent, Int)+  leftStartIndex = chartLowerRightmost axis leftFrontier+  rightStartIndex = chartLowerLeftmost axis rightFrontier+  leftSize = Seq.length (seamFrontierEdges leftFrontier)+  rightSize = Seq.length (seamFrontierEdges rightFrontier)++  walk !leftIndex (!leftX, !leftY) !rightIndex (!rightX, !rightY) !frontierReads = do+    nextLeftIndex <- pure (nextIndex leftSize leftIndex)+    previousRightIndex <- pure (previousIndex rightSize rightIndex)+    (nextLeftX, nextLeftY) <- frontierPointAt axis left leftFrontier nextLeftIndex+    (previousRightX, previousRightY) <- frontierPointAt axis right rightFrontier previousRightIndex+    let !nextReads = frontierReads + 2+        !leftBelow =+          orient2dCoordinates leftX leftY rightX rightY nextLeftX nextLeftY == LT+        !rightBelow =+          orient2dCoordinates leftX leftY rightX rightY previousRightX previousRightY == LT+    if leftBelow+      then walk nextLeftIndex (nextLeftX, nextLeftY) rightIndex (rightX, rightY) nextReads+      else+        if rightBelow+          then walk leftIndex (leftX, leftY) previousRightIndex (previousRightX, previousRightY) nextReads+          else do+            leftEdge <- frontierEdgeAt leftFrontier leftIndex+            rightEdge <- frontierEdgeAt rightFrontier rightIndex+            pure+              ( SeamTangent leftIndex leftEdge+              , SeamTangent rightIndex rightEdge+              , nextReads+              )++upperTangent+  :: SeamAxis+  -> Triangulation mode vertex directed undirected face+  -> SeamFrontierIndex+  -> Triangulation mode' vertex' directed' undirected' face'+  -> SeamFrontierIndex+  -> Maybe (SeamTangent, SeamTangent, Int)+upperTangent axis left leftFrontier right rightFrontier = do+  (leftStart, leftReads) <- frontierPointAtCount axis left leftFrontier leftStartIndex+  (rightStart, rightReads) <- frontierPointAtCount axis right rightFrontier rightStartIndex+  walk leftStartIndex leftStart rightStartIndex rightStart (leftReads + rightReads)+ where+  leftStartIndex :: Int+  rightStartIndex :: Int+  leftSize :: Int+  rightSize :: Int+  walk+    :: Int+    -> (Double, Double)+    -> Int+    -> (Double, Double)+    -> Int+    -> Maybe (SeamTangent, SeamTangent, Int)+  leftStartIndex = chartUpperRightmost axis leftFrontier+  rightStartIndex = chartUpperLeftmost axis rightFrontier+  leftSize = Seq.length (seamFrontierEdges leftFrontier)+  rightSize = Seq.length (seamFrontierEdges rightFrontier)++  walk !leftIndex (!leftX, !leftY) !rightIndex (!rightX, !rightY) !frontierReads = do+    previousLeftIndex <- pure (previousIndex leftSize leftIndex)+    nextRightIndex <- pure (nextIndex rightSize rightIndex)+    (previousLeftX, previousLeftY) <- frontierPointAt axis left leftFrontier previousLeftIndex+    (nextRightX, nextRightY) <- frontierPointAt axis right rightFrontier nextRightIndex+    let !nextReads = frontierReads + 2+        !leftAbove =+          orient2dCoordinates leftX leftY rightX rightY previousLeftX previousLeftY == GT+        !rightAbove =+          orient2dCoordinates leftX leftY rightX rightY nextRightX nextRightY == GT+    if leftAbove+      then walk previousLeftIndex (previousLeftX, previousLeftY) rightIndex (rightX, rightY) nextReads+      else+        if rightAbove+          then walk leftIndex (leftX, leftY) nextRightIndex (nextRightX, nextRightY) nextReads+          else do+            leftEdge <- frontierEdgeAt leftFrontier leftIndex+            rightEdge <- frontierEdgeAt rightFrontier rightIndex+            pure+              ( SeamTangent leftIndex leftEdge+              , SeamTangent rightIndex rightEdge+              , nextReads+              )++frontierEdgeAt :: SeamFrontierIndex -> Int -> Maybe Int+frontierEdgeAt frontier index = Seq.lookup index (seamFrontierEdges frontier)++chartLowerRightmost :: SeamAxis -> SeamFrontierIndex -> Int+chartLowerRightmost axis frontier =+  case axis of+    SeamAxisX -> seamFrontierLowerRightmost frontier+    SeamAxisY -> seamFrontierYLowerRightmost frontier++chartLowerLeftmost :: SeamAxis -> SeamFrontierIndex -> Int+chartLowerLeftmost axis frontier =+  case axis of+    SeamAxisX -> seamFrontierLowerLeftmost frontier+    SeamAxisY -> seamFrontierYLowerLeftmost frontier++chartUpperRightmost :: SeamAxis -> SeamFrontierIndex -> Int+chartUpperRightmost axis frontier =+  case axis of+    SeamAxisX -> seamFrontierUpperRightmost frontier+    SeamAxisY -> seamFrontierYUpperRightmost frontier++chartUpperLeftmost :: SeamAxis -> SeamFrontierIndex -> Int+chartUpperLeftmost axis frontier =+  case axis of+    SeamAxisX -> seamFrontierUpperLeftmost frontier+    SeamAxisY -> seamFrontierYUpperLeftmost frontier++frontierPointAt+  :: SeamAxis+  -> Triangulation mode vertex directed undirected face+  -> SeamFrontierIndex+  -> Int+  -> Maybe (Double, Double)+frontierPointAt axis triangulation frontier index = do+  edge <- frontierEdgeAt frontier index+  let !vertex = topologyAt triangulation (4 * edge)+  pure (chartPoint axis (physicalPoint triangulation vertex))+{-# INLINE frontierPointAt #-}++chartPoint :: SeamAxis -> (Double, Double) -> (Double, Double)+chartPoint axis (x, y) =+  case axis of+    SeamAxisX -> (x, y)+    SeamAxisY -> seamQuarterTurn (x, y)++physicalPoint+  :: Triangulation mode vertex directed undirected face+  -> Int+  -> (Double, Double)+physicalPoint triangulation vertex =+  ( triPointX triangulation `pagedUnsafeIndex` vertex+  , triPointY triangulation `pagedUnsafeIndex` vertex+  )++frontierPointAtCount+  :: SeamAxis+  -> Triangulation mode vertex directed undirected face+  -> SeamFrontierIndex+  -> Int+  -> Maybe ((Double, Double), Int)+frontierPointAtCount axis triangulation frontier index = do+  point <- frontierPointAt axis triangulation frontier index+  pure (point, 1)++nextIndex :: Int -> Int -> Int+nextIndex size index+  | index + 1 == size = 0+  | otherwise = index + 1+{-# INLINE nextIndex #-}++previousIndex :: Int -> Int -> Int+previousIndex size index+  | index == 0 = size - 1+  | otherwise = index - 1+{-# INLINE previousIndex #-}+++mergeSeparated+  :: forall outputMode leftMode rightMode vertex+   . Triangulation leftMode vertex () () ()+  -> Triangulation rightMode vertex () () ()+  -> SeamTangents+   -> Either+      BuildError+      (Triangulation outputMode vertex () () (), BuildStats)+mergeSeparated+  left+  right+  SeamTangents+    { seamLowerLeft = SeamTangent _ lowerLeft+    , seamLowerRight = SeamTangent _ lowerRight+    , seamUpperLeft = SeamTangent _ upperLeft+    , seamUpperRight = SeamTangent _ upperRight+    } = runST $ do+  mutable <- newMutableDcel unitElementDefaults (planarDcelCapacity totalVertices)+  pointCapacityOutcome <- ensurePointCapacity mutable totalVertices+  cellCapacityOutcome <-+    ensureCellCapacity+      mutable+      ((leftDirected + rightDirected) `quot` 2 + 1)+      (leftFaces + rightFaces - 2)+  case (pointCapacityOutcome, cellCapacityOutcome) of+    (Left obstruction, _) -> pure (Left obstruction)+    (_, Left obstruction) -> pure (Left obstruction)+    (Right (), Right ()) -> do+      appendSourceVertices mutable left+      appendSourceVertices mutable right+      _ <- addEdgeBlock mutable ((leftDirected + rightDirected) `quot` 2)+      _ <- addFaceBlock mutable (leftFaces + rightFaces - 2)+      copySource mutable left 0 0 0+      copySource mutable right leftVertices leftDirected (leftFaces - 1)+      base <- spliceLowerTangent mutable leftDirected lowerLeft lowerRight+      operation <- newOperationState (halfEdgeCapacity mutable)+      stitched <-+        stitchSeam+          mutable+          operation+          base+          (topologyAt left (4 * upperLeft))+          (leftVertices + topologyAt right (4 * upperRight))+          []+          []+      case stitched of+        Left obstruction -> pure (Left obstruction)+        Right _ -> do+          statistics <- freezeBuildStats operation+          fmap (\triangulation -> (triangulation, statistics))+            <$> freezeTriangulation mutable+ where+  !leftVertices = numVertices left+  !rightVertices = numVertices right+  !totalVertices = leftVertices + rightVertices+  !leftDirected = numDirectedEdges left+  !rightDirected = numDirectedEdges right+  !leftFaces = numFaces left+  !rightFaces = numFaces right++stitchSeam+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> Int+  -> [Int]+  -> [Int]+  -> ST s (Either BuildError (Int, [Int]))+stitchSeam mutable operation base upperLeft upperRight seeds newFaces =+  fmap (fmap (\(finalBase, faces, _) -> (finalBase, faces)))+    ( stitchSeamWith+        (\target ops edges -> legalizeEdges target ops edges >> pure (Right ()))+        (SeamProgress 0 0 0 0 0 0)+        mutable+        operation+        base+        upperLeft+        upperRight+        seeds+        newFaces+    )++stitchSeamPinned+  :: (Int -> Bool)+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> [Int]+  -> [Int]+  -> ST s (Either BuildError (Int, [Int], SeamProgress))+stitchSeamPinned targetFaceProtected mutable operation leftSize leftStart rightSize rightStart base upperLeft upperRight seeds newFaces =+  stitchSeamWith+    (\target ops edges -> legalizeEdgesPinned targetFaceProtected target ops edges >> pure (Right ()))+    (SeamProgress leftSize leftStart (previousIndex leftSize leftStart) rightSize rightStart rightStart)+    mutable+    operation+    base+    upperLeft+    upperRight+    seeds+    newFaces++data SeamProgress = SeamProgress+  { seamProgressLeftSize :: {-# UNPACK #-} !Int+  , seamProgressLeftStart :: {-# UNPACK #-} !Int+  , seamProgressLeftCursor :: {-# UNPACK #-} !Int+  , seamProgressRightSize :: {-# UNPACK #-} !Int+  , seamProgressRightStart :: {-# UNPACK #-} !Int+  , seamProgressRightCursor :: {-# UNPACK #-} !Int+  }++stitchSeamWith+  :: (MutableDcel s vertex directed undirected face -> OperationState s -> [Int] -> ST s (Either BuildError ()))+  -> SeamProgress+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> Int+  -> [Int]+  -> [Int]+  -> ST s (Either BuildError (Int, [Int], SeamProgress))+stitchSeamWith legalize progress mutable operation base upperLeft upperRight seeds newFaces = do+  leftVertex <- readOrigin mutable base+  rightVertex <- readOrigin mutable (base `xor` 1)+  if leftVertex == upperLeft && rightVertex == upperRight+    then do+      legalized <- legalize mutable operation seeds+      pure (fmap (const (base, newFaces, progress)) legalized)+    else do+      leftEdge <- readPrevious mutable base+      rightEdge <- readNext mutable base+      nextLeft <- readOrigin mutable leftEdge+      nextRight <- readOrigin mutable (rightEdge `xor` 1)+      leftTurn <- vertexOrientation mutable nextLeft leftVertex rightVertex+      rightTurn <- vertexOrientation mutable leftVertex rightVertex nextRight+      chooseRight <-+        if rightVertex == upperRight+          then pure False+          else+            if leftVertex == upperLeft+              then pure True+              else+                case (leftTurn == GT, rightTurn == GT) of+                  (True, True) ->+                    (== GT) <$> vertexInCircle mutable nextLeft leftVertex rightVertex nextRight+                  (False, True) -> pure True+                  _ -> pure False+      if chooseRight+        then do+          closed <- closeOuterTurn mutable base+          case closed of+            Left obstruction -> pure (Left obstruction)+            Right nextBase ->+              do+                face <- readFace mutable (nextBase `xor` 1)+                stitchSeamWith+                  legalize+                  (advanceRight progress)+                  mutable+                  operation+                  nextBase+                  upperLeft+                  upperRight+                  (base : rightEdge : seeds)+                  (face : newFaces)+        else do+          closed <- closeOuterTurn mutable leftEdge+          case closed of+            Left obstruction -> pure (Left obstruction)+            Right nextBase ->+              do+                face <- readFace mutable (nextBase `xor` 1)+                stitchSeamWith+                  legalize+                  (advanceLeft progress)+                  mutable+                  operation+                  nextBase+                  upperLeft+                  upperRight+                  (leftEdge : base : seeds)+                  (face : newFaces)++advanceLeft :: SeamProgress -> SeamProgress+advanceLeft progress@SeamProgress{seamProgressLeftSize, seamProgressLeftCursor} =+  progress+    { seamProgressLeftCursor =+        previousIndex seamProgressLeftSize seamProgressLeftCursor+    }++advanceRight :: SeamProgress -> SeamProgress+advanceRight progress@SeamProgress{seamProgressRightSize, seamProgressRightCursor} =+  progress+    { seamProgressRightCursor =+        nextIndex seamProgressRightSize seamProgressRightCursor+    }++combineSeamFrontier+  :: Triangulation mode vertex directed undirected face+  -> SeamFrontierIndex+  -> SeamFrontierIndex+  -> Int+  -> Int+  -> Seq.Seq Int+  -> Seq.Seq Int+  -> SeamProgress+  -> Either BuildError SeamFrontierIndex+combineSeamFrontier triangulation leftFrontier rightFrontier leftEdgeOffset rightEdgeOffset upperBridge lowerBridge progress+  | seamProgressLeftSize progress /= Seq.length (seamFrontierEdges leftFrontier) = Left SeamFrontierUnavailable+  | seamProgressRightSize progress /= Seq.length (seamFrontierEdges rightFrontier) = Left SeamFrontierUnavailable+  | otherwise = do+  leftEdges <- translatedEdges leftFrontier leftEdgeOffset+  rightEdges <- translatedEdges rightFrontier rightEdgeOffset+  rightResidual <-+    cycleSlice+      rightEdges+      (seamProgressRightSize progress)+      (seamProgressRightCursor progress)+      (previousIndex+         (seamProgressRightSize progress)+         (seamProgressRightStart progress))+  leftResidual <-+    cycleSlice+      leftEdges+      (seamProgressLeftSize progress)+      (seamProgressLeftStart progress)+      (seamProgressLeftCursor progress)+  let !outputEdges =+        upperBridge+          Seq.>< rightResidual+          Seq.>< lowerBridge+          Seq.>< leftResidual+      !rightOffset = Seq.length upperBridge+      !lowerOffset = rightOffset + Seq.length rightResidual+      !leftOffset = lowerOffset + Seq.length lowerBridge+      !rightEnd = previousIndex (seamProgressRightSize progress) progressRightStart+      !leftEnd = seamProgressLeftCursor progress+      !candidatePositions =+        IntSet.toAscList+          ( IntSet.fromList+              ( residualBoundaryPositions 0 upperBridge+                  ++ residualBoundaryPositions rightOffset rightResidual+                  ++ residualBoundaryPositions lowerOffset lowerBridge+                  ++ residualBoundaryPositions leftOffset leftResidual+                  ++ sourceAnchorPositions+                    rightOffset+                    (seamProgressRightCursor progress)+                    rightEnd+                    (seamProgressRightSize progress)+                    rightFrontier+                  ++ sourceAnchorPositions+                    leftOffset+                    progressLeftStart+                    leftEnd+                    (seamProgressLeftSize progress)+                    leftFrontier+              )+          )+  (minimumX, maximumX, lowerRight, lowerLeft, upperRight, upperLeft) <-+    summarizeOutputChart id candidatePositions outputEdges+  (minimumY, maximumY, yLowerRight, yLowerLeft, yUpperRight, yUpperLeft) <-+    summarizeOutputChart seamQuarterTurn candidatePositions outputEdges+  pure+    SeamFrontierIndex+      { seamFrontierEdges = outputEdges+      , seamFrontierXMinimum = minimumX+      , seamFrontierXMaximum = maximumX+      , seamFrontierLowerRightmost = lowerRight+      , seamFrontierLowerLeftmost = lowerLeft+      , seamFrontierUpperRightmost = upperRight+      , seamFrontierUpperLeftmost = upperLeft+      , seamFrontierYMinimum = minimumY+      , seamFrontierYMaximum = maximumY+      , seamFrontierYLowerRightmost = yLowerRight+      , seamFrontierYLowerLeftmost = yLowerLeft+      , seamFrontierYUpperRightmost = yUpperRight+      , seamFrontierYUpperLeftmost = yUpperLeft+      }+ where+  progressRightStart = seamProgressRightStart progress+  progressLeftStart = seamProgressLeftStart progress++  translatedEdges+    :: SeamFrontierIndex+    -> Int+    -> Either BuildError (Seq.Seq Int)+  translatedEdges frontier offset+    | offset == 0 = Right (seamFrontierEdges frontier)+    | otherwise = Right (fmap (+ offset) (seamFrontierEdges frontier))++  cycleSlice+    :: Seq.Seq Int+    -> Int+    -> Int+    -> Int+    -> Either BuildError (Seq.Seq Int)+  cycleSlice edges size start end+    | size <= 0 || start < 0 || end < 0 || start >= size || end >= size = Left SeamFrontierUnavailable+    | start <= end = Right (Seq.take (end - start + 1) (Seq.drop start edges))+    | otherwise =+        Right+          ( Seq.drop start edges+              Seq.>< Seq.take (end + 1) edges+          )++  residualBoundaryPositions :: Int -> Seq.Seq Int -> [Int]+  residualBoundaryPositions offset residual =+    case Seq.length residual of+      0 -> []+      lengthOfResidual -> [offset, offset + lengthOfResidual - 1]++  sourceAnchorPositions+    :: Int+    -> Int+    -> Int+    -> Int+    -> SeamFrontierIndex+    -> [Int]+  sourceAnchorPositions offset start end size frontier =+    [ offset + position+    | anchor <- sourceAnchors frontier+    , Right position <- [intervalPosition size anchor start end]+    ]++  sourceAnchors :: SeamFrontierIndex -> [Int]+  sourceAnchors frontier =+    [ seamFrontierLowerRightmost frontier+    , seamFrontierLowerLeftmost frontier+    , seamFrontierUpperRightmost frontier+    , seamFrontierUpperLeftmost frontier+    , seamFrontierYLowerRightmost frontier+    , seamFrontierYLowerLeftmost frontier+    , seamFrontierYUpperRightmost frontier+    , seamFrontierYUpperLeftmost frontier+    ]++  summarizeOutputChart+    :: ((Double, Double) -> (Double, Double))+    -> [Int]+    -> Seq.Seq Int+    -> Either BuildError (Double, Double, Int, Int, Int, Int)+  summarizeOutputChart transform candidatePositions outputEdges = do+    candidates <-+      traverse+        (\index -> do+           edge <- maybe (Left SeamFrontierUnavailable) Right (Seq.lookup index outputEdges)+           let !vertex = topologyAt triangulation (4 * edge)+           pure (index, physicalPoint triangulation vertex))+        candidatePositions+    maybe (Left SeamFrontierUnavailable) Right+      (summarizeSeamChart transform candidates)++  intervalPosition :: Int -> Int -> Int -> Int -> Either BuildError Int+  intervalPosition size target start end+    | target < 0 || target >= size = Left SeamFrontierUnavailable+    | start <= end =+        if target >= start && target <= end+          then Right (target - start)+          else Left SeamFrontierUnavailable+    | target >= start = Right (target - start)+    | target <= end = Right (size - start + target)+    | otherwise = Left SeamFrontierUnavailable++vertexOrientation+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> Int+  -> Int+  -> ST s Ordering+vertexOrientation mutable a b c = do+  ax <- readPointX mutable a+  ay <- readPointY mutable a+  bx <- readPointX mutable b+  by <- readPointY mutable b+  cx <- readPointX mutable c+  cy <- readPointY mutable c+  pure $! orient2dCoordinates ax ay bx by cx cy+{-# INLINE vertexOrientation #-}++vertexInCircle+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> Int+  -> Int+  -> Int+  -> ST s Ordering+vertexInCircle mutable a b c d = do+  ax <- readPointX mutable a+  ay <- readPointY mutable a+  bx <- readPointX mutable b+  by <- readPointY mutable b+  cx <- readPointX mutable c+  cy <- readPointY mutable c+  dx <- readPointX mutable d+  dy <- readPointY mutable d+  pure $! inCircleCoordinates ax ay bx by cx cy dx dy+{-# INLINE vertexInCircle #-}++appendSourceVertices+  :: MutableDcel s vertex () () ()+  -> Triangulation mode vertex () () ()+  -> ST s ()+appendSourceVertices mutable source =+  forRange 0 (numVertices source) $ \vertex -> do+    _ <-+      appendVertexCoordinates+        mutable+        (triPointX source `pagedUnsafeIndex` vertex)+        (triPointY source `pagedUnsafeIndex` vertex)+        (vertexData source (VertexId (fromIntegral vertex)))+    pure ()++copySource+  :: MutableDcel s vertex () () ()+  -> Triangulation mode vertex () () ()+  -> Int+  -> Int+  -> Int+  -> ST s ()+copySource mutable source vertexOffset edgeOffset faceOffset = do+  forRange 0 (numDirectedEdges source) $ \edge -> do+    let !target = edgeOffset + edge+        !sourceBase = 4 * edge+        !sourceFace = topologyAt source (sourceBase + 3)+        !targetFace = if sourceFace == 0 then 0 else faceOffset + sourceFace+    writeOrigin mutable target (vertexOffset + topologyAt source sourceBase)+    writeNext mutable target (edgeOffset + topologyAt source (sourceBase + 1))+    writePrevious mutable target (edgeOffset + topologyAt source (sourceBase + 2))+    writeFace mutable target targetFace+  forRange 0 (numVertices source) $ \vertex ->+    case vertexOutEdge source (VertexId (fromIntegral vertex)) of+      Nothing -> markConnected mutable (vertexOffset + vertex) (-1)+      Just (DirectedEdgeId edge) ->+        markConnected mutable (vertexOffset + vertex) (edgeOffset + fromIntegral edge)+  forRange 1 (numFaces source) $ \face ->+    case adjacentEdge source (FaceId (fromIntegral face)) of+      Nothing -> writeFaceEdge mutable (faceOffset + face) (-1)+      Just (DirectedEdgeId edge) ->+        writeFaceEdge mutable (faceOffset + face) (edgeOffset + fromIntegral edge)++copySourceConstraints+  :: MutableDcel s vertex () () ()+  -> Int+  -> Triangulation 'Constrained vertex () () ()+  -> ST s ()+copySourceConstraints mutable directedEdgeOffset source =+  traverse_+    (\(UndirectedEdgeId edge) ->+       ()+         <$ setConstraint+           mutable+           (directedEdgeOffset + 2 * fromIntegral edge)+    )+    (constraintEdges source)++spliceLowerTangent+  :: MutableDcel s vertex () () ()+  -> Int+  -> Int+  -> Int+  -> ST s Int+spliceLowerTangent mutable rightEdgeOffset leftOuter rightOuterSource = do+  let !rightOuter = rightEdgeOffset + rightOuterSource+  leftVertex <- readOrigin mutable leftOuter+  rightVertex <- readOrigin mutable rightOuter+  leftPrevious <- readPrevious mutable leftOuter+  rightPrevious <- readPrevious mutable rightOuter+  (forward, backward) <- addEdge mutable leftVertex rightVertex+  writeFace mutable forward 0+  writeFace mutable backward 0+  linkEdges mutable leftPrevious forward+  linkEdges mutable forward rightOuter+  linkEdges mutable rightPrevious backward+  linkEdges mutable backward leftOuter+  writeFaceEdge mutable 0 forward+  writeVertexOut mutable leftVertex forward+  writeVertexOut mutable rightVertex backward+  pure forward+{-# INLINE spliceLowerTangent #-}++topologyAt+  :: Triangulation mode vertex directed undirected face+  -> Int+  -> Int+topologyAt triangulation slot =+  fromIntegral (triHalfTopology triangulation `pagedUnsafeIndex` slot)+{-# INLINE topologyAt #-}+++forRange :: Monad m => Int -> Int -> (Int -> m ()) -> m ()+forRange from to action = go from+ where+  go !index+    | index >= to = pure ()+    | otherwise = action index >> go (index + 1)+{-# INLINE forRange #-}
+ src-build/Moonlight/Triangulation/Internal/Join/SiteSet.hs view
@@ -0,0 +1,400 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Exact transient site sections derived from the authoritative coordinate+-- planes. This is the sole owner of coordinate-set classification for joins,+-- set algebra, and constrained union. Payloads travel as annotations; they do+-- not participate in site identity.+module Moonlight.Triangulation.Internal.Join.SiteSet+  ( SiteSet+  , siteSetFromTriangulation+  , siteSupportFromTriangulation+  , siteSetSize+  , siteSetRelation+  , siteRelationFromTriangulations+  , siteSetUnionWith+  , siteSetIntersectionWith+  , siteSetDifference+  , siteSetSymmetricDifferenceFromTriangulations+  , siteSetAssocs+  , siteSetPoints+  , delaunayFromSiteSet+  , rebuildCanonicalSiteSet+  ) where++import Control.Monad.ST (ST, runST)+import qualified Data.Map.Strict as Map+import qualified Data.Map.Merge.Strict as MapMerge+import Data.Functor.Const (Const (..))+import Data.Maybe (isJust)+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MUV+import Moonlight.Triangulation.Internal.BulkLoad (delaunayFromAdmittedDistinctAscending)+import Moonlight.Triangulation.Dcel (numVertices, vertexData, vertexPoint)+import Moonlight.Triangulation.Internal.HandleDefs (VertexId (..))+import Moonlight.Triangulation.Internal.Canonical (canonicalizeKnownAscending)+import Moonlight.Triangulation.Handles.Iterators.FixedIterators+  ( foldVertices'+  )+import Moonlight.Triangulation.Internal.Paged+  ( pagedUnsafeIndex+  , toVector+  )+import Moonlight.Triangulation.Internal.PointIndex+  ( MutablePointIndex+  , lookupMutablePoint+  , lookupPointIndex+  , newMutablePointIndex+  , seedMutablePointIndex+  )+import Moonlight.Triangulation.Internal.Representation+  ( BuildResult (buildTriangulation)+  , Triangulation (..)+  )+import Moonlight.Triangulation.Internal.Types+  ( BuildError+  , ConstraintMode (Unconstrained)+  , Point (..)+  , QueryPoint (..)+  , SiteRelation (..)+  , unitElementDefaults+  )++newtype SiteSet annotation = SiteSet (Map.Map QueryPoint annotation)++-- Strict sufficient statistics for the one-pass ordered-map descent used by+-- 'siteSetRelation'. Keeping the census strict prevents a relation query from+-- replacing an intermediate map allocation with a chain of monoidal thunks.+data SiteRelationCensus = SiteRelationCensus !Int !Int !Int++instance Semigroup SiteRelationCensus where+  SiteRelationCensus leftA rightA overlapA <> SiteRelationCensus leftB rightB overlapB =+    SiteRelationCensus+      (leftA + leftB)+      (rightA + rightB)+      (overlapA + overlapB)++instance Monoid SiteRelationCensus where+  mempty = SiteRelationCensus 0 0 0++siteSetFromTriangulation+  :: Triangulation mode annotation directed undirected face+  -> SiteSet annotation+siteSetFromTriangulation triangulation =+  SiteSet+    ( Map.fromList+        [ ( QueryPoint+              ( Point+                  (triPointX triangulation `pagedUnsafeIndex` vertex)+                  (triPointY triangulation `pagedUnsafeIndex` vertex)+              )+          , vertexData triangulation (VertexId (fromIntegral vertex))+          )+        | vertex <- [0 .. numVertices triangulation - 1]+        ]+    )++-- | Coordinate support without touching the boxed annotation plane. Order and+-- set identity are geometric observations; callers that discard annotations+-- should not pay a boxed-page read per vertex merely to manufacture ignored+-- map values.+siteSupportFromTriangulation+  :: Triangulation mode vertex directed undirected face+  -> SiteSet ()+siteSupportFromTriangulation triangulation =+  SiteSet+    ( Map.fromList+        [ ( QueryPoint+              ( Point+                  (triPointX triangulation `pagedUnsafeIndex` vertex)+                  (triPointY triangulation `pagedUnsafeIndex` vertex)+              )+          , ()+          )+        | vertex <- [0 .. numVertices triangulation - 1]+        ]+    )+{-# INLINE siteSupportFromTriangulation #-}++siteSetSize :: SiteSet annotation -> Int+siteSetSize (SiteSet sites) = Map.size sites+{-# INLINE siteSetSize #-}++siteSetRelation+  :: SiteSet leftAnnotation+  -> SiteSet rightAnnotation+  -> SiteRelation+siteSetRelation (SiteSet left) (SiteSet right) =+  siteRelationFromCardinalities+    (leftOnly + overlap)+    (rightOnly + overlap)+    overlap+ where+  SiteRelationCensus leftOnly rightOnly overlap =+    getConst+      ( MapMerge.mergeA+          (MapMerge.traverseMissing (\_ _ -> Const (SiteRelationCensus 1 0 0)))+          (MapMerge.traverseMissing (\_ _ -> Const (SiteRelationCensus 0 1 0)))+          (MapMerge.zipWithAMatched (\_ _ _ -> Const (SiteRelationCensus 0 0 1)))+          left+          right+      )+{-# INLINE siteSetRelation #-}++siteRelationFromTriangulations+  :: Triangulation leftMode leftAnnotation leftDirected leftUndirected leftFace+  -> Triangulation rightMode rightAnnotation rightDirected rightUndirected rightFace+  -> SiteRelation+siteRelationFromTriangulations left right =+  siteRelationFromCardinalities leftCount rightCount overlap+ where+  !leftCount = numVertices left+  !rightCount = numVertices right+  !overlap+    | leftCount <= rightCount = exactOverlapCount right left+    | otherwise = exactOverlapCount left right+{-# INLINE siteRelationFromTriangulations #-}++siteRelationFromCardinalities :: Int -> Int -> Int -> SiteRelation+siteRelationFromCardinalities leftCount rightCount overlap+  | leftCount == rightCount && overlap == leftCount = EqualSites+  | overlap == leftCount = LeftProperSubset+  | overlap == rightCount = RightProperSubset+  | overlap == 0 = DisjointSites+  | otherwise = PartialOverlap overlap+{-# INLINE siteRelationFromCardinalities #-}++exactOverlapCount+  :: Triangulation sourceMode sourceAnnotation sourceDirected sourceUndirected sourceFace+  -> Triangulation indexedMode indexedAnnotation indexedDirected indexedUndirected indexedFace+  -> Int+exactOverlapCount source indexed =+  either+    (const (persistentExactOverlapCount source indexed))+    id+    (transientExactOverlapCount source indexed)+{-# INLINE exactOverlapCount #-}++transientExactOverlapCount+  :: Triangulation sourceMode sourceAnnotation sourceDirected sourceUndirected sourceFace+  -> Triangulation indexedMode indexedAnnotation indexedDirected indexedUndirected indexedFace+  -> Either BuildError Int+transientExactOverlapCount source indexed = runST $ do+  pointIndex <- newMutablePointIndex (numVertices indexed)+  seeded <-+    seedMutablePointIndex+      pointIndex+      (numVertices indexed)+      (readCoordinateX indexed)+      (readCoordinateY indexed)+  case seeded of+    Left failure -> pure (Left failure)+    Right () ->+      fmap Right+        ( U.ifoldM'+            (\count vertex x -> do+               let y = triPointY source `pagedUnsafeIndex` vertex+               match <-+                 lookupMutablePoint+                   pointIndex+                   (readCoordinateX indexed)+                   (readCoordinateY indexed)+                   x+                   y+               pure (if isJust match then count + 1 else count)+            )+            0+            (toVector (triPointX source))+        )+{-# INLINE transientExactOverlapCount #-}++persistentExactOverlapCount+  :: Triangulation sourceMode sourceAnnotation sourceDirected sourceUndirected sourceFace+  -> Triangulation indexedMode indexedAnnotation indexedDirected indexedUndirected indexedFace+  -> Int+persistentExactOverlapCount source indexed =+  foldVertices'+    source+    (\count vertex ->+       if pointOccursIn indexed (vertexPoint source vertex)+         then count + 1+         else count+    )+    0+{-# INLINE persistentExactOverlapCount #-}++siteSetUnionWith+  :: (annotation -> annotation -> annotation)+  -> SiteSet annotation+  -> SiteSet annotation+  -> SiteSet annotation+siteSetUnionWith combine (SiteSet left) (SiteSet right) =+  SiteSet (Map.unionWith combine left right)+{-# INLINE siteSetUnionWith #-}++siteSetIntersectionWith+  :: (leftAnnotation -> rightAnnotation -> annotation)+  -> SiteSet leftAnnotation+  -> SiteSet rightAnnotation+  -> SiteSet annotation+siteSetIntersectionWith combine (SiteSet left) (SiteSet right) =+  SiteSet (Map.intersectionWith combine left right)+{-# INLINE siteSetIntersectionWith #-}++siteSetDifference+  :: SiteSet annotation+  -> SiteSet other+  -> SiteSet annotation+siteSetDifference (SiteSet left) (SiteSet right) = SiteSet (Map.difference left right)+{-# INLINE siteSetDifference #-}++siteSetSymmetricDifferenceFromTriangulations+  :: Triangulation leftMode annotation leftDirected leftUndirected leftFace+  -> Triangulation rightMode annotation rightDirected rightUndirected rightFace+  -> Either BuildError (SiteSet annotation)+siteSetSymmetricDifferenceFromTriangulations left right+  | numVertices left >= numVertices right = indexedSymmetricDifference left right+  | otherwise = indexedSymmetricDifference right left+{-# INLINE siteSetSymmetricDifferenceFromTriangulations #-}++indexedSymmetricDifference+  :: forall sourceMode annotation sourceDirected sourceUndirected sourceFace+            indexedMode indexedDirected indexedUndirected indexedFace+  . Triangulation sourceMode annotation sourceDirected sourceUndirected sourceFace+  -> Triangulation indexedMode annotation indexedDirected indexedUndirected indexedFace+  -> Either BuildError (SiteSet annotation)+indexedSymmetricDifference source indexed =+  fmap (SiteSet . Map.fromList) (runST collectExclusiveAssociations)+ where+  collectExclusiveAssociations+    :: forall state. ST state (Either BuildError [(QueryPoint, annotation)])+  collectExclusiveAssociations = do+    pointIndex <- newMutablePointIndex (numVertices indexed)+    seeded <-+      seedMutablePointIndex+        pointIndex+        (numVertices indexed)+        (readCoordinateX indexed)+        (readCoordinateY indexed)+    case seeded of+      Left failure -> pure (Left failure)+      Right () -> do+        matchedIndexedVertices <- MUV.replicate (numVertices indexed) False+        sourceExclusive <-+          U.ifoldM'+            (collectSourceExclusive pointIndex matchedIndexedVertices)+            []+            (toVector (triPointX source))+        indexedExclusive <-+          U.ifoldM'+            (collectIndexedExclusive matchedIndexedVertices)+            []+            (toVector (triPointX indexed))+        pure (Right (sourceExclusive <> indexedExclusive))+   where+    collectSourceExclusive+      :: MutablePointIndex state+      -> MUV.MVector state Bool+      -> [(QueryPoint, annotation)]+      -> Int+      -> Double+      -> ST state [(QueryPoint, annotation)]+    collectSourceExclusive pointIndex matchedIndexedVertices associations rawVertex x = do+      let vertex = VertexId (fromIntegral rawVertex)+          y = triPointY source `pagedUnsafeIndex` rawVertex+          point = QueryPoint (Point x y)+      match <-+        lookupMutablePoint+          pointIndex+          (readCoordinateX indexed)+          (readCoordinateY indexed)+          x+          y+      case match of+        Nothing -> pure ((point, vertexData source vertex) : associations)+        Just indexedVertex -> do+          MUV.unsafeWrite matchedIndexedVertices indexedVertex True+          pure associations++    collectIndexedExclusive+      :: MUV.MVector state Bool+      -> [(QueryPoint, annotation)]+      -> Int+      -> Double+      -> ST state [(QueryPoint, annotation)]+    collectIndexedExclusive matchedIndexedVertices associations rawVertex x = do+      let vertex = VertexId (fromIntegral rawVertex)+          point = QueryPoint (Point x (triPointY indexed `pagedUnsafeIndex` rawVertex))+      matched <- MUV.unsafeRead matchedIndexedVertices rawVertex+      pure+        ( if matched+            then associations+            else (point, vertexData indexed vertex) : associations+        )+{-# INLINE indexedSymmetricDifference #-}++readCoordinateX+  :: Triangulation mode annotation directed undirected face+  -> Int+  -> ST state Double+readCoordinateX triangulation vertex =+  pure (triPointX triangulation `pagedUnsafeIndex` vertex)+{-# INLINE readCoordinateX #-}++readCoordinateY+  :: Triangulation mode annotation directed undirected face+  -> Int+  -> ST state Double+readCoordinateY triangulation vertex =+  pure (triPointY triangulation `pagedUnsafeIndex` vertex)+{-# INLINE readCoordinateY #-}++pointOccursIn+  :: Triangulation mode annotation directed undirected face+  -> Point+  -> Bool+pointOccursIn triangulation = isJust . lookupPointIn triangulation+{-# INLINE pointOccursIn #-}++lookupPointIn+  :: Triangulation mode annotation directed undirected face+  -> Point+  -> Maybe Int+lookupPointIn triangulation =+  lookupPointIndex+    (triPointX triangulation)+    (triPointY triangulation)+    (triPointIndex triangulation)+{-# INLINE lookupPointIn #-}++siteSetAssocs :: SiteSet annotation -> [(QueryPoint, annotation)]+siteSetAssocs (SiteSet sites) = Map.toAscList sites+{-# INLINE siteSetAssocs #-}++siteSetPoints :: SiteSet annotation -> V.Vector (Point)+siteSetPoints (SiteSet sites) = V.fromList (fmap queryPointValue (Map.keys sites))+{-# INLINE siteSetPoints #-}++-- | Publish an admitted exact site section through the one bulk-construction+-- engine. Its Map order is the trusted strict lexicographic vertex order; the+-- circle sweep still establishes the algorithm's radial execution order.+delaunayFromSiteSet+  :: SiteSet annotation+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+delaunayFromSiteSet sites =+  buildTriangulation+    <$> delaunayFromAdmittedDistinctAscending+      unitElementDefaults+      (V.fromList (siteSetAssocs sites))+{-# INLINE delaunayFromSiteSet #-}++-- | Canonical finite-set publication. The preceding SiteSet build preserves+-- lexicographic vertex order, so Canonical need not rediscover that fact.+rebuildCanonicalSiteSet+  :: SiteSet annotation+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+rebuildCanonicalSiteSet sites =+  delaunayFromSiteSet sites >>= canonicalizeKnownAscending+{-# INLINE rebuildCanonicalSiteSet #-}
+ src-build/Moonlight/Triangulation/Internal/Location.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE BangPatterns #-}++module Moonlight.Triangulation.Internal.Location+  ( MutableLocation (..)+  , locateMutable+  , locateMutableWithin+  , locateLineMutable+  , visibleOuterEdge+  ) where++import Control.Monad.ST (ST)+import Data.Bits ((.&.))+import qualified Data.IntSet as IntSet+import Data.STRef (readSTRef, writeSTRef)+import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex)+import Moonlight.Triangulation.Internal.FaceProbe+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , maxCounter+  )+import Moonlight.Triangulation.Internal.HandleDefs+  ( FaceId (..)+  , UndirectedEdgeId (..)+  )+import Moonlight.Triangulation.Internal.Predicates+import Moonlight.Triangulation.Math+  ( canonicalPoint+  , squaredDistanceWide+  )+import Moonlight.Triangulation.Types++data MutableLocation+  = MutableEmpty+  | MutableOnVertex {-# UNPACK #-} !Int+  | MutableOnEdge {-# UNPACK #-} !Int+  | MutableInFace {-# UNPACK #-} !Int+  | MutableOutsideHull {-# UNPACK #-} !Int+  deriving stock (Eq, Ord, Show)++locateMutable+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Maybe Int+  -> Point+  -> ST s (Either BuildError MutableLocation)+locateMutable mutable operation hint rawQuery = do+  locateMutableWithBarrier Nothing mutable operation hint rawQuery++-- | Locate from a checked local face while refusing to walk across the exact+-- interface section. The ordinary locator remains unchanged for unrestricted+-- refinement; the local interpreter supplies only its compact barrier pairs.+locateMutableWithin+  :: IntSet.IntSet+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Maybe Int+  -> Point+  -> ST s (Either BuildError MutableLocation)+locateMutableWithin interfacePairs =+  locateMutableWithBarrier (Just interfacePairs)++locateMutableWithBarrier+  :: Maybe IntSet.IntSet+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Maybe Int+  -> Point+  -> ST s (Either BuildError MutableLocation)+locateMutableWithBarrier barrier mutable operation hint rawQuery = do+  connected <- connectedCount mutable+  faces <- faceCount mutable+  let !query = canonicalPoint rawQuery+  case connected of+    0 -> pure (Right MutableEmpty)+    _ | faces <= 1 -> Right <$> locateLineMutable mutable query+    -- A hint is the caller vouching for adjacency, so the exact walk starts+    -- there directly; only an unhinted locate buys the vertex descent.+    _ | Just face <- hint, face > 0 && face < faces -> walkWithBarrier barrier mutable operation query face+    _ -> do+      start <- chooseStartFace mutable hint+      anchor <- readFaceEdge mutable start+      if anchor < 0+        then walkWithBarrier barrier mutable operation query start+        else do+          origin <- readOrigin mutable anchor+          nearest <- descendToNearest mutable operation query origin+          face <- incidentInnerFace mutable nearest start+          walkWithBarrier barrier mutable operation query face++-- | Greedy first-improvement descent through vertex neighbours: hop to the+-- first neighbour strictly closer to the query until none improves. Distance+-- is a heuristic only — exact containment belongs to 'walkWithBarrier' — so the widened+-- comparison can lengthen the path but never move the located answer.+--+-- Strictly decreasing distance bounds the hops and nothing else: no vertex is+-- entered twice, but the star rotation terminates only if @reverse . previous@+-- closes an orbit, which is a property of the links rather than of the+-- geometry. Disjoint stars over distinct entered vertices spend at most one+-- step per outgoing half-edge, so a budget past 'directedEdgeCount' cannot be+-- exhausted while the links are well formed. Exhausting it means they are not,+-- and yields the vertex in hand rather than an error — a truncated descent can+-- only lengthen 'walkWithBarrier', never move what it finds.+descendToNearest+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Point+  -> Int+  -> ST s Int+descendToNearest mutable operation query start = do+  halfEdges <- directedEdgeCount mutable+  point <- pointAt mutable start+  settle (halfEdges + 1) start (squaredDistanceWide query point)+ where+  settle !budget !vertex !best = do+    first <- readVertexOut mutable vertex+    if first < 0+      then pure vertex+      else rotate budget vertex best first first+  rotate !budget !vertex !best !first !edge+    | budget <= 0 = pure vertex+    | otherwise = do+        neighbour <- readOrigin mutable (reverseIndex edge)+        point <- pointAt mutable neighbour+        let !candidate = squaredDistanceWide query point+        if candidate < best+          then do+            addCounter operation CounterLocationWalkSteps 1+            settle (budget - 1) neighbour candidate+          else do+            previousEdge <- readPrevious mutable edge+            let !outgoing = reverseIndex previousEdge+            if outgoing == first then pure vertex else rotate (budget - 1) vertex best first outgoing++-- | An inner face incident to the vertex, so the exact walk starts adjacent+-- to where the descent settled; the caller's face stands in when the star+-- offers none.+incidentInnerFace+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> Int+  -> ST s Int+incidentInnerFace mutable vertex fallback = do+  first <- readVertexOut mutable vertex+  if first < 0 then pure fallback else rotate first first+ where+  rotate !first !edge = do+    face <- readFace mutable edge+    if face > 0+      then pure face+      else do+        previousEdge <- readPrevious mutable edge+        let !outgoing = reverseIndex previousEdge+        if outgoing == first then pure fallback else rotate first outgoing++locateLineMutable :: MutableDcel s vertex directed undirected face -> Point -> ST s MutableLocation+locateLineMutable mutable rawQuery = do+  let !query = canonicalPoint rawQuery+  vertices <- pointCount mutable+  exactVertex <- findVertex query vertices 0+  case exactVertex of+    Just vertex -> pure (MutableOnVertex vertex)+    Nothing -> do+      halfEdges <- directedEdgeCount mutable+      if halfEdges == 0+        then pure (MutableOutsideHull 0)+        else do+          onEdge <- findSegment query halfEdges 0+          case onEdge of+            Just edge -> pure (MutableOnEdge edge)+            Nothing -> do+              firstConnected <- findConnected vertices 0+              firstOut <- readVertexOut mutable firstConnected+              let edge = if firstOut < 0 then 0 else firstOut+              from <- edgeOriginPoint mutable edge+              to <- edgeOriginPoint mutable (reverseIndex edge)+              case orient2d from to query of+                GT -> pure (MutableOutsideHull (orientOuter edge))+                LT -> pure (MutableOutsideHull (orientOuter (reverseIndex edge)))+                EQ -> MutableOutsideHull <$> nearestTerminalEdge query halfEdges edge+ where+  findVertex !query !limit !index+    | index >= limit = pure Nothing+    | otherwise = do+        connected <- isConnected mutable index+        if not connected+          then findVertex query limit (index + 1)+          else do+            point <- pointAt mutable index+            if point == query then pure (Just index) else findVertex query limit (index + 1)++  findSegment !query !limit !edge+    | edge >= limit = pure Nothing+    | otherwise = do+        let normalized = edge .&. complementOne+        from <- edgeOriginPoint mutable normalized+        to <- edgeOriginPoint mutable (reverseIndex normalized)+        if onClosedSegment from to query+          then pure (Just normalized)+          else findSegment query limit (normalized + 2)++  findConnected !limit !index+    | index >= limit = pure 0+    | otherwise = do+        connected <- isConnected mutable index+        if connected then pure index else findConnected limit (index + 1)++  orientOuter :: Int -> Int+  orientOuter edge = edge++  -- A degenerate chain's outer cycle doubles back exactly at its two terminal+  -- vertices, so @next e == reverse e@ characterises the edge entering a+  -- terminal. Collinear extension must attach to the terminal nearest the+  -- query, which for three or more vertices is not an endpoint of any single+  -- arbitrary edge.+  nearestTerminalEdge !query !limit !fallback = go 0 Nothing+   where+    go !edge !best+      | edge >= limit = pure (maybe fallback fst best)+      | otherwise = do+          edgeNext <- readNext mutable edge+          if edgeNext /= reverseIndex edge+            then go (edge + 1) best+            else do+              let !terminal = reverseIndex edge+              point <- edgeOriginPoint mutable terminal+              let !candidate = squaredDistanceWide query point+              case best of+                Just (_, closest) | closest <= candidate -> go (edge + 1) best+                _ -> go (edge + 1) (Just (terminal, candidate))++  complementOne = -2++walkWithBarrier+  :: Maybe IntSet.IntSet+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Point+  -> Int+  -> ST s (Either BuildError MutableLocation)+walkWithBarrier barrier mutable operation query initialFace = do+  faces <- faceCount mutable+  halfEdges <- directedEdgeCount mutable+  let !budget = max 8 (faces + halfEdges `quot` 2 + 4)+  go budget 0 initialFace+ where+  go !remaining !steps !face+    | remaining <= 0 = do+        addCounter operation CounterLocationFallbacks 1+        maxCounter operation CounterLocationMaxWalk steps+        pure (Left (LocationWalkExhausted query steps))+    | face <= 0 = Right . MutableOutsideHull <$> visibleOuterEdge mutable query+    | otherwise = do+        addCounter operation CounterLocationWalkSteps 1+        let !nextSteps = steps + 1+        probe <- probeFace mutable face query+        case probe of+          MutableInFace found -> do+            writeSTRef (mdLastFace mutable) found+            maxCounter operation CounterLocationMaxWalk nextSteps+            pure (Right probe)+          MutableOnVertex _ -> do+            writeSTRef (mdLastFace mutable) face+            maxCounter operation CounterLocationMaxWalk nextSteps+            pure (Right probe)+          MutableOnEdge _ -> do+            writeSTRef (mdLastFace mutable) face+            maxCounter operation CounterLocationMaxWalk nextSteps+            pure (Right probe)+          MutableOutsideHull edge -> do+            adjacent <- readFace mutable edge+            if adjacent > 0+                && maybe False (IntSet.member (edge `quot` 2)) barrier+              then+                pure+                  ( Left+                      ( RefinementDomainWouldCrossInterface+                          (UndirectedEdgeId (fromIntegral (edge `quot` 2)))+                          (FaceId (fromIntegral face))+                      )+                  )+              else+                if adjacent == 0+                  then do+                    maxCounter operation CounterLocationMaxWalk nextSteps+                    pure (Right (MutableOutsideHull edge))+                  else go (remaining - 1) nextSteps adjacent+          MutableEmpty -> pure (Left (PointLocationFailed query))++probeFace :: MutableDcel s vertex directed undirected face -> Int -> Point -> ST s MutableLocation+-- 'faceEdges' walks the @next@ chain, so the cycle already states each+-- boundary's destination: @destination e0 = origin e1@. Reading the twin's+-- origin instead asks the store for what the face has already said, at twice+-- the endpoint loads and twice the coordinate loads per probe. Three origins+-- and three points settle all three boundaries. Vertex and edge hits still+-- return on the first boundary that reports one, and a later crossing still+-- displaces an earlier one.+probeFace mutable face query = do+  (e0, e1, e2) <- faceEdges mutable face+  a <- readOrigin mutable e0+  b <- readOrigin mutable e1+  c <- readOrigin mutable e2+  pa <- pointAt mutable a+  pb <- pointAt mutable b+  pc <- pointAt mutable c+  let !first = probeBoundary reverseIndex query e0 a pa b pb+  case first of+    BoundaryOnVertex vertex -> pure (MutableOnVertex vertex)+    BoundaryOnEdge boundary -> pure (MutableOnEdge boundary)+    _ -> do+      let !second = probeBoundary reverseIndex query e1 b pb c pc+      case second of+        BoundaryOnVertex vertex -> pure (MutableOnVertex vertex)+        BoundaryOnEdge boundary -> pure (MutableOnEdge boundary)+        _ -> do+          let !third = probeBoundary reverseIndex query e2 c pc a pa+          case third of+            BoundaryOnVertex vertex -> pure (MutableOnVertex vertex)+            BoundaryOnEdge boundary -> pure (MutableOnEdge boundary)+            _ -> pure $ case keep third (keep second (keep first Nothing)) of+              Nothing -> MutableInFace face+              Just boundary -> MutableOutsideHull boundary+ where+  keep :: BoundaryProbe boundary probeVertex -> Maybe boundary -> Maybe boundary+  keep (BoundaryCrossing boundary) _ = Just boundary+  keep _ held = held++chooseStartFace :: MutableDcel s vertex directed undirected face -> Maybe Int -> ST s Int+chooseStartFace mutable hint = do+  faces <- faceCount mutable+  cached <- readSTRef (mdLastFace mutable)+  let candidate = case hint of+        Just face | face > 0 && face < faces -> face+        _ | cached > 0 && cached < faces -> cached+        _ -> 1+  pure candidate++visibleOuterEdge :: MutableDcel s vertex directed undirected face -> Point -> ST s Int+visibleOuterEdge mutable query = do+  start <- readFaceEdge mutable 0+  halfEdges <- directedEdgeCount mutable+  if start < 0 || halfEdges == 0+    then pure 0+    else go (halfEdges + 1) start start Nothing+ where+  go !remaining !start !edge !fallback+    | remaining <= 0 = pure (maybe start id fallback)+    | otherwise = do+        from <- edgeOriginPoint mutable edge+        to <- edgeOriginPoint mutable (reverseIndex edge)+        let !side = orient2d from to query+            !fallback' = if side /= LT then Just edge else fallback+        if side == GT+          then pure edge+          else do+            edgeNext <- readNext mutable edge+            if edgeNext == start then pure (maybe edge id fallback') else go (remaining - 1) start edgeNext fallback'
+ src-build/Moonlight/Triangulation/Internal/Refinement.hs view
@@ -0,0 +1,1707 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Ruppert refinement over three local worklists: forced segment splits,+-- fixed-edge encroachment candidates, and skinny faces. A face candidate is+-- transactional: preflight locates the circumcenter and follows the+-- prospective legalization cavity without mutating topology; a fixed edge the+-- cavity meets is tested against the point's diametral disk and aborts the+-- plan into a segment split; otherwise the located site commits directly.+module Moonlight.Triangulation.Internal.Refinement+  ( RefinementInitialSeed (..)+  , RefinementDomain (..)+  , refineMutable+  ) where++import Control.Monad (filterM, forM_, unless, when)+import Control.Monad.ST (ST)+import Data.Foldable (traverse_)+import qualified Data.IntSet as IntSet+import Data.List (find)+import qualified Data.List as List+import qualified Data.IntMap.Strict as IntMap+import Data.Maybe (catMaybes, fromMaybe)+import Data.STRef (STRef, modifySTRef', newSTRef, readSTRef, writeSTRef)+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32)+import Moonlight.Triangulation.Internal.HandleDefs (FaceId (..), UndirectedEdgeId (..))+import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeEdges)+import Moonlight.Triangulation.Internal.DcelOperations.Subdivide (insertOnEdge)+import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex)+import Moonlight.Triangulation.Internal.Dyadic (exactDiametralDot)+import Moonlight.Triangulation.Internal.Growable+  ( GrowableWord32+  , clearGrowable+  , growableLength+  , newGrowableWord32+  , popGrowableOr+  , pushGrowable+  , readGrowable+  )+import Moonlight.Triangulation.Internal.Location+  ( MutableLocation (..)+  , locateMutable+  , locateMutableWithin+  )+import Moonlight.Triangulation.Internal.FaceQueue+  ( FaceQueue+  , newFaceQueue+  , popFace+  , pushFace+  )+import Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel (..)+  , addEdgeBlock+  , addFaceBlock+  , appendVertex+  , directedEdgeCount+  , edgeOriginPoint+  , ensureCellCapacity+  , faceCount+  , faceEdges+  , markConnected+  , pointAt+  , pointCapacity+  , readConstraint+  , readFace+  , readNext+  , readOrigin+  , readPrevious+  , readVertexOut+  , resetEdgeData+  , resetFaceData+  , setCycle3+  , writeOrigin+  , writeVertexOut+  )+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , maxCounter+  , readScratch+  , writeScratch+  )+import Moonlight.Triangulation.Internal.PackedIndex (noIndex, packIndex, unpackIndex)+import Moonlight.Triangulation.Internal.Predicates+  ( inCircle+  , inDiametralCircle+  , orient2d+  )+import Moonlight.Triangulation.Internal.Probe (Probe (..))+import Moonlight.Triangulation.Math+  ( canonicalPoint+  , circumcenter+  , isFinite+  , midpoint+  , squaredDistance+  , squaredDistanceWide+  , triangleArea+  , triangleRadiusEdgeRatioSquaredWithArea+  , triangleRadiusEdgeRatioSquaredWithAreaAndSides+  , validateCoordinate+  )+import Moonlight.Triangulation.Insertion (insertExistingVertexAtLocation)+import Moonlight.Triangulation.Types+  ( BuildError (..)+  , Point (..)+  , RefinementParameters (..)+  )++-- | The worklists refinement owns for the duration of one transaction. Cavity+-- and segment queues are local to the current rewrite; the face-capacity mark+-- planes remain a bounded publication workspace until the compact arena is+-- replaced by a domain-indexed one.+data BoolMarks s+  = DenseBoolMarks !(MUV.MVector s Bool)+  | SparseBoolMarks !(STRef s IntSet.IntSet)++data EpochMarks s+  = DenseEpochMarks !(MUV.MVector s Word32)+  | SparseEpochMarks !(STRef s (IntMap.IntMap Word32))++data PairSlots s+  = DensePairSlots !(MUV.MVector s Word32)+  | SparsePairSlots !(STRef s (IntMap.IntMap Word32))++data SegmentOrigins s+  = DenseSegmentOrigins !(MUV.MVector s Word32)+  | SparseSegmentOrigins !(STRef s (IntMap.IntMap (Word32, Word32)))++newBoolMarks :: Maybe Int -> ST s (BoolMarks s)+newBoolMarks capacity =+  case capacity of+    Just size -> DenseBoolMarks <$> MUV.replicate (max 1 size) False+    Nothing -> SparseBoolMarks <$> newSTRef IntSet.empty++readBoolMark :: BoolMarks s -> Int -> ST s Bool+readBoolMark marks index =+  case marks of+    DenseBoolMarks values -> MUV.unsafeRead values index+    SparseBoolMarks values -> IntSet.member index <$> readSTRef values++writeBoolMark :: BoolMarks s -> Int -> Bool -> ST s ()+writeBoolMark marks index enabled =+  case marks of+    DenseBoolMarks values -> MUV.unsafeWrite values index enabled+    SparseBoolMarks values ->+      modifySTRef' values+        (if enabled then IntSet.insert index else IntSet.delete index)++newEpochMarks :: Maybe Int -> ST s (EpochMarks s)+newEpochMarks capacity =+  case capacity of+    Just size -> DenseEpochMarks <$> MUV.replicate (max 1 size) 0+    Nothing -> SparseEpochMarks <$> newSTRef IntMap.empty++readEpochMark :: EpochMarks s -> Int -> ST s Word32+readEpochMark marks index =+  case marks of+    DenseEpochMarks values -> MUV.unsafeRead values index+    SparseEpochMarks values -> fromMaybe 0 . IntMap.lookup index <$> readSTRef values++writeEpochMark :: EpochMarks s -> Int -> Word32 -> ST s ()+writeEpochMark marks index epoch =+  case marks of+    DenseEpochMarks values -> MUV.unsafeWrite values index epoch+    SparseEpochMarks values -> modifySTRef' values (IntMap.insert index epoch)++clearEpochMarks :: EpochMarks s -> ST s ()+clearEpochMarks marks =+  case marks of+    DenseEpochMarks values -> MUV.set values 0+    SparseEpochMarks values -> writeSTRef values IntMap.empty++newPairSlots :: Maybe Int -> ST s (PairSlots s)+newPairSlots capacity =+  case capacity of+    Just size -> DensePairSlots <$> MUV.replicate (max 1 size) noIndex+    Nothing -> SparsePairSlots <$> newSTRef IntMap.empty++readPairSlot :: PairSlots s -> Int -> ST s Word32+readPairSlot slots pair =+  case slots of+    DensePairSlots values -> MUV.unsafeRead values pair+    SparsePairSlots values -> fromMaybe noIndex . IntMap.lookup pair <$> readSTRef values++writePairSlot :: PairSlots s -> Int -> Word32 -> ST s ()+writePairSlot slots pair value =+  case slots of+    DensePairSlots values -> MUV.unsafeWrite values pair value+    SparsePairSlots values ->+      modifySTRef' values+        (if value == noIndex then IntMap.delete pair else IntMap.insert pair value)++newSegmentOrigins :: Maybe Int -> ST s (SegmentOrigins s)+newSegmentOrigins capacity =+  case capacity of+    Just size -> DenseSegmentOrigins <$> MUV.replicate (2 * max 1 size) noIndex+    Nothing -> SparseSegmentOrigins <$> newSTRef IntMap.empty++readSegmentOrigin :: SegmentOrigins s -> Int -> ST s (Word32, Word32)+readSegmentOrigin origins vertex = do+  case origins of+    DenseSegmentOrigins values ->+      (,)+        <$> MUV.unsafeRead values (2 * vertex)+        <*> MUV.unsafeRead values (2 * vertex + 1)+    SparseSegmentOrigins values -> do+      stored <- readSTRef values+      pure (fromMaybe (noIndex, noIndex) (IntMap.lookup vertex stored))++writeSegmentOrigin :: SegmentOrigins s -> Int -> Word32 -> Word32 -> ST s ()+writeSegmentOrigin origins vertex first second =+  case origins of+    DenseSegmentOrigins values -> do+      MUV.unsafeWrite values (2 * vertex) first+      MUV.unsafeWrite values (2 * vertex + 1) second+    SparseSegmentOrigins values ->+      modifySTRef' values (IntMap.insert vertex (first, second))++data Workspace s = Workspace+  { wsQueue :: !(FaceQueue s)+  , wsExcluded :: !(BoolMarks s)+  , wsPermitted :: !(Maybe (BoolMarks s))+  , wsVisited :: !(Maybe (BoolMarks s))+  , wsInterfaceBoundaryReads :: !(STRef s Int)+  , wsBoundaryCrossingAttempts :: !(STRef s Int)+  , wsForcedSplits :: !(GrowableWord32 s)+  , wsEncroachment :: !(GrowableWord32 s)+  -- | Where each pair's live entry sits in 'wsEncroachment', 'noIndex' when+  -- the pair is not queued. A re-push relocates the pair to the top and leaves+  -- the older entry behind as a slot that no longer names it, so a pair is+  -- tested once at its most recent offer instead of once per offer.+  , wsEncroachmentSlot :: !(PairSlots s)+  -- | Steiner vertices on constraints carry the original segment's endpoint+  -- pair, two words per vertex, 'noIndex' when the vertex is not on one.+  , wsSegmentOrigin :: !(SegmentOrigins s)+  -- | Cavity discovery state: an epoch stamp per face, edge pair and boundary+  -- vertex, plus the three records a successful commit consumes. A cavity is+  -- explored without mutating topology; the commit either fans the recorded+  -- boundary or abandons the records entirely.+  , wsCavityEpoch :: !(STRef s Word32)+  , wsCavityFaceMarks :: !(EpochMarks s)+  , wsCavityPairMarks :: !(EpochMarks s)+  , wsCavityVertexMarks :: !(EpochMarks s)+  , wsCavityFaces :: !(GrowableWord32 s)+  , wsCavityInternal :: !(GrowableWord32 s)+  , wsCavityBoundary :: !(GrowableWord32 s)+  , wsCavityCocircular :: !(GrowableWord32 s)+  -- | The recorded boundary in cycle order, written by the chaining walk and+  -- read by the fan.+  , wsCavityChain :: !(GrowableWord32 s)+  -- | The flood and hull-simulation stack. The old mesh-global work stack+  -- served both; the transaction owns it now, cleared before either use.+  , wsCavityWork :: !(GrowableWord32 s)+  }++data FaceHint+  = FaceAcceptable+  | FaceMustSplitLongestEdge+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Double+  | FaceMustRefine+  | FaceShouldRefine++data EdgeSplitLaw+  = SplitFixedSegment+  | SplitQualityEdge++-- | The initial support a refinement run is allowed to inspect. Subsequent+-- cavity, star, and fixed-edge propagation remains exactly the ordinary+-- refinement law; only the first offers differ. The constructor is internal+-- so public callers cannot smuggle a mutable worklist across the transaction+-- boundary.+data RefinementInitialSeed+  = RefineEveryFace+  | RefineSeededFaces !IntSet.IntSet++-- | A checked local section. Face and edge integers are admitted by the+-- immutable constructor in "Moonlight.Triangulation.Refinement"; the mutable+-- interpreter sees only the already-descended dense membership witnesses.+data RefinementDomain = RefinementDomain+  { refinementDomainPermittedFaces :: !IntSet.IntSet+  , refinementDomainInterfacePairs :: !IntSet.IntSet+  , refinementDomainInputFaceCount :: {-# UNPACK #-} !Int+  }+  deriving stock (Eq, Show)++-- | Refine the existing finite DCEL. Fixed edges (constraints and the convex+-- hull) are legal barriers: a candidate whose prospective cavity meets one+-- inside its diametral disk is abandoned and the segment is split instead.+-- The result is @(worklists-drained, Steiner-count, excluded-outer-faces)@.+refineMutable+  :: forall s vertex directed undirected face. (Point -> vertex)+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> RefinementParameters+  -> Int+  -> IntSet.IntSet+  -> RefinementInitialSeed+  -> Maybe RefinementDomain+  -> ST s (Either BuildError (Bool, Int, [Int], [Int], [Int], Int, Int))+refineMutable makeVertex mutable operation parameters budget initialExcludedFaces initialSeed domain = do+  let !faceBound =+        case domain of+          Nothing -> Just (3 * pointCapacity mutable + 8)+          Just _ -> Nothing+      !pairBound =+        case domain of+          Nothing -> Just (mdHalfCapacity mutable `quot` 2)+          Just _ -> Nothing+      !vertexBound =+        case domain of+          Nothing -> Just (pointCapacity mutable)+          Just _ -> Nothing+  wsQueue <- newFaceQueue faceBound+  wsExcluded <- newBoolMarks faceBound+  wsPermitted <- traverse (const (newBoolMarks Nothing)) domain+  wsVisited <- traverse (const (newBoolMarks Nothing)) domain+  wsInterfaceBoundaryReads <- newSTRef 0+  wsBoundaryCrossingAttempts <- newSTRef 0+  traverse_+    (\membership ->+       traverse_+         (\face -> writeBoolMark membership face True)+         (maybe [] (IntSet.toAscList . refinementDomainPermittedFaces) domain)+    )+    wsPermitted+  when (refineExcludeOuterFaces parameters) $+    traverse_ (\face -> writeBoolMark wsExcluded face True)+      (IntSet.toAscList initialExcludedFaces)+  wsForcedSplits <- newGrowableWord32 16+  wsEncroachment <- newGrowableWord32 64+  wsEncroachmentSlot <- newPairSlots pairBound+  wsSegmentOrigin <- newSegmentOrigins vertexBound+  wsCavityEpoch <- newSTRef 0+  wsCavityFaceMarks <- newEpochMarks faceBound+  wsCavityPairMarks <- newEpochMarks pairBound+  wsCavityVertexMarks <- newEpochMarks vertexBound+  wsCavityFaces <- newGrowableWord32 16+  wsCavityInternal <- newGrowableWord32 16+  wsCavityBoundary <- newGrowableWord32 16+  wsCavityCocircular <- newGrowableWord32 4+  wsCavityChain <- newGrowableWord32 16+  wsCavityWork <- newGrowableWord32 16+  let workspace = Workspace{wsQueue, wsExcluded, wsPermitted, wsVisited, wsInterfaceBoundaryReads, wsBoundaryCrossingAttempts, wsForcedSplits, wsEncroachment, wsEncroachmentSlot, wsSegmentOrigin, wsCavityEpoch, wsCavityFaceMarks, wsCavityPairMarks, wsCavityVertexMarks, wsCavityFaces, wsCavityInternal, wsCavityBoundary, wsCavityCocircular, wsCavityChain, wsCavityWork}+  seedInitialWork workspace initialSeed+  loop workspace IntMap.empty 0+ where+  !limit = max 0 budget++  -- The three bounds every queued face is measured against. They are fixed for+  -- the whole run, and the ratio bound is squared once here rather than once+  -- per face the ratio test reaches.+  !maximumArea = refineMaxArea parameters+  !minimumArea = refineMinArea parameters+  !maximumSquaredEdgeLength = fmap (\bound -> bound * bound) (refineMaxEdgeLength parameters)+  !squaredRatioBound = case refineMaxRadiusEdgeRatio parameters of+    Nothing -> Nothing+    Just bound -> Just $! squareBound bound++  -- One charged stack push: the old mesh-global 'pushWork' wrapper fed the+  -- legalization depth counter on every push, and the hull-simulation sites+  -- used that wrapper deliberately. The cavity flood's bypass stays raw.+  pushChargedWork :: GrowableWord32 s -> Int -> ST s ()+  pushChargedWork work value = do+    pushGrowable work (packIndex value)+    size <- growableLength work+    maxCounter operation CounterLegalizationMaxStack size++  -- Offer a fixed edge pair for the encroachment question. An offer always+  -- wins the pair's slot, so the pair is answered at its most recent offer and+  -- the entries it left behind are recognised as superseded when reached.+  pushEncroachment :: Workspace s -> Int -> ST s ()+  pushEncroachment Workspace{wsEncroachment, wsEncroachmentSlot} pair = do+    index <- growableLength wsEncroachment+    pushGrowable wsEncroachment (packIndex pair)+    writePairSlot wsEncroachmentSlot pair (packIndex index)++  -- 'noIndex' when the offers are drained.+  popEncroachment :: Workspace s -> ST s Word32+  popEncroachment Workspace{wsEncroachment, wsEncroachmentSlot} = go+   where+    go = do+      size <- growableLength wsEncroachment+      if size <= 0+        then pure noIndex+        else do+          let !index = size - 1+          packed <- popGrowableOr noIndex wsEncroachment+          let !pair = fromIntegral packed+          slot <- readPairSlot wsEncroachmentSlot pair+          if slot == packIndex index+            then do+              writePairSlot wsEncroachmentSlot pair noIndex+              pure packed+            else go++  -- The cavity epoch stamps three planes and is compared against them, so the+  -- wrap has to retire every stamp a reused value would answer for.+  nextCavityEpoch :: Workspace s -> ST s Word32+  nextCavityEpoch Workspace{wsCavityEpoch, wsCavityFaceMarks, wsCavityPairMarks, wsCavityVertexMarks} = do+    current <- readSTRef wsCavityEpoch+    let !next = current + 1+    if next == 0+      then do+        clearEpochMarks wsCavityFaceMarks+        clearEpochMarks wsCavityPairMarks+        clearEpochMarks wsCavityVertexMarks+        writeSTRef wsCavityEpoch 1+        pure 1+      else do+        writeSTRef wsCavityEpoch next+        pure next++  loop+    :: Workspace s+    -> IntMap.IntMap Double+    -> Int+    -> ST s (Either BuildError (Bool, Int, [Int], [Int], [Int], Int, Int))+  loop workspace@Workspace{wsQueue, wsForcedSplits} pendingOversizedEdges !added+    | added >= limit = finish workspace pendingOversizedEdges False added+    | otherwise = do+        forced <- popGrowableOr noIndex wsForcedSplits+        if forced /= noIndex+          then do+            splitOutcome <- resolveSplit SplitFixedSegment workspace (fromIntegral forced)+            case splitOutcome of+              Left obstruction -> pure (Left obstruction)+              Right split ->+                if split+                  then loop workspace pendingOversizedEdges (added + 1)+                  else do+                    -- The split refused (degenerate position or a kept+                    -- constraint). Retrying the face that forced it would loop,+                    -- so one queued face is sacrificed, exactly the face whose+                    -- requeue sits on top.+                    _ <- popFace wsQueue+                    loop workspace pendingOversizedEdges added+          else do+            candidate <- popEncroachment workspace+            if candidate /= noIndex+              then do+                splitOutcome <- checkEncroachment workspace (fromIntegral candidate)+                case splitOutcome of+                  Left obstruction -> pure (Left obstruction)+                  Right split ->+                    loop+                      workspace+                      pendingOversizedEdges+                      (if split then added + 1 else added)+              else do+                next <- popFace wsQueue+                case next of+                  Nothing -> finish workspace pendingOversizedEdges True added+                  Just face -> do+                    outcome <- handleFace workspace face+                    case outcome of+                      Left failure -> pure (Left failure)+                      Right (gained, pendingEdge) ->+                        loop+                          workspace+                          ( maybe+                              pendingOversizedEdges+                              (\(pair, actualSquaredLength) ->+                                 IntMap.insertWith+                                   max+                                   pair+                                   actualSquaredLength+                                   pendingOversizedEdges+                              )+                              pendingEdge+                          )+                          (added + gained)++  finish+    :: Workspace s+    -> IntMap.IntMap Double+    -> Bool+    -> Int+    -> ST s (Either BuildError (Bool, Int, [Int], [Int], [Int], Int, Int))+  finish workspace@Workspace{wsExcluded, wsPermitted, wsVisited, wsInterfaceBoundaryReads, wsBoundaryCrossingAttempts} pendingOversizedEdges complete added = do+    pendingObstruction <-+      if complete+        then completedMaximumEdgeObstruction workspace pendingOversizedEdges+        else pure (Right Nothing)+    case pendingObstruction of+      Left failure -> pure (Left failure)+      Right (Just failure) -> pure (Left failure)+      Right Nothing -> do+        excludedFaces <- markedIndices wsExcluded+        visitedFaces <- maybe (pure []) markedIndices wsVisited+        permittedFaces <- maybe (pure []) markedIndices wsPermitted+        interfaceBoundaryReads <- readSTRef wsInterfaceBoundaryReads+        boundaryCrossingAttempts <- readSTRef wsBoundaryCrossingAttempts+        pure (Right (complete, added, excludedFaces, visitedFaces, permittedFaces, interfaceBoundaryReads, boundaryCrossingAttempts))++  -- A quality edge that cannot be split is remembered at the point where the+  -- worklist discovers it.  Only a drained run discharges the pending section;+  -- a budget-limited run remains an ordinary resumable publication.  The+  -- final face is read from the constant-degree live edge neighbourhood so the+  -- reported obstruction retains the former face/edge ordering without an+  -- all-face audit.+  completedMaximumEdgeObstruction+    :: Workspace s+    -> IntMap.IntMap Double+    -> ST s (Either BuildError (Maybe BuildError))+  completedMaximumEdgeObstruction workspace pendingOversizedEdges =+    case refineMaxEdgeLength parameters of+      Nothing -> pure (Right Nothing)+      Just maximumLength -> do+        candidateResults <-+          traverse+            (liveOversizedEdgeCandidate workspace)+            (IntMap.toAscList pendingOversizedEdges)+        pure $ do+          candidates <- catMaybes <$> sequence candidateResults+          Right+            ( case List.sortOn (\(face, pair, _) -> (face, pair)) candidates of+                [] -> Nothing+                (face, pair, actualSquaredLength) : _ ->+                  Just+                    ( RefinementOversizedEdge+                        (FaceId (fromIntegral face))+                        (UndirectedEdgeId (fromIntegral pair))+                        (sqrt actualSquaredLength)+                        maximumLength+                    )+            )++  liveOversizedEdgeCandidate+    :: Workspace s+    -> (Int, Double)+    -> ST s (Either BuildError (Maybe (Int, Int, Double)))+  liveOversizedEdgeCandidate workspace (pair, actualSquaredLength) = do+    directedTotal <- directedEdgeCount mutable+    let directed = 2 * pair+    if directed < 0 || directed + 1 >= directedTotal+      then pure (Left RefinementDomainTopologyChanged)+      else do+        forwardFace <- readFace mutable directed+        backwardFace <- readFace mutable (reverseIndex directed)+        eligibleFaces <-+          filterM+            (maximumEdgeFaceEligible workspace)+            [forwardFace, backwardFace]+        pure+          ( Right+              ( case eligibleFaces of+                  [] -> Nothing+                  _ -> Just (minimum eligibleFaces, pair, actualSquaredLength)+              )+          )++  maximumEdgeFaceEligible :: Workspace s -> Int -> ST s Bool+  maximumEdgeFaceEligible Workspace{wsExcluded, wsPermitted} face+    | face <= 0 = pure False+    | otherwise = do+        excluded <- readBoolMark wsExcluded face+        permitted <-+          maybe+            (pure True)+            (\membership -> readBoolMark membership face)+            wsPermitted+        pure (not excluded && permitted)++  markedIndices :: BoolMarks s -> ST s [Int]+  markedIndices marks =+    case marks of+      DenseBoolMarks values -> do+        let indices = [0 .. MUV.length values - 1]+        filterM (MUV.unsafeRead values) indices+      SparseBoolMarks values -> IntSet.toAscList <$> readSTRef values+++  offerAll :: FaceQueue s -> ST s ()+  offerAll queue = do+    faces <- faceCount mutable+    forM_ [1 .. faces - 1] (pushFace queue)++  -- A seeded run is not a weaker refinement interpreter. It begins at the+  -- supplied faces and asks only the fixed edges those faces can immediately+  -- encroach; every later cavity and star contributes its own local closure+  -- through the same queue and encroachment machinery as the global entry.+  seedInitialWork :: Workspace s -> RefinementInitialSeed -> ST s ()+  seedInitialWork workspace seed =+    case seed of+      RefineEveryFace -> seedFixedEdges workspace >> offerAll (wsQueue workspace)+      RefineSeededFaces faces ->+        traverse_ (seedFace workspace) (IntSet.toAscList faces)++  seedFace :: Workspace s -> Int -> ST s ()+  seedFace workspace face = do+    pushFace (wsQueue workspace) face+    (e0, e1, e2) <- faceEdges mutable face+    traverse_ (offerFixedEdge workspace) [e0, e1, e2]++  -- Every fixed edge present at entry, queued once for the existing-vertex+  -- encroachment question. Later candidates arrive from the star walks of the+  -- insertions that could have created a new encroachment.+  seedFixedEdges :: Workspace s -> ST s ()+  seedFixedEdges workspace = do+    halfEdges <- directedEdgeCount mutable+    traverse_+      (offerFixedEdge workspace . (2 *))+      [0 .. halfEdges `quot` 2 - 1]++  offerFixedEdge :: Workspace s -> Int -> ST s ()+  offerFixedEdge workspace directed = do+    fixed <- isFixedEdge directed+    let !pair = directed `quot` 2+    -- An interface is a fixed boundary condition, not a quality obligation+    -- owned by this section. It is still encountered by candidate cavities,+    -- where any demand to split or cross it is a typed obstruction.+    when (fixed && not (isInterfacePair pair)) $+      pushEncroachment workspace pair++  isFixedEdge :: Int -> ST s Bool+  isFixedEdge directed = do+    if isInterfacePair (directed `quot` 2)+      then pure True+      else do+        protected <- readConstraint mutable directed+        if protected+          then pure True+          else do+            own <- readFace mutable directed+            if own == 0+              then pure True+              else (== 0) <$> readFace mutable (reverseIndex directed)++  isInterfacePair :: Int -> Bool+  isInterfacePair pair =+    maybe False (IntSet.member pair . refinementDomainInterfacePairs) domain+  {-# INLINE isInterfacePair #-}++  isHullPair :: Int -> ST s Bool+  isHullPair pair = do+    forwardFace <- readFace mutable (2 * pair)+    backwardFace <- readFace mutable (2 * pair + 1)+    pure (forwardFace == 0 || backwardFace == 0)++  interfaceCrossing :: Workspace s -> Int -> ST s BuildError+  interfaceCrossing Workspace{wsPermitted, wsBoundaryCrossingAttempts} pair = do+    modifySTRef' wsBoundaryCrossingAttempts (+ 1)+    forwardFace <- readFace mutable (2 * pair)+    backwardFace <- readFace mutable (2 * pair + 1)+    joinFace <-+      case wsPermitted of+        Nothing -> pure Nothing+        Just permitted -> do+          forwardPermitted <- dynamicPermitted permitted forwardFace+          backwardPermitted <- dynamicPermitted permitted backwardFace+          pure+            ( if forwardPermitted+                then Just forwardFace+                else if backwardPermitted then Just backwardFace else Nothing+            )+    let result =+          case joinFace of+            Just face ->+              RefinementDomainWouldCrossInterface+                (UndirectedEdgeId (fromIntegral pair))+                (FaceId (fromIntegral face))+            Nothing -> RefinementDomainTopologyChanged+    pure result+   where+    dynamicPermitted :: BoolMarks s -> Int -> ST s Bool+    dynamicPermitted membership face =+      if face > 0 then readBoolMark membership face else pure False++  -- The edge bound is a hard geometric law and therefore precedes the minimum+  -- area short-circuit: a long, thin face must get a direct longest-edge split+  -- even when its area is below the configured minimum. The area bound then+  -- condemns outright ('FaceMustRefine'); the ratio bound only invites+  -- refinement, which the input-angle guard may still decline.+  faceHint :: Int -> Int -> Int -> Point -> Point -> Point -> FaceHint+  faceHint e0 e1 e2 p0 p1 p2 =+    case maximumSquaredEdgeLength of+      Just maximumSquaredLength ->+        let (!longestEdge, !longestSquaredLength, !side01, !side12, !side20) =+              faceEdgeMetrics e0 e1 e2 p0 p1 p2+         in if exceeds longestSquaredLength maximumSquaredLength+              then+                FaceMustSplitLongestEdge+                  (longestEdge `quot` 2)+                  longestSquaredLength+              else+                nonEdgeHint+                  ( ratioBad+                      ( triangleRadiusEdgeRatioSquaredWithAreaAndSides+                          area+                          side01+                          side12+                          side20+                      )+                  )+      Nothing ->+        nonEdgeHint+          (ratioBad (triangleRadiusEdgeRatioSquaredWithArea area p0 p1 p2))+   where+    !area = triangleArea p0 p1 p2+    areaBad = maybe False (exceeds area) maximumArea+    belowMinimum = maybe False (area <) minimumArea+    ratioBad :: Double -> Bool+    ratioBad ratio = case squaredRatioBound of+      Nothing -> False+      Just bound -> exceeds ratio bound+    nonEdgeHint angleBad+      | areaBad = FaceMustRefine+      | belowMinimum = FaceAcceptable+      | angleBad = FaceShouldRefine+      | otherwise = FaceAcceptable++  handleFace+    :: Workspace s+    -> Int+    -> ST s (Either BuildError (Int, Maybe (Int, Double)))+  handleFace workspace@Workspace{wsExcluded, wsPermitted, wsVisited} face = do+    addCounter operation CounterRefinementQueuePops 1+    permitted <-+      maybe+        (pure True)+        (\membership -> readBoolMark membership face)+        wsPermitted+    if not permitted+      then pure (Left (RefinementDomainWouldRewriteProtectedFace (FaceId (fromIntegral face))))+      else do+        traverse_ (\visited -> writeBoolMark visited face True) wsVisited+        skip <- readBoolMark wsExcluded face+        if skip+          then pure (Right (0, Nothing))+          else do+            addCounter operation CounterRefinementFaceChecks 1+            (e0, e1, e2) <- faceEdges mutable face+            p0 <- edgeOriginPoint mutable e0+            p1 <- edgeOriginPoint mutable e1+            p2 <- edgeOriginPoint mutable e2+            case faceHint e0 e1 e2 p0 p1 p2 of+              FaceAcceptable -> pure (Right (0, Nothing))+              FaceMustSplitLongestEdge pair actualSquaredLength ->+                qualitySplit workspace pair actualSquaredLength+              FaceMustRefine ->+                fmap+                  (fmap (\gained -> (gained, Nothing)))+                  (attemptCandidate workspace face p0 p1 p2)+              FaceShouldRefine -> do+                blocked <- inputAngleBlocks workspace e0 e1 e2 p0 p1 p2+                if blocked+                  then pure (Right (0, Nothing))+                  else+                    fmap+                      (fmap (\gained -> (gained, Nothing)))+                      (attemptCandidate workspace face p0 p1 p2)++  faceEdgeMetrics+    :: Int+    -> Int+    -> Int+    -> Point+    -> Point+    -> Point+    -> (Int, Double, Double, Double, Double)+  faceEdgeMetrics e0 e1 e2 p0 p1 p2+    | side01 >= side12 && side01 >= side20 = result e0 side01+    | side12 >= side20 = result e1 side12+    | otherwise = result e2 side20+   where+    !side01 = squaredDistanceWide p0 p1+    !side12 = squaredDistanceWide p1 p2+    !side20 = squaredDistanceWide p2 p0+    result :: Int -> Double -> (Int, Double, Double, Double, Double)+    result edge longest = (edge, longest, side01, side12, side20)++  -- An unsplittable quality edge is a pending law obstruction, not permission+  -- to cross a frozen interface and not immediate failure of a resumable run.+  qualitySplit+    :: Workspace s+    -> Int+    -> Double+    -> ST s (Either BuildError (Int, Maybe (Int, Double)))+  qualitySplit workspace pair actualSquaredLength = do+    outcome <- resolveSplit SplitQualityEdge workspace pair+    case outcome of+      Left (RefinementDomainWouldCrossInterface _ _) ->+        pure (Right (0, Just (pair, actualSquaredLength)))+      Left failure -> pure (Left failure)+      Right True -> pure (Right (1, Nothing))+      Right False -> pure (Right (0, Just (pair, actualSquaredLength)))++  -- Two subsegments of one original segment meeting at a small input angle+  -- cannot be refined apart: the angle is fixed by the input geometry. When+  -- the shortest edge of a ratio-bound face joins two Steiner vertices whose+  -- lineages share an original endpoint, the face is as good as it gets.+  inputAngleBlocks :: Workspace s -> Int -> Int -> Int -> Point -> Point -> Point -> ST s Bool+  inputAngleBlocks Workspace{wsSegmentOrigin} e0 e1 e2 p0 p1 p2 = do+    let !shortest = shortestFaceEdge e0 e1 e2 p0 p1 p2+    a <- readOrigin mutable shortest+    b <- readOrigin mutable (reverseIndex shortest)+    shared <- sharedSegmentOrigin wsSegmentOrigin a b+    if not shared+      then pure False+      else not <$> isFixedEdge shortest++  shortestFaceEdge :: Int -> Int -> Int -> Point -> Point -> Point -> Int+  shortestFaceEdge e0 e1 e2 p0 p1 p2+    | side01 <= side12 && side01 <= side20 = e0+    | side12 <= side20 = e1+    | otherwise = e2+   where+    !side01 = squaredDistanceWide p0 p1+    !side12 = squaredDistanceWide p1 p2+    !side20 = squaredDistanceWide p2 p0++  sharedSegmentOrigin :: SegmentOrigins s -> Int -> Int -> ST s Bool+  sharedSegmentOrigin lineage a b = do+    (a0, a1) <- readSegmentOrigin lineage a+    (b0, b1) <- readSegmentOrigin lineage b+    pure (a0 /= noIndex && b0 /= noIndex && (a0 == b0 || a0 == b1 || a1 == b0 || a1 == b1))++  validCandidate :: Point -> Maybe (Point)+  validCandidate point@(Point x y)+    | validateCoordinate x == Nothing && validateCoordinate y == Nothing = Just point+    | otherwise = Nothing++  attemptCandidate :: Workspace s -> Int -> Point -> Point -> Point -> ST s (Either BuildError Int)+  attemptCandidate workspace@Workspace{wsExcluded, wsForcedSplits} face p0 p1 p2 =+    case circumcenter p0 p1 p2 >>= validCandidate of+      Nothing -> pure (Right 0)+      Just point -> do+        located <-+          case domain of+            Nothing -> locateMutable mutable operation (Just face) point+            Just refinementDomain ->+              locateMutableWithin+                (refinementDomainInterfacePairs refinementDomain)+                mutable+                operation+                (Just face)+                point+        case located of+          -- The local locator has proved that the circumcenter lies beyond+          -- Γ without crossing it.  This is the same boundary-limited fixed+          -- point as a circumcenter outside a preserved hull: no admissible+          -- rewrite exists inside this section, so the face is discharged.+          -- Actual cavity demands involving Γ remain typed obstructions in+          -- 'exploreThenCommit'.+          Left (RefinementDomainWouldCrossInterface _ _) -> do+            modifySTRef' (wsInterfaceBoundaryReads workspace) (+ 1)+            pure (Right 0)+          Left failure -> pure (Left failure)+          Right site -> case site of+            MutableOnVertex _ -> pure (Right 0)+            MutableEmpty -> pure (Right 0)+            MutableOutsideHull edge+              | refinePreserveConvexHull parameters -> pure (Right 0)+              | otherwise -> attemptOutside workspace face point edge+            MutableOnEdge edge -> do+              hull <- case domain of+                Nothing -> pure False+                Just _ -> isHullPair (edge `quot` 2)+              if hull+                then pure (Right 0)+                else if isInterfacePair (edge `quot` 2)+                then Left <$> interfaceCrossing workspace (edge `quot` 2)+                else do+                  protected <- readConstraint mutable edge+                  if protected+                    then do+                      -- A circumcenter on a constraint is a request to split that+                      -- constraint, unless constraints are kept whole.+                      unless (refineKeepConstraintEdges parameters) $+                        pushGrowable wsForcedSplits (packIndex (edge `quot` 2))+                      pure (Right 0)+                    else exploreThenCommit workspace face point site+            MutableInFace under -> do+              permittedSite <-+                maybe+                  (pure True)+                  (\membership -> readBoolMark membership under)+                  (wsPermitted workspace)+              if not permittedSite+                then pure (Left (RefinementDomainWouldRewriteProtectedFace (FaceId (fromIntegral under))))+                else do+                  excludedSite <- readBoolMark wsExcluded under+                  if excludedSite+                    then pure (Right 0)+                    else exploreThenCommit workspace face point site++  -- Follow the prospective legalization cavity of the candidate without+  -- mutating topology, recording what the commit will consume: the cavity+  -- faces, the internal edge pairs, and the ordered boundary. Fixed edges are+  -- never crossed: the ones the cavity meets become boundary and are tested+  -- against the candidate's diametral disk. Every encroached fixed edge met+  -- is queued for splitting and the source face is revisited afterwards; a+  -- clean cavity is committed directly.+  exploreThenCommit :: Workspace s -> Int -> Point -> MutableLocation -> ST s (Either BuildError Int)+  exploreThenCommit workspace@Workspace{wsQueue, wsForcedSplits} face point site = do+    (visible, encroached) <- exploreCavity workspace point site+    case find isInterfacePair encroached of+      Just pair+        | all isInterfacePair encroached -> pure (Right 0)+        | otherwise -> Left <$> interfaceCrossing workspace pair+      Nothing+        | null encroached -> commitCavity workspace point site visible+        | otherwise ->+            do+              pushable <- filterM splittablePair encroached+              traverse_ (\pair -> pushGrowable wsForcedSplits (packIndex pair)) pushable+              unless (null pushable) $ pushFace wsQueue face+              pure (Right 0)++  splittablePair :: Int -> ST s Bool+  splittablePair pair = do+    hull <- case domain of+      Nothing -> pure False+      Just _ -> isHullPair pair+    if hull || isInterfacePair pair+      then pure False+      else if refineKeepConstraintEdges parameters+        then not <$> readConstraint mutable (2 * pair)+        else pure True++  admitStar :: Workspace s -> Int -> ST s ()+  admitStar Workspace{wsPermitted} vertex =+    case wsPermitted of+      Just membership ->+        forEachStarFace vertex $ \face -> rememberPermittedFace membership face+      Nothing -> pure ()++  rememberPermittedFace :: BoolMarks s -> Int -> ST s ()+  rememberPermittedFace membership face =+    if face <= 0+      then pure ()+      else do+        already <- readBoolMark membership face+        unless already $ do+          writeBoolMark membership face True++  retirePermittedFace :: Workspace s -> Int -> ST s ()+  retirePermittedFace Workspace{wsPermitted} face = do+    when (face >= 0) $ do+      traverse_+        (\membership -> writeBoolMark membership face False)+        wsPermitted++  retirePermittedFaces :: Workspace s -> GrowableWord32 s -> ST s ()+  retirePermittedFaces workspace faces = do+    count <- growableLength faces+    traverse_+      (\index -> do+         face <- unpackIndex <$> readGrowable faces index+         retirePermittedFace workspace face+      )+      [0 .. count - 1]++  captureCavityFaces :: GrowableWord32 s -> ST s [(Int, Maybe [Point])]+  captureCavityFaces faces = do+    count <- growableLength faces+    traverse+      (\index -> do+         face <- unpackIndex <$> readGrowable faces index+         signature <- mutableFaceSignature face+         pure (face, signature)+      )+      [0 .. count - 1]++  reconcileCavityFaces :: Workspace s -> [(Int, Maybe [Point])] -> ST s ()+  reconcileCavityFaces workspace signatures =+    traverse_+      (\(face, before) -> do+         after <- mutableFaceSignature face+         when (after /= before) (retirePermittedFace workspace face)+      )+      signatures++  mutableFaceSignature :: Int -> ST s (Maybe [Point])+  mutableFaceSignature face = do+    faces <- faceCount mutable+    if face <= 0 || face >= faces+      then pure Nothing+      else do+        (e0, e1, e2) <- faceEdges mutable face+        points <- traverse (edgeOriginPoint mutable) [e0, e1, e2]+        pure (Just (List.sort points))++  captureIncidentFaceSignatures :: [Int] -> ST s [(Int, Maybe [Point])]+  captureIncidentFaceSignatures vertices = do+    faces <- newSTRef IntSet.empty+    traverse_+      (\vertex -> forEachStarFace vertex (modifySTRef' faces . IntSet.insert))+      vertices+    captured <- IntSet.toAscList <$> readSTRef faces+    traverse+      (\face -> do+         signature <- mutableFaceSignature face+         pure (face, signature)+      )+      captured++  -- The flood never mutates, so a popped edge can be retested idempotently:+  -- an edge whose far face conflicts crosses, marks the face, and pushes that+  -- face's other two edges; each directed edge has at most its two+  -- face-neighbours as pushers, and a revisited crossing is deduplicated by+  -- the face and pair stamps. Boundary visibility for the fan is accumulated+  -- in place: every boundary edge is asked here, where its endpoints are+  -- already loaded, whether the point sees it from the cavity side.+  exploreCavity :: Workspace s -> Point -> MutableLocation -> ST s (Bool, [Int])+  exploreCavity workspace@Workspace{wsVisited, wsCavityFaceMarks, wsCavityPairMarks, wsCavityFaces, wsCavityInternal, wsCavityBoundary, wsCavityCocircular, wsCavityWork} point site = do+    next <- nextCavityEpoch workspace+    clearGrowable wsCavityFaces+    clearGrowable wsCavityInternal+    clearGrowable wsCavityBoundary+    clearGrowable wsCavityCocircular+    clearGrowable wsCavityWork+    seedVisible <- case site of+      MutableInFace under -> do+        markFace next under+        (e0, e1, e2) <- faceEdges mutable under+        pushCavityWork e0+        pushCavityWork e1+        pushCavityWork e2+        pure True+      MutableOnEdge edge -> do+        seedAcross next edge+        seedAcross next (reverseIndex edge)+        -- The located edge is never encroachment-tested: a point on it lies+        -- trivially inside its own diametral circle, and the question would+        -- force the same split forever. A fixed edge is boundary; any other+        -- is the cavity's first internal pair. Its visibility still counts.+        fixed <- isFixedEdge edge+        if fixed+          then do+            pushGrowable wsCavityBoundary (packIndex edge)+            from <- edgeOriginPoint mutable edge+            to <- edgeOriginPoint mutable (reverseIndex edge)+            pure (orient2d from to point == GT)+          else do+            recordInternal next (edge `quot` 2)+            pure True+      _ -> pure True+    drain next [] seedVisible+   where+    markFace :: Word32 -> Int -> ST s ()+    markFace epoch face = do+      writeEpochMark wsCavityFaceMarks face epoch+      traverse_ (\visited -> writeBoolMark visited face True) wsVisited+      pushGrowable wsCavityFaces (packIndex face)++    isMarked :: Word32 -> Int -> ST s Bool+    isMarked epoch face = (== epoch) <$> readEpochMark wsCavityFaceMarks face++    recordInternal :: Word32 -> Int -> ST s ()+    recordInternal epoch pair = do+      seen <- readEpochMark wsCavityPairMarks pair+      when (seen /= epoch) $ do+        writeEpochMark wsCavityPairMarks pair epoch+        pushGrowable wsCavityInternal (packIndex pair)++    -- The flood's stack traffic is transaction-local and owns no diagnostics;+    -- the charged wrapper would report every push as legalization depth.+    pushCavityWork :: Int -> ST s ()+    pushCavityWork value = pushGrowable wsCavityWork (packIndex value)++    seedAcross :: Word32 -> Int -> ST s ()+    seedAcross epoch directed = do+      adjacent <- readFace mutable directed+      when (adjacent /= 0) $ do+        markFace epoch adjacent+        next <- readNext mutable directed+        previous <- readPrevious mutable directed+        pushCavityWork next+        pushCavityWork previous++    -- Visibility is read by the caller only when nothing was encroached, so+    -- the first encroached edge retires the question: every later boundary+    -- edge skips the orientation that would only be conjoined into a value+    -- about to be discarded.+    drain :: Word32 -> [Int] -> Bool -> ST s (Bool, [Int])+    drain epoch = go+     where+      go !acc !visible = do+        packed <- popGrowableOr noIndex wsCavityWork+        if packed == noIndex+          then pure (visible, acc)+          else do+            let !directed = fromIntegral packed+            fixed <- isFixedEdge directed+            if fixed+              then do+                pushGrowable wsCavityBoundary (packIndex directed)+                from <- edgeOriginPoint mutable directed+                to <- edgeOriginPoint mutable (reverseIndex directed)+                let pair = directed `quot` 2+                hull <- case domain of+                  Nothing -> pure False+                  Just _ -> isHullPair pair+                let encroached =+                      if isInterfacePair pair || hull+                        then strictlyInDiametralCircle from to point+                        else inDiametralCircle from to point+                when (isInterfacePair pair) $+                  modifySTRef' (wsInterfaceBoundaryReads workspace) (+ 1)+                if encroached+                  then go (pair : acc) False+                  else go acc (visible && orient2d from to point == GT)+              else do+                across <- readFace mutable (reverseIndex directed)+                marked <- isMarked epoch across+                if marked+                  then do+                    recordInternal epoch (directed `quot` 2)+                    go acc visible+                  else do+                    let !twin = reverseIndex directed+                    acrossPrevious <- readPrevious mutable twin+                    opposite <- readOrigin mutable acrossPrevious+                    from <- edgeOriginPoint mutable directed+                    to <- pointAt mutable =<< readOrigin mutable twin+                    acrossPoint <- pointAt mutable opposite+                    let !verdict = inCircle to from acrossPoint point+                    if verdict == GT+                      then do+                        markFace epoch across+                        recordInternal epoch (directed `quot` 2)+                        acrossNext <- readNext mutable twin+                        pushCavityWork acrossNext+                        pushCavityWork acrossPrevious+                        go acc visible+                      else do+                        pushGrowable wsCavityBoundary (packIndex directed)+                        when (verdict == EQ) $+                          pushGrowable wsCavityCocircular (packIndex directed)+                        go acc (visible && orient2d from to point == GT)++  strictlyInDiametralCircle :: Point -> Point -> Point -> Bool+  strictlyInDiametralCircle (Point ax ay) (Point bx by) (Point px py) =+    exactDiametralDot ax ay bx by px py < 0++  -- The flood never mutates, so a popped edge can be retested idempotently:+  -- an edge whose far face conflicts pushes that face's other two edges, and+  -- each directed edge has at most its two face-neighbours as pushers.+  drainSimulation :: GrowableWord32 s -> Point -> [Int] -> ST s [Int]+  drainSimulation work point = go+   where+    go :: [Int] -> ST s [Int]+    go !acc = do+      packed <- popGrowableOr noIndex work+      if packed == noIndex+        then pure acc+        else do+          let !directed = fromIntegral packed+          fixed <- isFixedEdge directed+          if fixed+            then do+              from <- edgeOriginPoint mutable directed+              to <- edgeOriginPoint mutable (reverseIndex directed)+              if inDiametralCircle from to point+                then go (directed `quot` 2 : acc)+                else go acc+            else do+              let !twin = reverseIndex directed+              acrossPrevious <- readPrevious mutable twin+              opposite <- readOrigin mutable acrossPrevious+              from <- edgeOriginPoint mutable directed+              to <- pointAt mutable =<< readOrigin mutable twin+              across <- pointAt mutable opposite+              if inCircle to from across point == GT+                then do+                  acrossNext <- readNext mutable twin+                  pushChargedWork work acrossNext+                  pushChargedWork work acrossPrevious+                  go acc+                else go acc++  -- A cavity the fan commit cannot take: a degenerate or barrier-bent+  -- boundary, a pinched boundary walk, or a duplicate site. The located site+  -- commits through the ordinary split-and-legalize path instead; the+  -- recorded cavity is simply abandoned.+  commitFlipCandidate :: Workspace s -> Point -> MutableLocation -> ST s (Either BuildError Int)+  commitFlipCandidate workspace@Workspace{wsQueue, wsExcluded, wsCavityFaces} point site = do+    let !canonical = canonicalPoint point+    cavitySignatures <- captureCavityFaces wsCavityFaces+    vertex <- appendVertex mutable canonical (makeVertex canonical)+    splitSides <- case site of+      MutableOnEdge edge+        | refineExcludeOuterFaces parameters -> do+            own <- readFace mutable edge+            let !inner = if own == 0 then reverseIndex edge else edge+            leftFace <- readFace mutable inner+            rightFace <- readFace mutable (reverseIndex inner)+            leftExcluded <- readBoolMark wsExcluded leftFace+            rightExcluded <- sideExcluded wsExcluded (reverseIndex inner)+            faceBase <- faceCount mutable+            pure (Just (leftFace, leftExcluded, rightFace, rightExcluded, faceBase))+      _ -> pure Nothing+    inserted <- insertExistingVertexAtLocation @'ProbeOff mutable operation vertex site+    case inserted of+      Left failure -> pure (Left failure)+      Right () -> do+        addCounter operation CounterSteinerPoints 1+        reconcileCavityFaces workspace cavitySignatures+        admitStar workspace vertex+        case splitSides of+          Just (leftFace, leftExcluded, rightFace, rightExcluded, faceBase) ->+            inheritSplitExclusion wsExcluded leftFace leftExcluded rightFace rightExcluded faceBase+          Nothing -> pure ()+        forEachStarFace vertex $ \starFace -> do+          skip <- readBoolMark wsExcluded starFace+          unless skip $ pushFace wsQueue starFace+        pure (Right 1)++  -- Commit a clean cavity by fanning its boundary to the new vertex. The+  -- recorded cavity faces and internal pairs are recycled into fan faces and+  -- spokes; exactly two faces and three edge pairs are appended, whatever the+  -- cavity's size. Any boundary that is not a simple, strictly-visible cycle+  -- falls back to the split-and-legalize commit: that is the degenerate and+  -- the barrier-bent case, never an error.+  commitCavity :: Workspace s -> Point -> MutableLocation -> Bool -> ST s (Either BuildError Int)+  commitCavity workspace@Workspace{wsCavityFaces, wsCavityInternal, wsCavityBoundary} point site visible = do+    boundaryCount <- growableLength wsCavityBoundary+    cavityFaceCount <- growableLength wsCavityFaces+    internalCount <- growableLength wsCavityInternal+    chained <-+      if visible && boundaryCount == cavityFaceCount + 2 && boundaryCount == internalCount + 3+        then chainBoundary workspace boundaryCount+        else pure False+    if chained+      then fanCommit workspace point boundaryCount cavityFaceCount internalCount+      else commitFlipCandidate workspace point site++  -- Order the recorded boundary edges into the cycle they form, starting each+  -- successor by rotating around the current edge's destination. The records+  -- agree with a simple cycle only when the walk closes after exactly the+  -- recorded count and meets no boundary vertex twice; anything else is the+  -- pinched case the fan cannot take.+  chainBoundary :: Workspace s -> Int -> ST s Bool+  chainBoundary Workspace{wsCavityEpoch, wsCavityFaceMarks, wsCavityVertexMarks, wsCavityBoundary, wsCavityChain} count = do+    epoch <- readSTRef wsCavityEpoch+    walkBudget <- directedEdgeCount mutable+    start <- unpackIndex <$> readGrowable wsCavityBoundary 0+    clearGrowable wsCavityChain+    pushGrowable wsCavityChain (packIndex start)+    walk epoch (walkBudget + 2) start start (count - 1)+   where+    walk :: Word32 -> Int -> Int -> Int -> Int -> ST s Bool+    walk epoch walkBudget start current remaining = do+      destination <- readOrigin mutable (reverseIndex current)+      seen <- readEpochMark wsCavityVertexMarks destination+      if seen == epoch+        then pure False+        else do+          writeEpochMark wsCavityVertexMarks destination epoch+          successor <- nextBoundaryEdge epoch walkBudget current+          if remaining == 0+            then pure (successor == start)+            else+              if successor == start+                then pure False+                else do+                  pushGrowable wsCavityChain (packIndex successor)+                  walk epoch walkBudget start successor (remaining - 1)++    nextBoundaryEdge :: Word32 -> Int -> Int -> ST s Int+    nextBoundaryEdge epoch walkBudget edge = do+      first <- readNext mutable edge+      rotate first walkBudget+     where+      rotate :: Int -> Int -> ST s Int+      rotate candidate !remaining+        | remaining <= 0 = pure candidate+        | otherwise = do+            adjacent <- readFace mutable candidate+            markedHere <- (== epoch) <$> readEpochMark wsCavityFaceMarks adjacent+            across <- readFace mutable (reverseIndex candidate)+            markedAcross <- (== epoch) <$> readEpochMark wsCavityFaceMarks across+            if markedHere && not markedAcross+              then pure candidate+              else do+                following <- readNext mutable (reverseIndex candidate)+                rotate following (remaining - 1)++  fanCommit :: Workspace s -> Point -> Int -> Int -> Int -> ST s (Either BuildError Int)+  fanCommit workspace@Workspace{wsQueue, wsExcluded, wsCavityFaces, wsCavityInternal, wsCavityCocircular, wsCavityChain} point boundaryCount cavityFaceCount internalCount = do+    capacity <- ensureCellCapacity mutable (boundaryCount - internalCount) (boundaryCount - cavityFaceCount)+    case capacity of+      Left obstruction -> pure (Left obstruction)+      Right () -> fanCommitWithCapacity+   where+    fanCommitWithCapacity :: ST s (Either BuildError Int)+    fanCommitWithCapacity = do+      let !canonical = canonicalPoint point+      retirePermittedFaces workspace wsCavityFaces+      vertex <- appendVertex mutable canonical (makeVertex canonical)+      faceBase <- addFaceBlock mutable (boundaryCount - cavityFaceCount)+      edgeBase <- addEdgeBlock mutable (boundaryCount - internalCount)+      firstPair <- fanPair edgeBase 0+      let spoke :: Int -> Int -> ST s ()+          spoke !index !pair+            | index >= boundaryCount = pure ()+            | otherwise = do+                boundaryEdge <- unpackIndex <$> readGrowable wsCavityChain index+                face <- fanFace faceBase index+                nextPair <-+                  if index + 1 >= boundaryCount+                    then pure firstPair+                    else fanPair edgeBase (index + 1)+                origin <- readOrigin mutable boundaryEdge+                writeOrigin mutable (2 * pair) origin+                writeOrigin mutable (2 * pair + 1) vertex+                setCycle3 mutable face boundaryEdge (2 * nextPair) (2 * pair + 1)+                writeVertexOut mutable origin boundaryEdge+                -- 'fanFace' and 'fanPair' hand back the cavity's own faces and+                -- interior edges before they hand out new ones. A recycled slot+                -- is given a spoke to the Steiner vertex and a triangle that did+                -- not exist, so whatever the cavity element it displaced was+                -- labelled with does not survive.+                resetEdgeData mutable pair+                resetFaceData mutable face+                spoke (index + 1) nextPair+      spoke 0 firstPair+      markConnected mutable vertex (2 * firstPair + 1)+      addCounter operation CounterSteinerPoints 1+      admitStar workspace vertex+      -- Exactly-cocircular boundary quads are legal ties for the flip+      -- commit but not for a static boundary. Only those edges are drained:+      -- the flood already decided every other boundary edge's quad, so a+      -- full shouldFlip pass would ask again what it already answered.+      cocircular <- growableLength wsCavityCocircular+      when (cocircular > 0) $ do+        ties <- traverse (\index -> unpackIndex <$> readGrowable wsCavityCocircular index) [0 .. cocircular - 1]+        legalizeEdges mutable operation ties+      admitStar workspace vertex+      let offer :: Int -> ST s ()+          offer !index+            | index >= boundaryCount = pure ()+            | otherwise = do+                face <- fanFace faceBase index+                skip <- readBoolMark wsExcluded face+                unless skip $ pushFace wsQueue face+                offer (index + 1)+      offer 0+      pure (Right 1)++    fanFace :: Int -> Int -> ST s Int+    fanFace faceBase index+      | index < cavityFaceCount = unpackIndex <$> readGrowable wsCavityFaces index+      | otherwise = pure (faceBase + (index - cavityFaceCount))++    fanPair :: Int -> Int -> ST s Int+    fanPair edgeBase index+      | index < internalCount = unpackIndex <$> readGrowable wsCavityInternal index+      | otherwise = pure ((edgeBase + 2 * (index - internalCount)) `quot` 2)++  -- A candidate outside the hull (only reachable when the hull is not+  -- preserved) preflights against the whole visible hull chain: the+  -- prospective cavity reaches the hull, so the chain edges are exactly the+  -- fixed edges the insertion would meet.+  attemptOutside :: Workspace s -> Int -> Point -> Int -> ST s (Either BuildError Int)+  attemptOutside workspace@Workspace{wsQueue, wsExcluded, wsForcedSplits, wsCavityWork} face point edge = do+    chain <- visibleChain edge point+    clearGrowable wsCavityWork+    forM_ chain $ \hull -> do+      pushChargedWork wsCavityWork hull+      let !inner = reverseIndex hull+      innerFace <- readFace mutable inner+      when (innerFace /= 0) $ do+        next <- readNext mutable inner+        previous <- readPrevious mutable inner+        pushChargedWork wsCavityWork next+        pushChargedWork wsCavityWork previous+    encroached <- drainSimulation wsCavityWork point []+    if not (null encroached)+      then do+        pushable <- filterM splittablePair encroached+        forM_ pushable $ \pair -> pushGrowable wsForcedSplits (packIndex pair)+        unless (null pushable) $ pushFace wsQueue face+        pure (Right 0)+      else do+        let !canonical = canonicalPoint point+        vertex <- appendVertex mutable canonical (makeVertex canonical)+        inserted <- insertExistingVertexAtLocation @'ProbeOff mutable operation vertex (MutableOutsideHull edge)+        case inserted of+          Left failure -> pure (Left failure)+          Right () -> do+            addCounter operation CounterSteinerPoints 1+            admitStar workspace vertex+            when (refineExcludeOuterFaces parameters) $ do+              seedCount <- newSTRef 0+              forEachStarFace vertex $ \starFace -> do+                writeBoolMark wsExcluded starFace True+                count <- readSTRef seedCount+                writeScratch operation count starFace+                writeSTRef seedCount (count + 1)+              count <- readSTRef seedCount+              propagateExcluded wsExcluded count+            forEachStarFace vertex $ \starFace -> do+              skip <- readBoolMark wsExcluded starFace+              unless skip $ pushFace wsQueue starFace+            forEachStarFace vertex $ \starFace -> do+              (e0, e1, e2) <- faceEdges mutable starFace+              traverse_ (offerFixedEdge workspace) [e0, e1, e2]+            pure (Right 1)++  -- The maximal run of outer-cycle edges visible from the candidate, centred+  -- on the edge location reported. Bounded by the hull length.+  visibleChain :: Int -> Point -> ST s [Int]+  visibleChain edge point = do+    halfEdges <- directedEdgeCount mutable+    left <- expand (readPrevious mutable) (halfEdges + 1) edge+    right <- expand (readNext mutable) (halfEdges + 1) edge+    walk left right (halfEdges + 1) []+   where+    expand :: (Int -> ST s Int) -> Int -> Int -> ST s Int+    expand step !walkBudget !current+      | walkBudget <= 0 = pure current+      | otherwise = do+          candidate <- step current+          if candidate == edge+            then pure current+            else do+              from <- edgeOriginPoint mutable candidate+              to <- edgeOriginPoint mutable (reverseIndex candidate)+              if orient2d from to point == GT+                then expand step (walkBudget - 1) candidate+                else pure current++    walk :: Int -> Int -> Int -> [Int] -> ST s [Int]+    walk !current !end !walkBudget !acc+      | walkBudget <= 0 = pure acc+      | current == end = pure (current : acc)+      | otherwise = do+          following <- readNext mutable current+          walk following end (walkBudget - 1) (current : acc)++  -- New faces outside the hull sit at barrier depth zero; whatever they now+  -- reach without crossing a constraint joined the outer region with them.+  propagateExcluded :: BoolMarks s -> Int -> ST s ()+  propagateExcluded excluded = drain+   where+    drain :: Int -> ST s ()+    drain !count+      | count <= 0 = pure ()+      | otherwise = do+          face <- readScratch operation (count - 1)+          (e0, e1, e2) <- faceEdges mutable face+          next <- spread (count - 1) e0 >>= (`spread` e1) >>= (`spread` e2)+          drain next++    spread :: Int -> Int -> ST s Int+    spread !count !directed = do+      protected <- readConstraint mutable directed+      if protected+        then pure count+        else do+          adjacent <- readFace mutable (reverseIndex directed)+          if adjacent == 0+            then pure count+            else do+              already <- readBoolMark excluded adjacent+              if already+                then pure count+                else do+                  writeBoolMark excluded adjacent True+                  writeScratch operation count adjacent+                  pure (count + 1)++  -- A queued fixed edge against the vertices currently opposite it, from each+  -- non-excluded side. A stale candidate simply answers for the subsegment+  -- its handle now names, which is the edge the queue cares about.+  checkEncroachment :: Workspace s -> Int -> ST s (Either BuildError Bool)+  checkEncroachment workspace@Workspace{wsExcluded} pair = do+    let !directed = 2 * pair+    first <- sideEncroaches wsExcluded directed+    encroached <-+      if first+        then pure True+        else sideEncroaches wsExcluded (reverseIndex directed)+    if encroached+      then+        if isInterfacePair pair+          then Left <$> interfaceCrossing workspace pair+          else resolveSplit SplitFixedSegment workspace pair+      else pure (Right False)+   where+    sideEncroaches :: BoolMarks s -> Int -> ST s Bool+    sideEncroaches excluded side = do+      adjacent <- readFace mutable side+      if adjacent == 0+        then pure False+        else do+          skip <- readBoolMark excluded adjacent+          if skip+            then pure False+            else do+              opposite <- readOrigin mutable =<< readPrevious mutable side+              query <- pointAt mutable opposite+              from <- edgeOriginPoint mutable side+              to <- edgeOriginPoint mutable (reverseIndex side)+              hull <- case domain of+                Nothing -> pure False+                Just _ -> isHullPair pair+              pure+                ( if isInterfacePair pair || hull+                    then strictlyInDiametralCircle from to query+                    else inDiametralCircle from to query+                )++  -- Split a fixed edge. A first split lands at the midpoint; a subsegment+  -- split rounds its offset to the nearest power of two toward the original+  -- endpoint, so segments meeting at a small input angle stop encroaching+  -- each other instead of subdividing forever.+  resolveSplit :: EdgeSplitLaw -> Workspace s -> Int -> ST s (Either BuildError Bool)+  resolveSplit splitLaw workspace@Workspace{wsExcluded, wsSegmentOrigin} pair = do+    let !directed = 2 * pair+    protected <- readConstraint mutable directed+    hull <- case domain of+      Nothing -> pure False+      Just _ -> isHullPair pair+    if hull+      then pure (Right False)+      else if isInterfacePair pair+      then Left <$> interfaceCrossing workspace pair+      else if refineKeepConstraintEdges parameters && protected+      then pure (Right False)+      else do+        v0 <- readOrigin mutable directed+        v1 <- readOrigin mutable (reverseIndex directed)+        from <- pointAt mutable v0+        to <- pointAt mutable v1+        segmentLineage <-+          case splitLaw of+            SplitQualityEdge -> pure Nothing+            SplitFixedSegment -> do+              (lineage0, second0) <- readSegmentOrigin wsSegmentOrigin v0+              (lineage1, second1) <- readSegmentOrigin wsSegmentOrigin v1+              pure (Just (lineage0, second0, lineage1, second1))+        let (!onSegment0, !onSegment1) =+              case segmentLineage of+                Nothing -> (False, False)+                Just (lineage0, _, lineage1, _) ->+                  (lineage0 /= noIndex, lineage1 /= noIndex)+            !splitPoint = splitPosition onSegment0 onSegment1 from to+        incidentSignatures <- captureIncidentFaceSignatures [v0, v1]+        valid <- validateSplitPosition directed splitPoint+        if not valid+          then pure (Right False)+          else do+            -- Inheritance is read as structural face identities, never as+            -- post-split handle membership: the split's own legalization can+            -- flip seeded edges and relocate handles before any read, but it+            -- cannot rename a face. The kept side faces and the append base+            -- name the sides exactly.+            own <- readFace mutable directed+            let !inner = if own == 0 then reverseIndex directed else directed+            leftFace <- readFace mutable inner+            rightFace <- readFace mutable (reverseIndex inner)+            leftExcluded <- readBoolMark wsExcluded leftFace+            rightExcluded <- sideExcluded wsExcluded (reverseIndex inner)+            faceBase <- faceCount mutable+            let !canonical = canonicalPoint splitPoint+            retirePermittedFace workspace leftFace+            retirePermittedFace workspace rightFace+            vertex <- appendVertex mutable canonical (makeVertex canonical)+            inserted <- insertOnEdge @'ProbeOff mutable operation directed vertex+            case inserted of+              Left obstruction -> pure (Left obstruction)+              Right () -> do+                reconcileCavityFaces workspace incidentSignatures+                admitStar workspace vertex+                case segmentLineage of+                  Nothing -> pure ()+                  Just (lineage0, second0, lineage1, second1) ->+                    if onSegment0+                      then writeSegmentOrigin wsSegmentOrigin vertex lineage0 second0+                      else+                        if onSegment1+                          then writeSegmentOrigin wsSegmentOrigin vertex lineage1 second1+                          else writeSegmentOrigin wsSegmentOrigin vertex (packIndex v0) (packIndex v1)+                when (refineExcludeOuterFaces parameters) $+                  inheritSplitExclusion wsExcluded leftFace leftExcluded rightFace rightExcluded faceBase+                addCounter operation CounterSteinerPoints 1+                pushStarAfterSplit workspace vertex+                pure (Right True)++  splitPosition :: Bool -> Bool -> Point -> Point -> Point+  splitPosition onSegment0 onSegment1 from to+    | not onSegment0 && not onSegment1 = midpoint from to+    | otherwise =+        let !halfLength = sqrt (squaredDistance from to) * 0.5+         in if not (isFinite halfLength) || halfLength <= 0+              then midpoint from to+              else+                let !nearest = 2 ** fromIntegral (round (logBase 2 halfLength) :: Int)+                    !otherWeight = 0.5 * nearest / halfLength+                    !originalWeight = 1 - otherWeight+                    (!weight0, !weight1) =+                      if onSegment0+                        then (otherWeight, originalWeight)+                        else (originalWeight, otherWeight)+                    Point fromX fromY = from+                    Point toX toY = to+                 in Point (fromX * weight0 + toX * weight1) (fromY * weight0 + toY * weight1)++  -- The split is refused when the constructed vertex would leave one of the+  -- four new faces degenerate or clockwise — for an in-segment point that is+  -- exactly the coincidence-with-an-endpoint-or-opposite case.+  validateSplitPosition :: Int -> Point -> ST s Bool+  validateSplitPosition directed splitPoint@(Point splitX splitY)+    | validateCoordinate splitX /= Nothing = pure False+    | validateCoordinate splitY /= Nothing = pure False+    | otherwise = do+        from <- edgeOriginPoint mutable directed+        to <- edgeOriginPoint mutable (reverseIndex directed)+        first <- sideKeepsOrientation directed from to+        if not first+          then pure False+          else sideKeepsOrientation (reverseIndex directed) to from+   where+    sideKeepsOrientation :: Int -> Point -> Point -> ST s Bool+    sideKeepsOrientation side sideFrom sideTo = do+      adjacent <- readFace mutable side+      if adjacent == 0+        then pure True+        else do+          opposite <- readOrigin mutable =<< readPrevious mutable side+          oppositePoint <- pointAt mutable opposite+          pure+            ( orient2d sideFrom oppositePoint splitPoint == LT+                && orient2d oppositePoint sideTo splitPoint == LT+            )++  sideExcluded :: BoolMarks s -> Int -> ST s Bool+  sideExcluded excluded side = do+    adjacent <- readFace mutable side+    if adjacent == 0 then pure True else readBoolMark excluded adjacent++  -- A split keeps each side's classification. The faces a side holds+  -- afterwards are the side face it kept and the face appended over it:+  -- interior splits append two, boundary splits one, and both ids are+  -- immune to the legalization that runs between the geometry and here.+  inheritSplitExclusion :: BoolMarks s -> Int -> Bool -> Int -> Bool -> Int -> ST s ()+  inheritSplitExclusion excluded leftFace leftExcluded rightFace rightExcluded faceBase = do+    writeSide leftExcluded leftFace+    writeSide leftExcluded faceBase+    when (rightFace /= 0) $ do+      writeSide rightExcluded rightFace+      writeSide rightExcluded (faceBase + 1)+   where+    writeSide :: Bool -> Int -> ST s ()+    writeSide status side = do+      when (side /= 0) $ writeBoolMark excluded side status++  pushStarAfterSplit :: Workspace s -> Int -> ST s ()+  pushStarAfterSplit workspace@Workspace{wsQueue} vertex =+    forEachStarFace vertex $ \starFace -> do+      pushFace wsQueue starFace+      (e0, e1, e2) <- faceEdges mutable starFace+      traverse_ (offerFixedEdge workspace) [e0, e1, e2]++  -- Every interior face incident to a vertex, once. One rotation direction+  -- covers a full interior star; a hull star additionally needs the other+  -- direction from the starting edge.+  forEachStarFace :: Int -> (Int -> ST s ()) -> ST s ()+  forEachStarFace vertex visit = do+    start <- readVertexOut mutable vertex+    when (start >= 0) $ do+      wrapped <- rotate start start+      unless wrapped (rotateBack start)+   where+    rotate :: Int -> Int -> ST s Bool+    rotate !start !edge = do+      adjacent <- readFace mutable edge+      if adjacent == 0+        then pure False+        else do+          visit adjacent+          next <- reverseIndex <$> readPrevious mutable edge+          if next == start then pure True else rotate start next++    rotateBack :: Int -> ST s ()+    rotateBack edge = do+      let !twin = reverseIndex edge+      adjacent <- readFace mutable twin+      when (adjacent /= 0) $ do+        visit adjacent+        next <- readNext mutable twin+        rotateBack next++-- | Whether a measurement is over its bound. A non-positive bound admits+-- nothing, which is what dividing by it used to say by returning an infinity+-- that then compared greater than one.+exceeds :: Double -> Double -> Bool+exceeds value bound = bound <= 0 || value > bound+{-# INLINE exceeds #-}++-- | The bound the squared radius-edge ratio is compared against. Squaring is+-- monotone on the non-negative reals, so this asks the same question of the+-- squares that the unsquared bound asked of the lengths.+squareBound :: Double -> Double+squareBound bound+  | bound <= 0 = bound+  | otherwise = bound * bound+{-# INLINE squareBound #-}
+ src-build/Moonlight/Triangulation/Internal/Session.hs view
@@ -0,0 +1,416 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | One owned editing transaction over a triangulation: thaw once, edit, publish once.+module Moonlight.Triangulation.Internal.Session+  ( RemovalOutcome (..)+  , Session+  , withSession+  , withLocalSession+  , insertVertex+  , insertVertexAt+  , insertVertexAtNear+  , insertVertexAtNearVertex+  , insertAdmittedVertexAtCombining+  , removeAt+  , removeAtNear+  , removeManyAt+  , removeManyAtNear+  , excise+  , refuse+  ) where++import Control.DeepSeq (NFData)+import Control.Monad.ST (ST)+import Data.Bits (xor)+import qualified Data.Vector as V+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Insertion+  ( insertAdmittedPointCombining+  , insertPointCombining+  )+import Moonlight.Triangulation.Internal.Excision (removeMutable)+import Moonlight.Triangulation.Internal.Location (MutableLocation (..), locateMutable)+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.OperationState (OperationState)+import Moonlight.Triangulation.Internal.Paged (TransactionShape (..))+import Moonlight.Triangulation.Math (canonicalPoint)+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Transaction (runTransaction)+import Moonlight.Triangulation.Internal.Types+import GHC.Generics (Generic)++-- | What a single removal produced: the removed position and payload, plus the+-- slot and position changed by swap compaction when another vertex moved.+data RemovalOutcome vertex = RemovalOutcome+  { removalOutcomePoint :: !(Point)+  , removalOutcomeData :: !vertex+  , removalOutcomeSwap :: !(Maybe (VertexId, Point))+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | An edit sequence against one thawed mesh.+--+-- The two published entry points before this one — an insertion session and a+-- removal session — each handed the caller a function and could not compose,+-- so a caller who wanted to remove a hundred vertices and insert fifty thawed+-- twice and paid the O(n) publication a session exists to delete. They are the+-- same transaction; only the verb differed. This is that transaction, and the+-- verbs are its primitives.+--+-- The public session algebra and the private exact-site single-insertion+-- interpreter cross the same hidden transaction boundary. Sessions provide+-- composition; the private interpreter reaches that boundary only with+-- evidence from the immediately preceding frozen read. A fold of persistent+-- verbs and a session over the same verbs therefore differ only in which+-- intermediate meshes they publish.+--+-- Refusal short-circuits: the first 'BuildError' abandons the rest of the+-- sequence, and 'withSession' freezes nothing. A partly edited arena cannot+-- reach a caller as a published triangulation.+newtype Session s vertex directed undirected face a = Session+  { stepSession+      :: MutableDcel s vertex directed undirected face+      -> OperationState s+      -> ST s (Either BuildError a)+  }++instance Functor (Session s vertex directed undirected face) where+  fmap f (Session step) = Session $ \mesh operation -> fmap (fmap f) (step mesh operation)+  {-# INLINE fmap #-}++instance Applicative (Session s vertex directed undirected face) where+  pure a = Session $ \_ _ -> pure (Right a)+  {-# INLINE pure #-}+  Session left <*> Session right = Session $ \mesh operation -> do+    outcome <- left mesh operation+    case outcome of+      Left refusal -> pure (Left refusal)+      Right f -> fmap (fmap f) (right mesh operation)+  {-# INLINE (<*>) #-}++instance Monad (Session s vertex directed undirected face) where+  Session step >>= f = Session $ \mesh operation -> do+    outcome <- step mesh operation+    case outcome of+      Left refusal -> pure (Left refusal)+      Right a -> stepSession (f a) mesh operation+  {-# INLINE (>>=) #-}++-- | Abandon the transaction. Nothing is published.+refuse :: BuildError -> Session s vertex directed undirected face a+refuse failure = Session $ \_ _ -> pure (Left failure)+{-# INLINE refuse #-}++-- | Insert a vertex, answering the handle it was given. A point already+-- present keeps its handle and takes the new payload.+insertVertex+  :: HasPosition vertex+  => vertex+  -> Session s vertex directed undirected face VertexId+insertVertex payload = Session $ \mesh operation ->+  fmap+    (fmap (VertexId . fromIntegral . fst))+    (insertPointCombining (\_ replacement -> replacement) Nothing mesh operation (position payload) payload)++-- | Insert at a stated point, answering the handle and whether a site was+-- created. 'insertVertex' is this with the point read out of the payload; a+-- caller that computed the point — a constraint split, a Steiner refinement —+-- states it rather than round-tripping through 'HasPosition'.+insertVertexAt+  :: Point+  -> vertex+  -> Session s vertex directed undirected face (VertexId, InsertionDisposition)+insertVertexAt = insertVertexAtFrom (const (pure Nothing))++-- | 'insertVertexAt' with the walk seeded at a face the caller vouches for --+-- typically the face a locate on the just-published value settled on, which+-- is exact on the mesh this transaction thawed. The seed is a hint, not an+-- authority: an out-of-range face degrades to the unhinted descent, and the+-- walk corrects.+insertVertexAtNear+  :: FaceId+  -> Point+  -> vertex+  -> Session s vertex directed undirected face (VertexId, InsertionDisposition)+insertVertexAtNear seed =+  insertVertexAtFrom (const (pure (Just (faceIdIndex seed))))++-- | 'insertVertexAt' with the exact walk restricted first to an inner face in+-- the supplied vertex's star. This is the native boundary for hierarchy and+-- nearest-neighbour hints, which answer vertices rather than faces. The seed+-- remains non-authoritative: an invalid handle or a vertex with no incident+-- inner face degrades to the ordinary unhinted descent.+insertVertexAtNearVertex+  :: VertexId+  -> Point+  -> vertex+  -> Session s vertex directed undirected face (VertexId, InsertionDisposition)+insertVertexAtNearVertex seed = insertVertexAtFrom (`interiorFaceNearVertex` seed)++insertVertexAtFrom+  :: (MutableDcel s vertex directed undirected face -> ST s (Maybe Int))+  -> Point+  -> vertex+  -> Session s vertex directed undirected face (VertexId, InsertionDisposition)+insertVertexAtFrom seedFor point payload = Session $ \mesh operation -> do+  seed <- seedFor mesh+  fmap+    (fmap (\(vertex, disposition) -> (VertexId (fromIntegral vertex), disposition)))+    (insertPointCombining+       (\_ replacement -> replacement)+       seed+       mesh+       operation+       point+       payload+    )+{-# INLINE insertVertexAtFrom #-}++-- | Insert an admitted site while combining an occupied annotation. This is+-- package-internal descent from a boundary that already owns coordinate+-- admission; only location and annotation gluing remain here.+insertAdmittedVertexAtCombining+  :: (vertex -> vertex -> vertex)+  -> QueryPoint+  -> vertex+  -> Session s vertex directed undirected face (VertexId, InsertionDisposition)+insertAdmittedVertexAtCombining combine queryPoint payload = Session $ \mesh operation ->+  fmap+    (fmap (\(vertex, disposition) -> (VertexId (fromIntegral vertex), disposition)))+    (insertAdmittedPointCombining combine Nothing mesh operation queryPoint payload)++-- | Remove the vertex standing at a point, answering 'Nothing' when no vertex+-- stands there.+--+-- Keyed by position rather than by handle because removal swap-compacts the+-- arenas: every outstanding t'VertexId' may relocate, and over a sequence of+-- removals a handle-keyed verb would force the caller to thread every+-- relocation by hand. A position is invariant under compaction. The relocation+-- is still reported, in the 'RemovalOutcome', for callers holding handles.+-- The question is an identity question -- which vertex stands at this exact+-- position. A session that has committed to identity work ('removeManyAt',+-- 'excise') answers it through the identity index in O(1); one that has not+-- answers it with a single walk, because a published index is a lazy rebuild+-- and forcing a whole-mesh build to answer one question is the wrong trade.+removeAt+  :: Point+  -> Session s vertex directed undirected face (Maybe (RemovalOutcome vertex))+removeAt point = Session $ \mesh operation -> do+  indexed <- identityIndexActive mesh+  if indexed+    then removeIndexed mesh operation point+    else walkAndRemove mesh operation Nothing point++removeIndexed+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Point+  -> ST s (Either BuildError (Maybe (RemovalOutcome vertex)))+removeIndexed mesh operation point = do+  located <- lookupPointVertex mesh point+  case located of+    Just vertex -> fmap (fmap Just) (removeMutableOutcome mesh operation vertex)+    Nothing -> pure (Right Nothing)++-- | Remove the vertex standing at a point, starting from a caller-supplied+-- near vertex -- a locate hint from an external structure such as the+-- Delaunay hierarchy. The guess is a hint, not an authority: a slot renamed+-- by swap-compaction or out of range degrades to a walk hinted by the+-- guess's incident face, and the walk corrects.+removeAtNear+  :: VertexId+  -> Point+  -> Session s vertex directed undirected face (Maybe (RemovalOutcome vertex))+removeAtNear guessVertex point = Session $ \mesh operation -> do+  indexed <- identityIndexActive mesh+  let !guess = vertexIdIndex guessVertex+      !query = canonicalPoint point+  if indexed+    then removeIndexed mesh operation query+    else do+      vertices <- pointCount mesh+      if guess < 0 || guess >= vertices+        then walkAndRemove mesh operation Nothing query+        else do+          stored <- pointAt mesh guess+          if stored == query+            then fmap (fmap Just) (removeMutableOutcome mesh operation guess)+            else do+              hint <- interiorFaceAtVertex mesh guess+              walkAndRemove mesh operation hint query++interiorFaceNearVertex+  :: MutableDcel s vertex directed undirected face+  -> VertexId+  -> ST s (Maybe Int)+interiorFaceNearVertex mesh vertex@(VertexId rawVertex) = do+  vertices <- pointCount mesh+  if toInteger rawVertex >= toInteger vertices+    then pure Nothing+    else interiorFaceAtVertex mesh (vertexIdIndex vertex)++interiorFaceAtVertex+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> ST s (Maybe Int)+interiorFaceAtVertex mesh vertex = do+  outgoing <- readVertexOut mesh vertex+  if outgoing < 0+    then pure Nothing+    else do+      primary <- innerFaceOf outgoing+      maybe (innerFaceOf (outgoing `xor` 1)) (pure . Just) primary+ where+  innerFaceOf edge = do+    face <- readFace mesh edge+    pure (if face > 0 then Just face else Nothing)++walkAndRemove+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Maybe Int+  -> Point+  -> ST s (Either BuildError (Maybe (RemovalOutcome vertex)))+walkAndRemove mesh operation hint query = do+  located <- locateMutable mesh operation hint query+  case located of+    Left obstruction -> pure (Left obstruction)+    Right (MutableOnVertex vertex) ->+      fmap (fmap Just) (removeMutableOutcome mesh operation vertex)+    Right _ -> pure (Right Nothing)++-- | Remove the vertex standing at each point, answering per point in order.+-- One session-level decision buys the locate strategy: few removals walk the+-- mesh, each a ~O(sqrt n) descent, while many seed the existing mutable+-- open-addressed identity section once from coordinate authority and answer+-- each question by hash. The guard squares the crossover to avoid a root.+removeManyAt+  :: V.Vector (Point)+  -> Session s vertex directed undirected face (V.Vector (Maybe (RemovalOutcome vertex)))+removeManyAt points =+  withBatchIdentityForLoad (V.length points) (V.mapM removeAt points)++-- | Install the mutable identity section only around a dense removal program.+-- It is a local section over the coordinate arenas, not a new published cache:+-- on every result path it is discarded and freeze glues a lazy @PointIndex@+-- back from those arenas. Sparse loads retain the existing locate walk.+withBatchIdentityForLoad+  :: Int+  -> Session s vertex directed undirected face result+  -> Session s vertex directed undirected face result+withBatchIdentityForLoad count (Session action) = Session $ \mesh operation -> do+  vertices <- pointCount mesh+  if count * count > 10 * vertices+    then do+      activated <- activateBatchPointIndex mesh+      case activated of+        Left failure -> pure (Left failure)+        Right () -> do+          outcome <- action mesh operation+          discardBatchPointIndex mesh+          pure outcome+    else action mesh operation++identityCommitted :: Session s vertex directed undirected face Bool+identityCommitted = Session $ \mesh _ -> fmap Right (identityIndexActive mesh)+{-# INLINE identityCommitted #-}++-- | 'removeManyAt' with a near vertex per point where the caller has one — a+-- hierarchy sample, a previous answer. The batch commits to its load first,+-- so the identity-index crossover decides the regime once: a dense batch buys+-- its local mutable table and never examines a guess, a sparse one walks from+-- its guesses.+removeManyAtNear+  :: V.Vector (Maybe VertexId)+  -> V.Vector (Point)+  -> Session s vertex directed undirected face (V.Vector (Maybe (RemovalOutcome vertex)))+removeManyAtNear guesses points =+  withBatchIdentityForLoad (V.length points) $ do+    indexed <- identityCommitted+    if indexed+      then V.mapM removeAt points+      else+        V.zipWithM+          (\guess point -> maybe (removeAt point) (\vertex -> removeAtNear vertex point) guess)+          guesses+          points++-- | Remove a stated vertex. Sound only while the handle still denotes what the+-- caller means: the first removal in a sequence compacts the arenas, so a+-- handle taken before it may name a different vertex after. @removeAt@ is the+-- verb for a sequence; this is the verb for a handle the caller has just been+-- given and has not yet let a removal run underneath.+excise+  :: VertexId+  -> Session s vertex directed undirected face (RemovalOutcome vertex)+excise requested@(VertexId raw) = Session $ \mesh operation -> do+  vertices <- pointCount mesh+  if toInteger raw >= toInteger vertices+    then pure (Left (RemovalVertexOutOfRange requested vertices))+    else do+      activatePointIndex mesh+      removeMutableOutcome mesh operation (vertexIdIndex requested)++removeMutableOutcome+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> ST s (Either BuildError (RemovalOutcome vertex))+removeMutableOutcome mesh operation vertex =+  fmap (fmap removalOutcomeOf) (removeMutable mesh operation vertex)++removalOutcomeOf+  :: (Point, vertex, Maybe (Int, Point))+  -> RemovalOutcome vertex+removalOutcomeOf (point, payload, swapped) =+  RemovalOutcome+    { removalOutcomePoint = point+    , removalOutcomeData = payload+    , removalOutcomeSwap =+        (\(slot, standing) -> (VertexId (fromIntegral slot), standing)) <$> swapped+    }++-- | Run an edit sequence: thaw once, edit, freeze once, and publish the+-- counters the whole transaction charged.+--+-- The reservation is taken for the peak vertex count, so it is the insertion+-- count that sizes it; removals only shrink the mesh and a mixed sequence+-- cannot exceed the peak an insert-only sequence of the same count reaches.+--+-- The session cannot escape its callback: the state token is universally+-- quantified, so the mesh it addresses is dead by the time the frozen+-- triangulation is returned.+withSession+  :: forall mode vertex directed undirected face result+   . Triangulation mode vertex directed undirected face+  -> Int+  -> (forall s. Session s vertex directed undirected face result)+  -> Either BuildError (result, Triangulation mode vertex directed undirected face, BuildStats)+withSession triangulation additional session =+  runTransaction+    id+    DenseTransaction+    triangulation+    additional+    (\mesh operation -> stepSession session mesh operation)++-- | The local-edit transaction: copy-on-write pages, publication proportional+-- to what the edit dirtied. This is the section for singleton persistent+-- verbs, whose one edit cannot amortize a dense copy of the whole mesh.+withLocalSession+  :: forall mode vertex directed undirected face result+   . Triangulation mode vertex directed undirected face+  -> Int+  -> (forall s. Session s vertex directed undirected face result)+  -> Either BuildError (result, Triangulation mode vertex directed undirected face, BuildStats)+withLocalSession triangulation additional session =+  runTransaction+    id+    LocalTransaction+    triangulation+    additional+    (\mesh operation -> stepSession session mesh operation)
+ src-build/Moonlight/Triangulation/Internal/Transaction.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}++-- | The hidden publication boundary shared by persistent build-side edits.+--+-- The rank-two action can observe one mutable section, but neither the section+-- nor any site witness can escape it.  This is deliberately below the public+-- Session surface: a caller may compose public verbs, while an owner that has+-- just derived private evidence can interpret it without making that evidence+-- forgeable.+module Moonlight.Triangulation.Internal.Transaction+  ( runTransaction+  , runTransactionWithPublication+  , runUnmeasuredTransaction+  ) where++import Control.Monad.ST (ST, runST)+import Moonlight.Triangulation.Dcel (numVertices)+import Moonlight.Triangulation.Internal.Capacity (ensureCapacity)+import Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel+  , freezeTriangulation+  , freezeTriangulationWithStats+  , halfEdgeCapacity+  , thawTriangulation+  , thawTriangulationDense+  )+import Moonlight.Triangulation.Internal.OperationState+  ( OperationState+  , freezeBuildStats+  , newOperationState+  )+import Moonlight.Triangulation.Internal.Paged+  ( PublicationStats+  , TransactionShape (..)+  , emptyPublicationStats+  )+import Moonlight.Triangulation.Internal.Representation (Triangulation)+import Moonlight.Triangulation.Internal.Types (BuildError, BuildStats)++-- | Reserve, thaw, interpret, and publish one transaction.+--+-- The physical section is selected by the operation that knows its edit+-- volume.  Refusal short-circuits before freezing, so a partially rewritten+-- mutable mesh cannot escape as a published triangulation.+runTransaction+  :: (BuildError -> failure)+  -> TransactionShape+  -> Triangulation mode vertex directed undirected face+  -> Int+  -> (forall s. MutableDcel s vertex directed undirected face -> OperationState s -> ST s (Either failure result))+  -> Either failure (result, Triangulation mode vertex directed undirected face, BuildStats)+runTransaction = runTransactionWithReceipt freezeBuildStats+{-# INLINE runTransaction #-}++-- | The measured publication boundary.  The storage owner returns its page+-- counters alongside the immutable mesh; callers must not infer locality from+-- a final page count or from a benchmark timer.+runTransactionWithPublication+  :: (BuildError -> failure)+  -> TransactionShape+  -> Triangulation mode vertex directed undirected face+  -> Int+  -> (forall s. MutableDcel s vertex directed undirected face -> OperationState s -> ST s (Either failure result))+  -> Either failure (result, Triangulation mode vertex directed undirected face, BuildStats, PublicationStats)+runTransactionWithPublication = runTransactionWithPublicationReceipt freezeBuildStats+{-# INLINE runTransactionWithPublication #-}++-- | Publish a transaction whose caller observes no instrumentation. Avoiding+-- the statistics fold matters for singleton constraint verbs: their public+-- result has no statistics field, so reading every counter would be dead work.+runUnmeasuredTransaction+  :: (BuildError -> failure)+  -> TransactionShape+  -> Triangulation mode vertex directed undirected face+  -> Int+  -> (forall s. MutableDcel s vertex directed undirected face -> OperationState s -> ST s (Either failure result))+  -> Either failure (result, Triangulation mode vertex directed undirected face)+runUnmeasuredTransaction mapBuildFailure shape triangulation additional action =+  fmap+    (\(result, frozen, ()) -> (result, frozen))+    ( runTransactionWithReceipt+        (const (pure ()))+        mapBuildFailure+        shape+        triangulation+        additional+        action+    )+{-# INLINE runUnmeasuredTransaction #-}++runTransactionWithReceipt+  :: (forall s. OperationState s -> ST s receipt)+  -> (BuildError -> failure)+  -> TransactionShape+  -> Triangulation mode vertex directed undirected face+  -> Int+  -> (forall s. MutableDcel s vertex directed undirected face -> OperationState s -> ST s (Either failure result))+  -> Either failure (result, Triangulation mode vertex directed undirected face, receipt)+runTransactionWithReceipt freezeReceipt mapBuildFailure shape triangulation additional action = do+  fmap+    (\(value, frozen, receipt, _publicationStats) -> (value, frozen, receipt))+    (runTransactionCore freezeWithoutPublicationStats freezeReceipt mapBuildFailure shape triangulation additional action)+{-# INLINE runTransactionWithReceipt #-}++runTransactionWithPublicationReceipt+  :: (forall s. OperationState s -> ST s receipt)+  -> (BuildError -> failure)+  -> TransactionShape+  -> Triangulation mode vertex directed undirected face+  -> Int+  -> (forall s. MutableDcel s vertex directed undirected face -> OperationState s -> ST s (Either failure result))+  -> Either failure (result, Triangulation mode vertex directed undirected face, receipt, PublicationStats)+runTransactionWithPublicationReceipt freezeReceipt mapBuildFailure shape triangulation additional action = do+  runTransactionCore freezeTriangulationWithStats freezeReceipt mapBuildFailure shape triangulation additional action+{-# INLINE runTransactionWithPublicationReceipt #-}++runTransactionCore+  :: (forall s. MutableDcel s vertex directed undirected face -> ST s (Either BuildError (Triangulation mode vertex directed undirected face, PublicationStats)))+  -> (forall s. OperationState s -> ST s receipt)+  -> (BuildError -> failure)+  -> TransactionShape+  -> Triangulation mode vertex directed undirected face+  -> Int+  -> (forall s. MutableDcel s vertex directed undirected face -> OperationState s -> ST s (Either failure result))+  -> Either failure (result, Triangulation mode vertex directed undirected face, receipt, PublicationStats)+runTransactionCore freezePublication freezeReceipt mapBuildFailure shape triangulation additional action = do+  let !currentCapacity = numVertices triangulation+      !requestedAdditional = max 0 additional+      !capacity+        | requestedAdditional > maxBound - currentCapacity = maxBound+        | otherwise = currentCapacity + requestedAdditional+  case ensureCapacity capacity of+    Left failure -> Left (mapBuildFailure failure)+    Right () -> pure ()+  runST $ do+    mutable <-+      case shape of+        DenseTransaction -> thawTriangulationDense capacity triangulation+        LocalTransaction -> thawTriangulation capacity triangulation+    operation <- newOperationState (halfEdgeCapacity mutable)+    outcome <- action mutable operation+    case outcome of+      Left refusal -> pure (Left refusal)+      Right value -> do+        frozenOutcome <- freezePublication mutable+        case frozenOutcome of+          Left obstruction -> pure (Left (mapBuildFailure obstruction))+          Right (frozen, publicationStats) -> do+            receipt <- freezeReceipt operation+            pure (Right (value, frozen, receipt, publicationStats))+{-# INLINE runTransactionCore #-}++freezeWithoutPublicationStats+  :: MutableDcel s vertex directed undirected face+  -> ST s (Either BuildError (Triangulation mode vertex directed undirected face, PublicationStats))+freezeWithoutPublicationStats mutable =+  fmap (fmap (\frozen -> (frozen, emptyPublicationStats))) (freezeTriangulation mutable)
+ src-build/Moonlight/Triangulation/Refinement.hs view
@@ -0,0 +1,551 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Ruppert refinement: Steiner insertion composed after a built mesh, never a+-- second kind of mesh. Parameters are reached through checked verbs rather than+-- a raw record, so an unrealizable quality bar is a refusal.+module Moonlight.Triangulation.Refinement+  ( refine+  , refineWithinDomain+  , validateRefinementParameters+  , withMinimumAngle+  , radiusEdgeRatioForAngle+  ) where++import Control.Monad (void)+import Control.Monad.ST (ST)+import Data.Foldable (traverse_)+import qualified Data.IntSet as IntSet+import Data.List (sort)+import Data.Maybe (fromMaybe)+import qualified Data.Set as Set+import qualified Data.Vector as V+import Moonlight.Triangulation.Dcel+  ( faceDirectedEdges+  , faceVertices+  , incidentFace+  , isConstraintEdge+  , numFaces+  , numUndirectedEdges+  , numVertices+  , undirectedEndpoints+  , vertexPoint+  )+import Moonlight.Triangulation.FloodFillIterator (facesAtEvenBarrierDepth)+import Moonlight.Triangulation.Internal.HandleDefs+  ( FaceId (..)+  , UndirectedEdgeId (..)+  , asUndirected+  , directedPair+  , faceIdIndex+  , reverseEdge+  , undirectedEdgeIdIndex+  )+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.Paged+  ( PublicationStats+  , TransactionShape (DenseTransaction, LocalTransaction)+  )+import Moonlight.Triangulation.Internal.Refinement+import Moonlight.Triangulation.Internal.Representation (Triangulation (..))+import Moonlight.Triangulation.Internal.Transaction (runTransactionWithPublication)+import Moonlight.Triangulation.Internal.Validation+  ( validateTopologyClosureWithStats+  )+import Moonlight.Triangulation.Types+import Moonlight.Triangulation.Validation+  ( validateTopology+  )++data RefinementExecution mode vertex directed undirected face = RefinementExecution+  { refinementExecutionResult :: !(RefinementResult mode vertex directed undirected face)+  , refinementExecutionVisitedFaces :: ![Int]+  , refinementExecutionPermittedFaces :: ![Int]+  , refinementExecutionInterfaceBoundaryReads :: {-# UNPACK #-} !Int+  , refinementExecutionBoundaryCrossingAttempts :: {-# UNPACK #-} !Int+  , refinementExecutionPublicationStats :: !PublicationStats+  }++-- | The radius-edge ratio admitting a minimum angle, in degrees.+radiusEdgeRatioForAngle :: Double -> Either BuildError (Maybe Double)+radiusEdgeRatioForAngle degrees =+  case classifyNonFinite degrees of+    Just nonFinite ->+      Left (RefinementMinimumAngleNotFinite nonFinite)+    Nothing+      | degrees < 0 || degrees > 60 ->+          Left (RefinementMinimumAngleOutOfRange degrees)+      | degrees == 0 -> Right Nothing+      | otherwise ->+          let ratio = 0.5 / sin (degrees * pi / 180)+           in case classifyNonFinite ratio of+                Just nonFinite ->+                  Left (RefinementMinimumAngleDerivedRatioNotFinite nonFinite)+                Nothing -> Right (Just ratio)++-- | Set the minimum angle, in degrees.+withMinimumAngle :: Double -> RefinementParameters -> Either BuildError (RefinementParameters)+withMinimumAngle degrees parameters = do+  ratio <- radiusEdgeRatioForAngle degrees+  pure parameters{refineMaxRadiusEdgeRatio = ratio}++-- | Refine an unconstrained or constrained triangulation in the same finite+-- DCEL. The constructor supplies application payloads for Steiner vertices;+-- payloads annotate the requested geometric point and cannot reauthor it.+refine+  :: (Point -> vertex)+  -> RefinementParameters+  -> Triangulation mode vertex directed undirected face+  -> Either BuildError (RefinementResult mode vertex directed undirected face)+refine makeVertex parameters =+  fmap refinementExecutionResult+    . refineWithInitialSeed RefineEveryFace Nothing makeVertex parameters++-- | Derive the exact immutable interface separating a checked active face+-- section from every protected inner face.  A permitted face set determines+-- this cut uniquely, so callers cannot supply a second claim about Gamma.+mkRefinementDomain+  :: Set.Set FaceId+  -> Triangulation mode vertex directed undirected face+  -> Either BuildError RefinementDomain+mkRefinementDomain permittedFaces triangulation = do+  permitted <- validateSeedFaces triangulation permittedFaces+  Right+    RefinementDomain+      { refinementDomainPermittedFaces = permitted+      , refinementDomainInterfacePairs = expectedInterface permitted+      , refinementDomainInputFaceCount = numFaces triangulation+      }+ where+  expectedInterface permitted =+    IntSet.fromList+      [ pair+      | rawFace <- IntSet.toAscList permitted+      , edge <- faceDirectedEdges triangulation (FaceId (fromIntegral rawFace))+      , let pair = undirectedEdgeIdIndex (asUndirected edge)+      , let adjacent = incidentFace triangulation (reverseEdge edge)+      , adjacent /= FaceId 0+      , IntSet.notMember (faceIdIndex adjacent) permitted+      ]++-- | Refine exactly one checked local section. Interface edges are installed as+-- transaction-local legalization barriers and removed before publication;+-- the receipt and collar proof inspect only the admitted local closure.+refineWithinDomain+  :: forall mode vertex directed undirected face.+     (Point -> vertex)+  -> RefinementParameters+  -> Set.Set FaceId+  -> Triangulation mode vertex directed undirected face+  -> Either BuildError (RefinementDomainResult mode vertex directed undirected face)+refineWithinDomain makeVertex parameters permittedFaces triangulation = do+  validateDomainParameters parameters+  domain <- mkRefinementDomain permittedFaces triangulation+  execution <-+    refineWithInitialSeed+      (RefineSeededFaces (refinementDomainPermittedFaces domain))+      (Just domain)+      makeVertex+      parameters+      triangulation+  let result = refinementExecutionResult execution+  (validationStats, finalInterfaceIncidence) <- validateDomainClosure+    domain+    triangulation+    (refinedTriangulation result)+    (refinementExecutionPermittedFaces execution)+  let receipt =+        buildRefinementReceipt+          domain+          triangulation+          (refinedTriangulation result)+          (refinementExecutionVisitedFaces execution)+          (refinementExecutionPermittedFaces execution)+          finalInterfaceIncidence+          (refinementExecutionInterfaceBoundaryReads execution)+          (refinementExecutionBoundaryCrossingAttempts execution)+          (refinementExecutionPublicationStats execution)+          validationStats+  case V.toList (refinementVisitedProtectedFaces receipt) of+    protected : _ -> Left (RefinementDomainWouldRewriteProtectedFace protected)+    [] ->+       let restoredResult :: RefinementResult mode vertex directed undirected face+           restoredResult =+            result+              { refinedTriangulation =+                  (refinedTriangulation result)+                    -- The checked local interpreter rejects every hull-pair+                    -- split, so the cached outer cycle remains an exact+                    -- handle witness and can be restored without a scan.+                    { triSeamFrontier = triSeamFrontier triangulation+                    }+              }+       in Right+        RefinementDomainResult+          { refinementDomainResult = restoredResult+          , refinementDomainReceipt = receipt+          }++validateDomainParameters :: RefinementParameters -> Either BuildError ()+validateDomainParameters parameters+  | not (refinePreserveConvexHull parameters) =+      Left RefinementDomainRequiresConvexHullPreservation+  | not (refineKeepConstraintEdges parameters) =+      Left RefinementDomainRequiresConstraintPreservation+  | refineExcludeOuterFaces parameters =+      Left RefinementDomainForbidsOuterFaceExclusion+  | refineMaxAdditionalVertices parameters == Nothing =+      Left RefinementDomainRequiresFiniteVertexBudget+  | otherwise = Right ()++refineWithInitialSeed+  :: RefinementInitialSeed+  -> Maybe RefinementDomain+  -> (Point -> vertex)+  -> RefinementParameters+  -> Triangulation mode vertex directed undirected face+  -> Either BuildError (RefinementExecution mode vertex directed undirected face)+refineWithInitialSeed initialSeed domain makeVertex parameters triangulation = do+  validateRefinementParameters parameters+  case domain of+    Just _ -> pure ()+    Nothing ->+      case validateTopology triangulation of+        violation : _ -> Left (RefinementInputTopologyInvalid violation)+        [] -> pure ()+  let originalCount = numVertices triangulation+      budget =+        case domain of+          Just _ -> max 0 (fromMaybe 0 (refineMaxAdditionalVertices parameters))+          Nothing -> max 0 (fromMaybe (10 * max 1 originalCount) (refineMaxAdditionalVertices parameters))+      initialExcludedFaces =+        if domain == Nothing && refineExcludeOuterFaces parameters+          then+            IntSet.fromList+              [ faceIdIndex face+              | face <-+                  facesAtEvenBarrierDepth+                    triangulation+                    (isConstraintEdge triangulation)+              ]+          else IntSet.empty+  ( outcome+    , frozen+    , stats+    , publicationStats+    ) <-+    runTransactionWithPublication id (transactionShape domain) triangulation budget $ \mutable operation -> do+      installInterfaceBarriers mutable domain+      refinement <-+        refineMutable+          makeVertex+          mutable+          operation+          parameters+          budget+          initialExcludedFaces+          initialSeed+          domain+      removeInterfaceBarriers mutable triangulation domain+      pure refinement+  let (complete, added, excluded, visited, permittedFaces, interfaceBoundaryReads, boundaryCrossingAttempts) = outcome+  pure+    RefinementExecution+      { refinementExecutionResult =+          RefinementResult+            { refinedTriangulation = frozen+            , refinementStats = stats+            , refinementAddedVertices = added+            , refinementComplete = complete+            , refinementExcludedFaces = V.fromList (map (FaceId . fromIntegral) excluded)+            }+      , refinementExecutionVisitedFaces = visited+      , refinementExecutionPermittedFaces = permittedFaces+      , refinementExecutionInterfaceBoundaryReads = interfaceBoundaryReads+      , refinementExecutionBoundaryCrossingAttempts = boundaryCrossingAttempts+      , refinementExecutionPublicationStats = publicationStats+      }++transactionShape :: Maybe RefinementDomain -> TransactionShape+transactionShape = maybe DenseTransaction (const LocalTransaction)++installInterfaceBarriers+  :: MutableDcel s vertex directed undirected face+  -> Maybe RefinementDomain+  -> ST s ()+installInterfaceBarriers mutable =+  traverse_+    (\pair -> void (setConstraint mutable (2 * pair)))+    . maybe [] (IntSet.toAscList . refinementDomainInterfacePairs)++removeInterfaceBarriers+  :: MutableDcel s vertex directed undirected face+  -> Triangulation mode vertex directed undirected face+  -> Maybe RefinementDomain+  -> ST s ()+removeInterfaceBarriers mutable input =+  traverse_+    (\pair ->+       let edge = UndirectedEdgeId (fromIntegral pair)+        in if isConstraintEdge input edge+             then pure ()+             else void (clearConstraint mutable (2 * pair))+    )+    . maybe [] (IntSet.toAscList . refinementDomainInterfacePairs)++buildRefinementReceipt+  :: RefinementDomain+  -> Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex directed undirected face+  -> [Int]+  -> [Int]+  -> V.Vector (UndirectedEdgeId, FaceId, FaceId)+  -> Int+  -> Int+  -> PublicationStats+  -> ValidationClosureStats+  -> RefinementReceipt+buildRefinementReceipt domain before after visited permittedFaces finalInterfaceIncidence interfaceBoundaryReads boundaryCrossingAttempts publicationStats validationStats =+  RefinementReceipt+    { refinementVisitedJoinFaces = V.fromList (fmap toFace visitedJoin)+    , refinementVisitedProtectedFaces = V.fromList (fmap toFace visitedProtected)+    , refinementCreatedFaces = V.fromList (fmap toFace createdFaces)+    , refinementFinalPermittedFaces = V.fromList (fmap toFace permittedFaces)+    , refinementFinalInterfaceIncidence = finalInterfaceIncidence+    , refinementTouchedEdges = V.fromList (fmap toEdge touchedEdges)+    , refinementRemovedEdges = V.fromList (fmap toEdge removedEdges)+    , refinementInterfaceBoundaryReads = interfaceBoundaryReads+    , refinementAttemptedBoundaryCrossings = boundaryCrossingAttempts+    , refinementPublicationStats = publicationStats+    , refinementValidationClosureStats = validationStats+    }+ where+  permitted = refinementDomainPermittedFaces domain+  (visitedProtected, visitedJoin) =+    foldr+      (\face (protected, join) ->+         if IntSet.member face permitted+           then (protected, face : join)+           else if face >= refinementDomainInputFaceCount domain+             then (protected, face : join)+           else (face : protected, join))+      ([], []) visited+  initialFaces = refinementDomainPermittedFaces domain+  finalFaces = IntSet.fromList permittedFaces+  faceClosure = IntSet.toAscList (IntSet.union initialFaces finalFaces)+  createdFaces =+    [ face+    | face <- faceClosure+    , localFaceSignature before face /= localFaceSignature after face+    ]+  initialEdges = localDomainEdges before initialFaces+  finalEdges = localDomainEdges after finalFaces+  edgeClosure = IntSet.toAscList (IntSet.union initialEdges finalEdges)+  touchedEdges =+    [ edge+    | edge <- edgeClosure+    , localEdgeSignature before edge /= localEdgeSignature after edge+    ]+  removedEdges =+    [ edge+    | edge <- IntSet.toAscList initialEdges+    , localEdgeSignature before edge /= localEdgeSignature after edge+    ]+  toFace = FaceId . fromIntegral+  toEdge = UndirectedEdgeId . fromIntegral++localFaceSignature+  :: Triangulation mode vertex directed undirected face+  -> Int+  -> Maybe [Point]+localFaceSignature triangulation raw+  | raw <= 0 || raw >= numFaces triangulation = Nothing+  | otherwise =+      Just+        ( sort+            (fmap (vertexPoint triangulation) (faceVertices triangulation (FaceId (fromIntegral raw))))+        )++localDomainEdges+  :: Triangulation mode vertex directed undirected face+  -> IntSet.IntSet+  -> IntSet.IntSet+localDomainEdges triangulation faces =+  IntSet.fromList+    [ undirectedEdgeIdIndex (asUndirected edge)+    | rawFace <- IntSet.toAscList faces+    , edge <- faceDirectedEdges triangulation (FaceId (fromIntegral rawFace))+    ]++localEdgeSignature+  :: Triangulation mode vertex directed undirected face+  -> Int+  -> Maybe (Point, Point, [FaceId])+localEdgeSignature triangulation raw+  | raw < 0 || raw >= numUndirectedEdges triangulation = Nothing+  | otherwise =+      let edge = UndirectedEdgeId (fromIntegral raw)+          (fromVertex, toVertex) = undirectedEndpoints triangulation edge+          fromPoint = vertexPoint triangulation fromVertex+          toPoint = vertexPoint triangulation toVertex+          (forward, backward) = directedPair edge+       in Just+            ( min fromPoint toPoint+            , max fromPoint toPoint+            , sort+                [ incidentFace triangulation forward+                , incidentFace triangulation backward+                ]+            )++validateDomainClosure+  :: RefinementDomain+  -> Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex directed undirected face+  -> [Int]+  -> Either BuildError (ValidationClosureStats, V.Vector (UndirectedEdgeId, FaceId, FaceId))+validateDomainClosure domain before after finalPermittedFaces = do+  let finalPermitted = IntSet.fromList finalPermittedFaces+      (closureStats, closureViolations) =+        validateTopologyClosureWithStats+          ( IntSet.union+              (refinementDomainPermittedFaces domain)+              finalPermitted+          )+          (refinementDomainInterfacePairs domain)+          after+  case closureViolations of+    violation : _ -> Left (RefinementInputTopologyInvalid violation)+    [] -> pure ()+  traverse_ validateProtectedFace (IntSet.toAscList protectedFaces)+  finalInterfaceIncidence <-+    V.fromList+      <$> traverse+        (validateInterfaceEdge finalPermitted)+        (IntSet.toAscList (refinementDomainInterfacePairs domain))+  pure (closureStats, finalInterfaceIncidence)+ where+  permitted = refinementDomainPermittedFaces domain+  protectedFaces =+    IntSet.fromList+      [ rawFace+      | rawPair <- IntSet.toAscList (refinementDomainInterfacePairs domain)+      , let edge = UndirectedEdgeId (fromIntegral rawPair)+      , let (forward, backward) = directedPair edge+      , rawFace <-+          [ faceIdIndex (incidentFace before forward)+          , faceIdIndex (incidentFace before backward)+          ]+      , rawFace > 0+      , IntSet.notMember rawFace permitted+      ]++  validateProtectedFace rawFace =+    if localFaceSignature before rawFace == localFaceSignature after rawFace+      then Right ()+      else Left (RefinementDomainProtectedFaceChanged (FaceId (fromIntegral rawFace)))++  validateInterfaceEdge finalPermitted rawPair =+    let edge = UndirectedEdgeId (fromIntegral rawPair)+     in case (localEdgeSignature before rawPair, localEdgeSignature after rawPair) of+      ( Just (beforeFrom, beforeTo, beforeFaces)+        , Just (afterFrom, afterTo, afterFaces)+        )+          | beforeFrom == afterFrom && beforeTo == afterTo ->+              validateInterfaceFaces finalPermitted edge beforeFaces afterFaces+      _ -> Left RefinementDomainTopologyChanged++  validateInterfaceFaces finalPermitted edge beforeFaces afterFaces =+    case filter protected beforeFaces of+      [protectedFace]+        | protectedFace `elem` afterFaces ->+            case filter (/= protectedFace) afterFaces of+              [oppositeFace]+                | IntSet.member (faceIdIndex oppositeFace) finalPermitted ->+                    Right (edge, protectedFace, oppositeFace)+                | otherwise ->+                    Left+                      ( RefinementDomainInterfaceOppositeFaceNotPermitted+                          edge+                          oppositeFace+                      )+              _ -> Left RefinementDomainTopologyChanged+      _ -> Left RefinementDomainTopologyChanged++  protected face =+    let raw = faceIdIndex face+     in raw > 0 && IntSet.notMember raw permitted++-- | Refuse outer or absent faces rather than silently treating an invalid+-- topology witness as an empty repair. Face zero is the outer face and has no+-- active refinement equation.+validateSeedFaces+  :: Triangulation mode vertex directed undirected face+  -> Set.Set FaceId+  -> Either BuildError IntSet.IntSet+validateSeedFaces triangulation requested =+  IntSet.fromList <$> traverse validateFace (Set.toAscList requested)+ where+  totalFaces = numFaces triangulation++  validateFace :: FaceId -> Either BuildError Int+  validateFace face+    | face == FaceId 0 || toInteger (unFaceId face) >= toInteger totalFaces =+        Left (RefinementSeedFaceNotActive face totalFaces)+    | otherwise = Right (faceIdIndex face)++-- | Refuse parameters no mesh can satisfy.+validateRefinementParameters :: RefinementParameters -> Either BuildError ()+validateRefinementParameters RefinementParameters{refineMaxAdditionalVertices, refineMinArea, refineMaxArea, refineMaxRadiusEdgeRatio, refineMaxEdgeLength} = do+  case refineMaxAdditionalVertices of+    Just value+      | value < 0 ->+          Left (RefinementMaximumAdditionalVerticesNegative value)+    _ -> Right ()+  validateOptionalRefinementParameter+    RefinementMinimumAreaNotFinite+    RefinementMinimumAreaNegative+    (>= 0)+    refineMinArea+  validateOptionalRefinementParameter+    RefinementMaximumAreaNotFinite+    RefinementMaximumAreaNotPositive+    (> 0)+    refineMaxArea+  validateOptionalRefinementParameter+    RefinementMaximumRadiusEdgeRatioNotFinite+    RefinementMaximumRadiusEdgeRatioNotPositive+    (> 0)+    refineMaxRadiusEdgeRatio+  validateOptionalRefinementParameter+    RefinementMaximumEdgeLengthNotFinite+    RefinementMaximumEdgeLengthNotPositive+    (> 0)+    refineMaxEdgeLength+  case (refineMinArea, refineMaxArea) of+    (Just minimumArea, Just maximumArea)+      | minimumArea > maximumArea ->+          Left+            ( RefinementMinimumAreaExceedsMaximum+                minimumArea+                maximumArea+            )+    _ -> Right ()++validateOptionalRefinementParameter+  :: (NonFiniteValue -> BuildError)+  -> (Double -> BuildError)+  -> (Double -> Bool)+  -> Maybe Double+  -> Either BuildError ()+validateOptionalRefinementParameter nonFinite outsideRange predicate value =+  case value of+    Nothing -> Right ()+    Just number ->+      case classifyNonFinite number of+        Just nonFiniteValue ->+          Left (nonFinite nonFiniteValue)+        Nothing+          | predicate number -> Right ()+          | otherwise ->+              Left (outsideRange number)
+ src-build/Moonlight/Triangulation/Removal.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Persistent removal: one excision, published as its own triangulation.+module Moonlight.Triangulation.Removal+  ( RemovalOutcome (..)+  , RemovalResult (..)+  , removeVertex+  , locateAndRemove+  ) where++import Control.DeepSeq (NFData)+import Moonlight.Triangulation.Internal.HandleDefs (VertexId (..))+import Moonlight.Triangulation.Internal.PointIndex (lookupPointIndex)+import Moonlight.Triangulation.Internal.Representation (Triangulation (..))+import Moonlight.Triangulation.Internal.Types (BuildError, BuildStats, Point, queryPointValue)+import Moonlight.Triangulation.Math (validatePoint)+import Moonlight.Triangulation.Internal.Session (RemovalOutcome (..), excise, withLocalSession)+import GHC.Generics (Generic)++-- | One removal and its publication: the frozen triangulation, the outcome+-- record, and the operation's counters. The persistent entries publish all+-- three; a session publishes the outcome per call and the counters once.+data RemovalResult mode vertex directed undirected face = RemovalResult+  { removalTriangulation :: !(Triangulation mode vertex directed undirected face)+  , removalOutcome :: !(RemovalOutcome vertex)+  , removalStats :: !BuildStats+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++deriving stock instance+  (Eq vertex, Eq directed, Eq undirected, Eq face)+  => Eq (RemovalResult mode vertex directed undirected face)+deriving stock instance+  (Show vertex, Show directed, Show undirected, Show face)+  => Show (RemovalResult mode vertex directed undirected face)++-- | Remove the vertex a handle names. The triangulation the caller passed in+-- still denotes the mesh it always did; the removal is in the returned one.+--+-- This is a session over a single 'excise', which is what makes replacing a+-- fold of it with one session sound: the two agree on every mesh, and differ+-- only in how many of the intermediate ones are published. A fold publishes+-- @k@ meshes and pays a thaw for each, so it runs in Θ(n·k); the session pays+-- one thaw and runs in O(k·deg).+removeVertex+  :: Triangulation mode vertex directed undirected face+  -> VertexId+  -> Either BuildError (RemovalResult mode vertex directed undirected face)+removeVertex triangulation requested = do+  (outcome, frozen, stats) <- withLocalSession triangulation 0 (excise requested)+  pure+    RemovalResult+      { removalTriangulation = frozen+      , removalOutcome = outcome+      , removalStats = stats+      }++-- | Resolve a point through the mesh's exact derived identity section, then+-- remove the handle it proves. A hash is only a rejection filter; the lookup+-- confirms both authoritative coordinate planes before the topology is+-- opened. A point that sites no vertex answers 'Nothing' without publishing a+-- cosmetically different mesh.+--+-- See 'removeVertex' on the cost of folding this rather than opening one+-- session over @removeAt@.+locateAndRemove+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> Either BuildError (Maybe (RemovalResult mode vertex directed undirected face))+locateAndRemove triangulation point = do+  queryPoint <- validatePoint Nothing point+  case+      lookupPointIndex+        (triPointX triangulation)+        (triPointY triangulation)+        (triPointIndex triangulation)+        -- Stored coordinates are canonical; the query must be too, or any+        -- coordinate whose canonicalization exceeds signed zero misses a vertex+        -- the session verbs would find.+        (queryPointValue queryPoint) of+    Nothing -> Right Nothing+    Just rawVertex ->+      Just <$> removeVertex triangulation (VertexId (fromIntegral rawVertex))++-- Polymorphic entries consumed from other packages; without exposed+-- unfoldings they run boxed through an imported boundary.
+ src-build/Moonlight/Triangulation/Session.hs view
@@ -0,0 +1,17 @@+-- | One sealed editing transaction: thaw once, compose edits, publish once.+module Moonlight.Triangulation.Session+  ( RemovalOutcome (..)+  , Session+  , withSession+  , insertVertex+  , insertVertexAt+  , insertVertexAtNear+  , insertVertexAtNearVertex+  , removeAt+  , removeAtNear+  , removeManyAt+  , removeManyAtNear+  , refuse+  ) where++import Moonlight.Triangulation.Internal.Session
+ src-build/Moonlight/Triangulation/SetAlgebra.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE DataKinds #-}++-- | Finite-set operations on unconstrained meshes. Every+-- constructing operation returns the finite-arena obstruction instead of+-- laundering it through a partial class instance.+module Moonlight.Triangulation.SetAlgebra+  ( siteRelation+  , union+  , unions+  , intersection+  , intersectionWith+  , difference+  , symmetricDifference+  ) where++import Data.Foldable (traverse_)+import Data.Maybe (isJust)+import qualified Data.Vector as V+import Moonlight.Triangulation.BulkLoad (empty)+import Moonlight.Triangulation.Dcel (numVertices, vertexData, vertexPoint, vertexPoints)+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (vertices)+import Moonlight.Triangulation.Internal.Join (joinBalanced, joinNormalForm)+import Moonlight.Triangulation.Internal.Join.SiteSet+  ( rebuildCanonicalSiteSet+  , siteSetDifference+  , siteSetFromTriangulation+  , siteSetIntersectionWith+  , siteSetPoints+  , siteRelationFromTriangulations+  , siteSetSymmetricDifferenceFromTriangulations+  , siteSupportFromTriangulation+  )+import Moonlight.Triangulation.Internal.Representation (Triangulation)+import Moonlight.Triangulation.Internal.Types+  ( BuildError (PointLocationFailed)+  , ConstraintMode (Unconstrained)+  , InsertionDisposition (..)+  , Point+  , SiteRelation (..)+  , unitElementDefaults+  )+import Moonlight.Triangulation.JoinSemilattice (JoinSemilattice)+import Moonlight.Triangulation.Internal.Session+  ( Session+  , insertVertexAt+  , refuse+  , removeAtNear+  , removeManyAt+  , withLocalSession+  )++-- | Exact relation between two triangulations' coordinate supports. Vertex+-- annotations and topology-element payloads are observations over the support;+-- none participates in this classification.+siteRelation+  :: Triangulation leftMode leftAnnotation leftDirected leftUndirected leftFace+  -> Triangulation rightMode rightAnnotation rightDirected rightUndirected rightFace+  -> SiteRelation+siteRelation left right =+  siteRelationFromTriangulations left right+{-# INLINE siteRelation #-}++-- | A valid Delaunay representative of both site sets. Use+-- 'Moonlight.Triangulation.Canonical.canonicalize'+-- when construction-independent dense numbering is required.+union+  :: JoinSemilattice annotation+  => Triangulation 'Unconstrained annotation () () ()+  -> Triangulation 'Unconstrained annotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+union = joinNormalForm++-- | @union@ over a list, folded as a balanced tournament.+unions+  :: JoinSemilattice annotation+  => [Triangulation 'Unconstrained annotation () () ()]+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+unions = joinBalanced++-- | The sites both meshes hold.+intersection+  :: Triangulation 'Unconstrained () () () ()+  -> Triangulation 'Unconstrained () () () ()+  -> Either BuildError (Triangulation 'Unconstrained () () () ())+intersection left right+  | numVertices left == 0 = Right left+  | numVertices right == 0 = Right right+  | otherwise =+      case siteRelationFromTriangulations left right of+        EqualSites -> Right left+        LeftProperSubset -> Right left+        RightProperSubset -> Right right+        DisjointSites -> Right (empty unitElementDefaults)+        PartialOverlap overlap -> intersectPartialOverlap overlap+ where+  leftSites = siteSupportFromTriangulation left+  rightSites = siteSupportFromTriangulation right+  rebuildIntersection = intersectionWith (\_ _ -> ()) left right+  intersectPartialOverlap overlap+    | leftRemoved <= rightRemoved+    , removalDeltaIsEligible leftRemoved overlap =+        removeExpectedFrom left (siteSetPoints (siteSetDifference leftSites rightSites))+    | rightRemoved < leftRemoved+    , removalDeltaIsEligible rightRemoved overlap =+        removeExpectedFrom right (siteSetPoints (siteSetDifference rightSites leftSites))+    | otherwise = rebuildIntersection+   where+    leftRemoved = numVertices left - overlap+    rightRemoved = numVertices right - overlap+{-# INLINE intersection #-}++-- | The sites both meshes hold, with the result annotation computed from the+-- left and right annotations at that exact coordinate. The combiner is called+-- only for shared sites, in left-then-right order; geometry remains the sole+-- authority for membership. @intersectionWith const left mask@ is the+-- annotation-preserving restriction of @left@ to @mask@'s support.+intersectionWith+  :: (leftAnnotation -> rightAnnotation -> annotation)+  -> Triangulation 'Unconstrained leftAnnotation () () ()+  -> Triangulation 'Unconstrained rightAnnotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+intersectionWith combine left right =+  rebuildCanonicalSiteSet+    ( siteSetIntersectionWith+        combine+        (siteSetFromTriangulation left)+        (siteSetFromTriangulation right)+    )+{-# INLINE intersectionWith #-}++-- | The left's sites, less the right's.+difference+  :: Triangulation 'Unconstrained leftAnnotation () () ()+  -> Triangulation 'Unconstrained rightAnnotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained leftAnnotation () () ())+difference left right+  | numVertices left == 0 || numVertices right == 0 = Right left+  | numVertices right < numVertices left+  , removalDeltaIsEligible (numVertices right) (numVertices left - numVertices right) =+      removeAvailableFrom left (vertexPoints right)+  | otherwise =+      rebuildCanonicalSiteSet+        ( siteSetDifference+            (siteSetFromTriangulation left)+            (siteSupportFromTriangulation right)+        )+{-# INLINE difference #-}++-- | The sites exactly one mesh holds.+symmetricDifference+  :: Triangulation 'Unconstrained annotation () () ()+  -> Triangulation 'Unconstrained annotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+symmetricDifference left right+  | numVertices left == 0 = Right right+  | numVertices right == 0 = Right left+  | numVertices right < numVertices left+  , toggleDeltaIsEligible (numVertices right) (numVertices left - numVertices right) =+      toggleIncoming left right+  | numVertices left < numVertices right+  , toggleDeltaIsEligible (numVertices left) (numVertices right - numVertices left) =+      toggleIncoming right left+  | otherwise =+      siteSetSymmetricDifferenceFromTriangulations left right+        >>= rebuildCanonicalSiteSet+{-# INLINE symmetricDifference #-}++removalDeltaIsEligible :: Int -> Int -> Bool+removalDeltaIsEligible removed survivors = removed <= survivors `quot` 128+{-# INLINE removalDeltaIsEligible #-}++toggleDeltaIsEligible :: Int -> Int -> Bool+toggleDeltaIsEligible incoming residentRemainder = incoming <= residentRemainder `quot` 128+{-# INLINE toggleDeltaIsEligible #-}++removeAvailableFrom+  :: Triangulation 'Unconstrained annotation () () ()+  -> V.Vector (Point)+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+removeAvailableFrom triangulation points =+  fmap published+    (withLocalSession triangulation 0 (V.any isJust <$> removeManyAt points))+ where+  published (removed, revised, _) = if removed then revised else triangulation+{-# INLINE removeAvailableFrom #-}++removeExpectedFrom+  :: Triangulation 'Unconstrained annotation () () ()+  -> V.Vector (Point)+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+removeExpectedFrom triangulation points =+  fmap (\(_, revised, _) -> revised)+    (withLocalSession triangulation 0 (removeExpectedPoints points))+{-# INLINE removeExpectedFrom #-}++removeExpectedPoints+  :: V.Vector (Point)+  -> Session state annotation () () () ()+removeExpectedPoints points = do+  outcomes <- removeManyAt points+  V.zipWithM_+    (\point outcome -> maybe (refuse (PointLocationFailed point)) (const (pure ())) outcome)+    points+    outcomes+{-# INLINE removeExpectedPoints #-}++toggleIncoming+  :: Triangulation 'Unconstrained annotation () () ()+  -> Triangulation 'Unconstrained annotation () () ()+  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())+toggleIncoming base incoming =+  fmap (\(_, revised, _) -> revised)+    (withLocalSession base (numVertices incoming) (toggleIncomingVertices incoming))+{-# INLINE toggleIncoming #-}++toggleIncomingVertices+  :: Triangulation 'Unconstrained annotation () () ()+  -> Session state annotation () () () ()+toggleIncomingVertices incoming =+  traverse_+    (\vertex -> do+      let point = vertexPoint incoming vertex+          annotation = vertexData incoming vertex+      (fresh, disposition) <- insertVertexAt point annotation+      case disposition of+        Inserted -> pure ()+        AlreadyPresent -> do+          outcome <- removeAtNear fresh point+          maybe (refuse (PointLocationFailed point)) (const (pure ())) outcome+    )+    (vertices incoming)+{-# INLINE toggleIncomingVertices #-}
+ src-cell-complex/Moonlight/Hex/CellComplex.hs view
@@ -0,0 +1,79 @@+-- | Integral cellular chains derived from one native hexagonal region.+module Moonlight.Hex.CellComplex+  ( HexCellComplexError (..)+  , finiteHexCellComplex+  ) where++import Data.Bifunctor (first)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Set qualified as Set+import Data.Vector qualified as Vector+import Moonlight.Hex.Coordinate (HexCoord)+import Moonlight.Hex.Element+  ( HexSide+  , HexBoundarySide+  , HexVertex+  , hexBoundaryFrom+  , hexBoundaryIdentity+  , hexCellBoundary+  , hexCellSides+  , hexCellVertices+  , hexSideEndpoints+  )+import Moonlight.Hex.Region (HexRegion, hexRegionCoords)+import Moonlight.Homology.Boundary+  ( BoundaryIncidence+  , FiniteChainComplex+  , emptyBoundaryIncidence+  , emptyBoundaryIncidenceOf+  , materializeIncidenceBoundary+  , mkFiniteChainComplexChecked+  )+import Moonlight.Homology.Chain (HomologicalDegree (..), HomologyFailure)++newtype HexCellComplexError = HexCellComplexInvalid HomologyFailure+  deriving stock (Eq, Show)++-- | Interpret the selected cells and their downward closure in Homology's+-- existing finite-chain carrier. No second topology representation survives.+finiteHexCellComplex :: HexRegion -> Either HexCellComplexError (FiniteChainComplex Int)+finiteHexCellComplex region = do+  degreeOne <-+    first HexCellComplexInvalid+      (materializeIncidenceBoundary edgeBoundary edgeBasis vertexBasis)+  degreeTwo <-+    first HexCellComplexInvalid+      (materializeIncidenceBoundary faceBoundary faceBasis edgeBasis)+  let degreeZero :: BoundaryIncidence Int+      degreeZero = emptyBoundaryIncidenceOf (fromIntegral (length vertexBasis)) 0+      boundaryAt (HomologicalDegree degree) = case degree of+        0 -> degreeZero+        1 -> degreeOne+        2 -> degreeTwo+        _ -> emptyBoundaryIncidence+  first HexCellComplexInvalid+    (mkFiniteChainComplexChecked (HomologicalDegree 2) boundaryAt)+ where+  faceBasis = Vector.toList (hexRegionCoords region)+  edgeBasis =+    Set.toAscList+      (Set.fromList (faceBasis >>= NonEmpty.toList . hexCellSides))+  vertexBasis =+    Set.toAscList+      (Set.fromList (faceBasis >>= NonEmpty.toList . hexCellVertices))++edgeBoundary :: HexSide -> [(Int, HexVertex)]+edgeBoundary side =+  let (from, to) = hexSideEndpoints side+   in [(-1, from), (1, to)]++faceBoundary :: HexCoord -> [(Int, HexSide)]+faceBoundary = fmap orientedCoefficient . NonEmpty.toList . hexCellBoundary+ where+  orientedCoefficient :: HexBoundarySide -> (Int, HexSide)+  orientedCoefficient boundary =+    let side = hexBoundaryIdentity boundary+        (canonicalFrom, _) = hexSideEndpoints side+        coefficient = if hexBoundaryFrom boundary == canonicalFrom then 1 else -1+     in (coefficient, side)+{-# LANGUAGE DerivingStrategies #-}
+ src-cell-complex/Moonlight/Triangulation/CellComplex.hs view
@@ -0,0 +1,495 @@+{-# LANGUAGE EmptyDataDeriving #-}++-- | The admitted Moonlight triangulation cell section as a generic+-- 'CellComplex2D', an integral cellular chain complex, and an exact filtered+-- alpha complex. The 'ExactCellSet' remains the semantic owner: this module+-- supplies only the incidence and Homology interpretations required by+-- downstream topology.+module Moonlight.Triangulation.CellComplex+  ( DCELComplex,+    DCELError (..),+    fromExactCellSet,+    finiteChainComplex,+    filteredAlphaComplex,+  )+where++import Data.Bifunctor (first)+import Data.IntMap.Strict qualified as IntMap+import Data.IntSet qualified as IntSet+import Data.List qualified as List+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Vector qualified as Vector+import Moonlight.Algebra.Pure.Orientation (Orientation (..))+import Moonlight.Homology.Boundary+  ( BoundaryIncidence+  , BoundaryIncidenceShapeError+  , BoundaryEntry+  , FiniteChainComplex+  , emptyBoundaryIncidence+  , emptyBoundaryIncidenceOf+  , mkBoundaryEntryFromInts+  , mkBoundaryIncidenceFromOrderedColumns+  , mkBoundaryIncidenceFromOrderedEntries+  , mkFiniteChainComplexChecked+  , targetIndex+  )+import Moonlight.Homology.Chain+  ( HomologicalDegree (..)+  , HomologyFailure+  )+import Moonlight.Homology.Persistence+  ( FilteredFiniteChainComplex+  , mkFilteredFiniteChainComplex+  )+import Moonlight.Homology.Pure.Topology.CellComplex+  ( CellComplex2D (..)+  , CellRef (..)+  , CellTypes (..)+  , OrientedEdge (..)+  , ValidateComplex2D (..)+  )+import Moonlight.Homology.Topology (BasisCellRef (..))+import Moonlight.Triangulation.Alpha+  ( AlphaBirth+  , AlphaFiltration+  , alphaEdgeBirth+  , alphaFaceBirth+  , alphaFiltrationCellSet+  , alphaVertexBirth+  )+import Moonlight.Triangulation.Dcel qualified as Dcel+import Moonlight.Triangulation.Internal.HandleDefs+  ( DirectedEdgeId,+    FaceId (..),+    UndirectedEdgeId (..),+    VertexId (..),+    asUndirected,+    directedPair,+    isNormalized,+  )+import Moonlight.Triangulation.Internal.CellSet (ExactCellSet (..))+import Moonlight.Triangulation.Types (Triangulation)++-- | An incidence view of one already-validated, downward-closed exact cell+-- selection. It deliberately has no independent cell inventory.+newtype DCELComplex = DCELComplex ExactCellSet++-- | 'ExactCellSet' construction discharges every closure and handle+-- obligation before this view exists. Incidence materialization, Homology's+-- independent chain-law seal, and the exact-birth join retain typed+-- obstructions at their respective boundaries.+type DCELCellRef = CellRef VertexId UndirectedEdgeId FaceId++data DCELError+  = DCELBoundaryCellMissing !DCELCellRef !DCELCellRef+  | DCELBoundaryIncidenceInvalid !BoundaryIncidenceShapeError+  | DCELChainComplexInvalid !HomologyFailure+  | DCELAlphaBirthMissing !DCELCellRef+  | DCELFilteredComplexInvalid !HomologyFailure+  deriving stock (Eq, Show)++fromExactCellSet :: ExactCellSet -> DCELComplex+fromExactCellSet = DCELComplex++-- | Canonical integral cellular chains in ascending resident-handle order.+-- Degree one uses target minus source; degree two uses the DCEL's oriented+-- face boundary. The Homology boundary seals the result only after checking+-- shape and @d . d = 0@; no unchecked chain constructor crosses the public+-- package boundary.+finiteChainComplex :: DCELComplex -> Either DCELError (FiniteChainComplex Int)+finiteChainComplex complexValue =+  let basis = dcelBasis complexValue+   in finiteChainComplexWithBasis complexValue basis++-- | Lower the exact alpha section into Homology without converting its birth+-- order through binary64. Persistence remains wholly owned by Homology.+filteredAlphaComplex+  :: AlphaFiltration+  -> Either DCELError (FilteredFiniteChainComplex AlphaBirth Int)+filteredAlphaComplex filtration =+  case alphaFiltrationCellSet filtration of+    ExactCellSet triangulation _ _ _ -> do+      finite <- residentAlphaFiniteChainComplex triangulation+      vertexBirthAssignments <-+        traverse+          ( residentAlphaBirthAssignment+              CellVertexRef+              residentVertexBasisRef+              (alphaVertexBirth filtration)+          )+          (vertexHandlesOf triangulation)+      edgeBirthAssignments <-+        traverse+          ( residentAlphaBirthAssignment+              CellEdgeRef+              residentEdgeBasisRef+              (alphaEdgeBirth filtration)+          )+          (undirectedEdgesOf triangulation)+      faceBirthAssignments <-+        traverse+          ( residentAlphaBirthAssignment+              CellFaceRef+              residentFaceBasisRef+              (alphaFaceBirth filtration)+          )+          (innerFacesOf triangulation)+      first DCELFilteredComplexInvalid+        ( mkFilteredFiniteChainComplex+            finite+            (vertexBirthAssignments <> edgeBirthAssignments <> faceBirthAssignments)+        )++-- | The opaque 'AlphaFiltration' constructor admits the entire resident DCEL,+-- whose handle ranges are dense. This local section therefore lowers those+-- handles directly to basis indices while retaining Homology's independent+-- shape and nilpotence seal. Sparse 'ExactCellSet' values continue through the+-- generic map-indexed 'finiteChainComplex' path.+residentAlphaFiniteChainComplex+  :: Triangulation mode vertex directed undirected face+  -> Either DCELError (FiniteChainComplex Int)+residentAlphaFiniteChainComplex triangulation = do+  let degreeOneColumns =+        Vector.generate+          (Dcel.numUndirectedEdges triangulation)+          (residentEdgeBoundaryEntries triangulation . UndirectedEdgeId . fromIntegral)+      degreeTwoColumns =+        Vector.imap+          residentFaceBoundaryEntries+          (Dcel.innerFaceDirectedEdgeTriples triangulation)+  degreeOneBoundary <-+    first DCELBoundaryIncidenceInvalid+      ( mkBoundaryIncidenceFromOrderedColumns+          (fromIntegral (Dcel.numUndirectedEdges triangulation))+          (fromIntegral (Dcel.numVertices triangulation))+          degreeOneColumns+      )+  degreeTwoBoundary <-+    first DCELBoundaryIncidenceInvalid+      ( mkBoundaryIncidenceFromOrderedColumns+          (fromIntegral (Dcel.numInnerFaces triangulation))+          (fromIntegral (Dcel.numUndirectedEdges triangulation))+          degreeTwoColumns+      )+  let degreeZeroBoundary =+        emptyBoundaryIncidenceOf+          (fromIntegral (Dcel.numVertices triangulation))+          0+      boundaryAt (HomologicalDegree degreeValue) =+        case degreeValue of+          0 -> degreeZeroBoundary+          1 -> degreeOneBoundary+          2 -> degreeTwoBoundary+          _ -> emptyBoundaryIncidence+  first DCELChainComplexInvalid+    (mkFiniteChainComplexChecked (HomologicalDegree 2) boundaryAt)++residentEdgeBoundaryEntries+  :: Triangulation mode vertex directed undirected face+  -> UndirectedEdgeId+  -> [BoundaryEntry Int]+residentEdgeBoundaryEntries triangulation edgeValue =+  let (sourceVertex, targetVertex) = Dcel.undirectedEndpoints triangulation edgeValue+      sourceEntry =+        mkBoundaryEntryFromInts+          (basisIndexOfEdge edgeValue)+          (basisIndexOfVertex sourceVertex)+          (-1)+      targetEntry =+        mkBoundaryEntryFromInts+          (basisIndexOfEdge edgeValue)+          (basisIndexOfVertex targetVertex)+          1+   in if targetIndex sourceEntry <= targetIndex targetEntry+        then [sourceEntry, targetEntry]+        else [targetEntry, sourceEntry]++residentFaceBoundaryEntries+  :: Int+  -> (DirectedEdgeId, DirectedEdgeId, DirectedEdgeId)+  -> [BoundaryEntry Int]+residentFaceBoundaryEntries faceIndexValue (firstEdge, secondEdge, thirdEdge) =+  sortThreeBoundaryEntries+    (residentFaceBoundaryEntry faceIndexValue firstEdge)+    (residentFaceBoundaryEntry faceIndexValue secondEdge)+    (residentFaceBoundaryEntry faceIndexValue thirdEdge)++sortThreeBoundaryEntries+  :: BoundaryEntry Int+  -> BoundaryEntry Int+  -> BoundaryEntry Int+  -> [BoundaryEntry Int]+sortThreeBoundaryEntries firstEntry secondEntry thirdEntry =+  let (firstLow, firstHigh) = orderedBoundaryPair firstEntry secondEntry+      (secondLow, finalHigh) = orderedBoundaryPair firstHigh thirdEntry+      (finalLow, finalMiddle) = orderedBoundaryPair firstLow secondLow+   in [finalLow, finalMiddle, finalHigh]++orderedBoundaryPair+  :: BoundaryEntry Int+  -> BoundaryEntry Int+  -> (BoundaryEntry Int, BoundaryEntry Int)+orderedBoundaryPair firstEntry secondEntry =+  if targetIndex firstEntry <= targetIndex secondEntry+    then (firstEntry, secondEntry)+    else (secondEntry, firstEntry)++residentFaceBoundaryEntry :: Int -> DirectedEdgeId -> BoundaryEntry Int+residentFaceBoundaryEntry faceIndexValue directedEdge =+  mkBoundaryEntryFromInts+    faceIndexValue+    (basisIndexOfEdge (asUndirected directedEdge))+    (if isNormalized directedEdge then 1 else -1)++residentAlphaBirthAssignment+  :: (cell -> DCELCellRef)+  -> (cell -> BasisCellRef)+  -> (cell -> Maybe AlphaBirth)+  -> cell+  -> Either DCELError (BasisCellRef, AlphaBirth)+residentAlphaBirthAssignment cellReference basisReference birthAt cell =+  maybe+    (Left (DCELAlphaBirthMissing (cellReference cell)))+    (Right . (,) (basisReference cell))+    (birthAt cell)++residentVertexBasisRef :: VertexId -> BasisCellRef+residentVertexBasisRef vertexValue =+  BasisCellRef (HomologicalDegree 0) (basisIndexOfVertex vertexValue)++residentEdgeBasisRef :: UndirectedEdgeId -> BasisCellRef+residentEdgeBasisRef edgeValue =+  BasisCellRef (HomologicalDegree 1) (basisIndexOfEdge edgeValue)++residentFaceBasisRef :: FaceId -> BasisCellRef+residentFaceBasisRef faceValue =+  BasisCellRef (HomologicalDegree 2) (basisIndexOfFace faceValue)++basisIndexOfVertex :: VertexId -> Int+basisIndexOfVertex (VertexId rawVertex) = fromIntegral rawVertex++basisIndexOfEdge :: UndirectedEdgeId -> Int+basisIndexOfEdge (UndirectedEdgeId rawEdge) = fromIntegral rawEdge++basisIndexOfFace :: FaceId -> Int+basisIndexOfFace (FaceId rawFace) = fromIntegral rawFace - 1++undirectedEdgesOf+  :: Triangulation mode vertex directed undirected face+  -> [UndirectedEdgeId]+undirectedEdgesOf triangulation =+  fmap (UndirectedEdgeId . fromIntegral) [0 .. Dcel.numUndirectedEdges triangulation - 1]++vertexHandlesOf+  :: Triangulation mode vertex directed undirected face+  -> [VertexId]+vertexHandlesOf triangulation =+  fmap (VertexId . fromIntegral) [0 .. Dcel.numVertices triangulation - 1]++innerFacesOf+  :: Triangulation mode vertex directed undirected face+  -> [FaceId]+innerFacesOf triangulation =+  fmap (FaceId . fromIntegral) [1 .. Dcel.numFaces triangulation - 1]++data DCELBasis = DCELBasis+  { dcelVertexBasis :: !(Map VertexId BasisCellRef)+  , dcelEdgeBasis :: !(Map UndirectedEdgeId BasisCellRef)+  , dcelFaceBasis :: !(Map FaceId BasisCellRef)+  }++dcelBasis :: DCELComplex -> DCELBasis+dcelBasis complexValue =+  DCELBasis+    { dcelVertexBasis = basisMap 0 (vertices complexValue)+    , dcelEdgeBasis = basisMap 1 (edges complexValue)+    , dcelFaceBasis = basisMap 2 (faces complexValue)+    }++basisMap :: Ord cell => Int -> [cell] -> Map cell BasisCellRef+basisMap degreeValue cells =+  Map.fromAscList+    ( zipWith+        (\indexValue cell -> (cell, BasisCellRef (HomologicalDegree degreeValue) indexValue))+        [0 ..]+        cells+    )++finiteChainComplexWithBasis+  :: DCELComplex+  -> DCELBasis+  -> Either DCELError (FiniteChainComplex Int)+finiteChainComplexWithBasis complexValue basis = do+  degreeOneEntries <-+    concat+      <$> traverse+        (edgeBoundaryEntries complexValue basis)+        (Map.toAscList (dcelEdgeBasis basis))+  degreeTwoEntries <-+    concat+      <$> traverse+        (faceBoundaryEntries complexValue basis)+        (Map.toAscList (dcelFaceBasis basis))+  degreeOneBoundary <-+    first DCELBoundaryIncidenceInvalid+      ( mkBoundaryIncidenceFromOrderedEntries+          (fromIntegral (Map.size (dcelEdgeBasis basis)))+          (fromIntegral (Map.size (dcelVertexBasis basis)))+          degreeOneEntries+      )+  degreeTwoBoundary <-+    first DCELBoundaryIncidenceInvalid+      ( mkBoundaryIncidenceFromOrderedEntries+          (fromIntegral (Map.size (dcelFaceBasis basis)))+          (fromIntegral (Map.size (dcelEdgeBasis basis)))+          degreeTwoEntries+      )+  let degreeZeroBoundary =+        emptyBoundaryIncidenceOf+          (fromIntegral (Map.size (dcelVertexBasis basis)))+          0+      boundaryAt :: HomologicalDegree -> BoundaryIncidence Int+      boundaryAt (HomologicalDegree degreeValue) =+        case degreeValue of+          0 -> degreeZeroBoundary+          1 -> degreeOneBoundary+          2 -> degreeTwoBoundary+          _ -> emptyBoundaryIncidence+  first DCELChainComplexInvalid+    (mkFiniteChainComplexChecked (HomologicalDegree 2) boundaryAt)++edgeBoundaryEntries+  :: DCELComplex+  -> DCELBasis+  -> (UndirectedEdgeId, BasisCellRef)+  -> Either DCELError [BoundaryEntry Int]+edgeBoundaryEntries complexValue basis (edgeValue, edgeBasisRef) = do+  let (sourceVertex, targetVertex) = edgeBoundary complexValue edgeValue+      sourceCell = CellEdgeRef edgeValue+  sourceBasisRef <-+    requireBoundaryCell+      sourceCell+      (CellVertexRef sourceVertex)+      sourceVertex+      (dcelVertexBasis basis)+  targetBasisRef <-+    requireBoundaryCell+      sourceCell+      (CellVertexRef targetVertex)+      targetVertex+      (dcelVertexBasis basis)+  pure+    ( List.sortOn+        targetIndex+        [ mkBoundaryEntryFromInts+            (cellIndex edgeBasisRef)+            (cellIndex sourceBasisRef)+            (-1)+        , mkBoundaryEntryFromInts+            (cellIndex edgeBasisRef)+            (cellIndex targetBasisRef)+            1+        ]+    )++faceBoundaryEntries+  :: DCELComplex+  -> DCELBasis+  -> (FaceId, BasisCellRef)+  -> Either DCELError [BoundaryEntry Int]+faceBoundaryEntries complexValue basis (faceValue, faceBasisRef) =+  List.sortOn targetIndex+    <$> traverse+      boundaryEntry+      (faceBoundary complexValue faceValue)+ where+  boundaryEntry orientedBoundary = do+    let edgeValue = orientedEdge orientedBoundary+    edgeBasisRef <-+      requireBoundaryCell+        (CellFaceRef faceValue)+        (CellEdgeRef edgeValue)+        edgeValue+        (dcelEdgeBasis basis)+    pure+      ( mkBoundaryEntryFromInts+          (cellIndex faceBasisRef)+          (cellIndex edgeBasisRef)+          (orientationCoefficient (edgeOrientation orientedBoundary))+      )++orientationCoefficient :: Orientation -> Int+orientationCoefficient orientation =+  case orientation of+    Positive -> 1+    Negative -> -1++requireBoundaryCell+  :: Ord cell+  => DCELCellRef+  -> DCELCellRef+  -> cell+  -> Map cell BasisCellRef+  -> Either DCELError BasisCellRef+requireBoundaryCell sourceCell targetCell cell basis =+  maybe+    (Left (DCELBoundaryCellMissing sourceCell targetCell))+    Right+    (Map.lookup cell basis)++instance CellTypes DCELComplex where+  type Vertex DCELComplex = VertexId+  type Edge DCELComplex = UndirectedEdgeId+  type Face DCELComplex = FaceId++instance CellComplex2D DCELComplex where+  vertices (DCELComplex (ExactCellSet _ selectedVertices _ _)) =+    fmap (VertexId . fromIntegral) (IntMap.keys selectedVertices)++  edges (DCELComplex (ExactCellSet _ _ selectedEdges _)) =+    fmap (UndirectedEdgeId . fromIntegral) (IntSet.toAscList selectedEdges)++  faces (DCELComplex (ExactCellSet _ _ _ selectedFaces)) =+    fmap (FaceId . fromIntegral) (IntSet.toAscList selectedFaces)++  edgeBoundary (DCELComplex (ExactCellSet triangulation _ _ _)) =+    Dcel.undirectedEndpoints triangulation++  faceBoundary (DCELComplex (ExactCellSet triangulation _ _ _)) face =+    fmap orientedBoundaryEdge (Dcel.faceDirectedEdges triangulation face)+    where+      orientedBoundaryEdge directedEdge =+        OrientedEdge+          { orientedEdge = asUndirected directedEdge,+            edgeOrientation =+              if isNormalized directedEdge+                then Positive+                else Negative+          }++  edgesAtVertex complexValue@(DCELComplex (ExactCellSet triangulation _ _ _)) vertex =+    filter (edgeContainsVertex triangulation vertex) (edges complexValue)++  facesAtEdge (DCELComplex (ExactCellSet triangulation _ _ selectedFaces)) edge =+    let (forward, backward) = directedPair edge+        selectedIncidentFace directedEdge =+          let face@(FaceId rawFace) = Dcel.incidentFace triangulation directedEdge+           in if IntSet.member (fromIntegral rawFace) selectedFaces+                then Just face+                else Nothing+     in (selectedIncidentFace forward, selectedIncidentFace backward)++instance ValidateComplex2D DCELComplex where+  type ValidationIssue DCELComplex = DCELError+  validateComplex _ = []++edgeContainsVertex ::+  Triangulation mode vertex directed undirected face ->+  VertexId ->+  UndirectedEdgeId ->+  Bool+edgeContainsVertex triangulation vertex edge =+  let (sourceVertex, targetVertex) = Dcel.undirectedEndpoints triangulation edge+   in vertex == sourceVertex || vertex == targetVertex
+ src-cell-complex/Moonlight/Triangulation/LabelledComplex.hs view
@@ -0,0 +1,131 @@+-- | Homology interpretations of canonical labelled planar complexes.+--+-- 'PlanarComplex' owns simplex identity and downward closure. This module+-- materializes that admitted section once; Homology remains the sole owner of+-- chain-law and filtration-law validation.+module Moonlight.Triangulation.LabelledComplex+  ( PlanarComplexInterpretationError (..)+  , finitePlanarComplex+  , filteredPlanarComplex+  )+where++import Data.Bifunctor (first)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Vector qualified as Vector+import Moonlight.Homology.Boundary+  ( BoundaryIncidence+  , FiniteChainComplex+  , emptyBoundaryIncidence+  , emptyBoundaryIncidenceOf+  , materializeIncidenceBoundary+  , mkFiniteChainComplexChecked+  )+import Moonlight.Homology.Chain+  ( HomologicalDegree (..)+  , HomologyFailure+  )+import Moonlight.Homology.Persistence+  ( FilteredFiniteChainComplex+  , mkFilteredFiniteChainComplex+  )+import Moonlight.Homology.Topology (BasisCellRef (..))+import Moonlight.Triangulation.Simplex+  ( PlanarComplex+  , PlanarSimplex+  , SimplexDimension (..)+  , planarComplexBasisAt+  , planarSimplexBoundary+  )++-- | Typed obstructions at the labelled-complex/Homology boundary.+data PlanarComplexInterpretationError label+  = PlanarComplexChainInvalid !HomologyFailure+  | PlanarComplexBirthUnexpected !(PlanarSimplex label)+  | PlanarComplexFiltrationInvalid !HomologyFailure+  deriving stock (Eq, Show)++-- | Canonical integral chains in ascending labelled-simplex order.+finitePlanarComplex+  :: Ord label+  => PlanarComplex label+  -> Either (PlanarComplexInterpretationError label) (FiniteChainComplex Int)+finitePlanarComplex complexValue = do+  degreeOneBoundary <-+    first PlanarComplexChainInvalid+      ( materializeIncidenceBoundary+          planarSimplexBoundary+          (basisList SimplexDimension1 complexValue)+          (basisList SimplexDimension0 complexValue)+      )+  degreeTwoBoundary <-+    first PlanarComplexChainInvalid+      ( materializeIncidenceBoundary+          planarSimplexBoundary+          (basisList SimplexDimension2 complexValue)+          (basisList SimplexDimension1 complexValue)+      )+  let degreeZeroBoundary :: BoundaryIncidence Int+      degreeZeroBoundary =+        emptyBoundaryIncidenceOf+          (fromIntegral (Vector.length (planarComplexBasisAt SimplexDimension0 complexValue)))+          0+      boundaryAt (HomologicalDegree degreeIndex) =+        case degreeIndex of+          0 -> degreeZeroBoundary+          1 -> degreeOneBoundary+          2 -> degreeTwoBoundary+          _ -> emptyBoundaryIncidence+  first PlanarComplexChainInvalid+    (mkFiniteChainComplexChecked (HomologicalDegree 2) boundaryAt)++-- | Add exact births to the admitted complex. Homology validates uniqueness,+-- total coverage, and every boundary inequality; this interpreter deliberately+-- does not duplicate those laws.+filteredPlanarComplex+  :: (Ord label, Ord filtration)+  => PlanarComplex label+  -> Map (PlanarSimplex label) filtration+  -> Either+      (PlanarComplexInterpretationError label)+      (FilteredFiniteChainComplex filtration Int)+filteredPlanarComplex complexValue births = do+  finite <- finitePlanarComplex complexValue+  assignments <- traverse birthAssignment (Map.toAscList births)+  first PlanarComplexFiltrationInvalid+    (mkFilteredFiniteChainComplex finite assignments)+ where+  basisReferences = planarBasisReferences complexValue+  birthAssignment (simplex, birthValue) =+    maybe+      (Left (PlanarComplexBirthUnexpected simplex))+      (Right . (,birthValue))+      (Map.lookup simplex basisReferences)++planarBasisReferences+  :: Ord label+  => PlanarComplex label+  -> Map (PlanarSimplex label) BasisCellRef+planarBasisReferences complexValue =+  Map.unions+    [ referencesAt 0 SimplexDimension0+    , referencesAt 1 SimplexDimension1+    , referencesAt 2 SimplexDimension2+    ]+ where+  referencesAt degreeValue dimension =+    Map.fromDistinctAscList+      ( zipWith+          (\basisIndex simplex ->+              (simplex, BasisCellRef (HomologicalDegree degreeValue) basisIndex)+          )+          [0 ..]+          (basisList dimension complexValue)+      )++basisList+  :: SimplexDimension+  -> PlanarComplex label+  -> [PlanarSimplex label]+basisList dimension = Vector.toList . planarComplexBasisAt dimension
+ src-core/Moonlight/Triangulation/Internal/BoxedPaged.hs view
@@ -0,0 +1,452 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}++module Moonlight.Triangulation.Internal.BoxedPaged+  ( BoxedPaged+  , MutableBoxedPaged+  , BoxedStorageError (..)+  , emptyBoxedPaged+  , boxedFill+  , boxedDefaulted+  , boxedMaterializedPageCount+  , boxedPagedLength+  , boxedUnsafeIndex+  , boxedFromVector+  , boxedToVector+  , thawBoxedPaged+  , readMutableBoxedPublicationStats+  , readBoxedPaged+  , writeBoxedPaged+  , resetBoxedRange+  , boxedThawPristine+  , freezeBoxedPaged+  , boxedUpdate+  ) where++import Control.DeepSeq (NFData)+import Control.Monad (when)+import Control.Monad.ST (ST)+import Data.Bits (shiftL, shiftR, (.&.))+import Data.Foldable (traverse_)+import qualified Data.IntMap.Strict as IntMap+import qualified Data.List as List+import Data.STRef+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import Moonlight.Triangulation.Internal.PageDirectory+import Moonlight.Triangulation.Internal.Paged+  ( PublicationStats (..)+  , TransactionShape (..)+  , addPublicationStats+  , emptyPublicationStats+  )++import GHC.Generics (Generic)++-- | A paged payload store in which an absent page means every slot in it holds+-- the fill. The fill belongs to the store rather than to a thaw of it: a+-- payload component either has a default that new elements inherit — the three+-- element payloads do — or it has none and every slot must be written before it+-- is read, which is the vertex component, whose payloads arrive with it.+--+-- The near-universal instantiation is @() () ()@, and under an unconditional+-- representation that costs one pointer per directed edge, undirected edge and+-- face, all aimed at the same closure. Here it costs nothing: an element+-- created at its default writes no slot, so no page is ever materialized.+data BoxedStorage a+  = DenseBoxedPages !(V.Vector (V.Vector a))+  | DefaultedBoxedPages !a !(PageDirectory (V.Vector a))+  deriving stock (Generic, Functor)+  deriving anyclass (NFData)++data BoxedPaged a = BoxedPaged+  { boxedLength :: {-# UNPACK #-} !Int+  , boxedStorage :: !(BoxedStorage a)+  }+  deriving stock (Generic, Functor)+  deriving anyclass (NFData)++data BoxedStorageError+  = BoxedFreezeLengthNegative {-# UNPACK #-} !Int+  | BoxedFreezeDensePageMissing {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++boxedFill :: BoxedPaged a -> Maybe a+boxedFill BoxedPaged{boxedStorage = DenseBoxedPages _} = Nothing+boxedFill BoxedPaged{boxedStorage = DefaultedBoxedPages fill _} = Just fill++-- | Number of materialized payload pages.  Defaulted stores report only their+-- sparse directory; an absent page is the fill and was never copied.+boxedMaterializedPageCount :: BoxedPaged a -> Int+boxedMaterializedPageCount BoxedPaged{boxedStorage} = case boxedStorage of+  DenseBoxedPages pages -> V.length pages+  DefaultedBoxedPages _ pages -> directorySize pages+{-# INLINE boxedMaterializedPageCount #-}++-- | A length-bearing payload section whose every slot is its default.  The+-- section deliberately owns no materialized pages; a geometry-only+-- publication can therefore carry an arbitrarily large unit payload plane+-- without forcing a dense boxed vector at its next freeze.+boxedDefaulted :: a -> Int -> BoxedPaged a+boxedDefaulted fill length' =+  BoxedPaged+    { boxedLength = max 0 length'+    , boxedStorage = DefaultedBoxedPages fill emptyDirectory+    }++-- Structural equality would distinguish a store that materialized a page of+-- defaults from one that did not, and the two are the same store. Equality is+-- therefore what can be observed: the length, the fill every unwritten slot+-- will report, and the sequence itself.+instance Eq a => Eq (BoxedPaged a) where+  left == right =+    boxedLength left == boxedLength right+      && boxedFill left == boxedFill right+      && boxedToVector left == boxedToVector right++instance Show a => Show (BoxedPaged a) where+  showsPrec precedence paged =+    showParen (precedence > 10) $+      showString "BoxedPaged "+        . showsPrec 11 (boxedFill paged)+        . showString " "+        . showsPrec 11 (boxedToVector paged)++data MutableBoxedPaged s a = MutableBoxedPaged+  { mutableBoxedBase :: !(BoxedPaged a)+  , mutableBoxedDirty :: !(STRef s (IntMap.IntMap (MV.MVector s a)))+  , mutableBoxedStats :: !(Maybe (STRef s PublicationStats))+  , -- | The thaw found no materialized page. Together with an empty dirty set+    -- this says every slot in the store reports the fill, which is the state a+    -- payload component nobody writes stays in for the whole transaction —+    -- the near-universal @() () ()@ case. Read through 'boxedThawPristine'.+    mutableBoxedPristineBase :: !Bool+  }++pageBits :: Int+pageBits = 8+{-# INLINE pageBits #-}++pageSize :: Int+pageSize = 1 `shiftL` pageBits+{-# INLINE pageSize #-}++-- Every index this store decomposes is an element identifier or a walk over+-- one, so the signed division a 'quotRem' would emit corrects for a sign that+-- cannot occur.+pageOf :: Int -> Int+pageOf index = index `shiftR` pageBits+{-# INLINE pageOf #-}++offsetOf :: Int -> Int+offsetOf index = index .&. (pageSize - 1)+{-# INLINE offsetOf #-}++emptyBoxedPaged :: Maybe a -> BoxedPaged a+emptyBoxedPaged fill =+  BoxedPaged+    0+    (case fill of+       Nothing -> DenseBoxedPages V.empty+       Just value -> DefaultedBoxedPages value emptyDirectory)++boxedPagedLength :: BoxedPaged a -> Int+boxedPagedLength = boxedLength+{-# INLINE boxedPagedLength #-}++-- | Index with a handle already admitted by the owning triangulation. Dense+-- stores carry every live page explicitly; defaulted stores can answer an+-- absent or short page from their stored default. The handle domain is owned+-- by the DCEL, so this raw kernel performs no second, disagreeing bounds check.+boxedUnsafeIndex :: BoxedPaged a -> Int -> a+boxedUnsafeIndex BoxedPaged{boxedStorage} index =+  let !page = pageOf index+      !offset = offsetOf index+   in case boxedStorage of+        DenseBoxedPages pages ->+          V.unsafeIndex (V.unsafeIndex pages page) offset+        DefaultedBoxedPages fill pages ->+          case lookupDirectory page pages of+            Just values | offset < V.length values -> V.unsafeIndex values offset+            _ -> fill+{-# INLINE boxedUnsafeIndex #-}++boxedFromVector :: Maybe a -> V.Vector a -> BoxedPaged a+boxedFromVector fill values =+  let !chunks =+        List.unfoldr+          (\offset ->+             if offset >= V.length values+               then Nothing+               else+                 let !page = pageOf offset+                     !count = min pageSize (V.length values - offset)+                     !chunk = V.slice offset count values+                  in Just ((page, chunk), offset + count))+          0+   in+  BoxedPaged+    { boxedLength = V.length values+    , boxedStorage =+        case fill of+          Nothing -> DenseBoxedPages (V.fromList (map snd chunks))+          Just value -> DefaultedBoxedPages value (directoryFromAscList chunks)+    }++-- Resolved a page at a time. Asking the directory per element paid a descent+-- for every slot of a run the descent had already found.+boxedToVector :: forall a. BoxedPaged a -> V.Vector a+boxedToVector BoxedPaged{boxedLength, boxedStorage}+  | boxedLength <= 0 = V.empty+  | otherwise = case boxedStorage of+      DenseBoxedPages pages -> V.take boxedLength (V.concat (V.toList pages))+      DefaultedBoxedPages fill pages ->+        V.concat (map (pageRun fill pages) [0 .. pageOf (boxedLength - 1)])+ where+  pageRun :: a -> PageDirectory (V.Vector a) -> Int -> V.Vector a+  pageRun fill pages page =+    let !base = page `shiftL` pageBits+        !width = min pageSize (boxedLength - base)+     in case lookupDirectory page pages of+          Just values+            | V.length values >= width -> V.slice 0 width values+            | otherwise -> values V.++ V.replicate (width - V.length values) fill+          Nothing -> V.replicate width fill++-- The fill comes from the store, not from the caller. A thaw that took it as an+-- argument obliged every call site to name the right one, and 'boxedUpdate' —+-- which passed the value being written — named the wrong one. That was harmless+-- only while pages were never absent.+thawBoxedPaged :: TransactionShape -> BoxedPaged a -> ST s (MutableBoxedPaged s a)+thawBoxedPaged shape base = do+  mutableBoxedDirty <- newSTRef IntMap.empty+  mutableBoxedStats <-+    case shape of+      DenseTransaction -> pure Nothing+      LocalTransaction -> Just <$> newSTRef emptyPublicationStats+  pure+    MutableBoxedPaged+      { mutableBoxedBase = base+      , mutableBoxedDirty+      , mutableBoxedStats+      , mutableBoxedPristineBase = case boxedStorage base of+          DenseBoxedPages pages -> V.null pages+          DefaultedBoxedPages _ pages -> directorySize pages == 0+      }++readBoxedPaged :: MutableBoxedPaged s a -> Int -> ST s a+readBoxedPaged MutableBoxedPaged{mutableBoxedBase, mutableBoxedDirty} index = do+  dirty <- readSTRef mutableBoxedDirty+  let !page = pageOf index+      !offset = offsetOf index+  case IntMap.lookup page dirty of+    Just values -> MV.unsafeRead values offset+    Nothing -> case boxedStorage mutableBoxedBase of+      DenseBoxedPages pages ->+        pure (V.unsafeIndex (V.unsafeIndex pages page) offset)+      DefaultedBoxedPages fill pages ->+        case lookupDirectory page pages of+          Just values | offset < V.length values -> pure (V.unsafeIndex values offset)+          _ -> pure fill+{-# INLINE readBoxedPaged #-}++writeBoxedPaged :: MutableBoxedPaged s a -> Int -> a -> ST s ()+writeBoxedPaged paged index value = do+  let !page = pageOf index+      !offset = offsetOf index+  values <- ensureMutableBoxedPage paged page+  MV.unsafeWrite values offset value+{-# INLINE writeBoxedPaged #-}++-- | Whether the thaw found no materialized page. With no writer into the+-- element payload planes inside a transaction — there is none; they are+-- written only through the persistent setters, outside one — this answers for+-- the whole transaction that every slot reports the fill, so a rewrite has+-- nothing to return and a relocation has nothing to move. It is why the+-- near-universal @() () ()@ mesh pays a predictable branch and no page.+boxedThawPristine :: MutableBoxedPaged s a -> Bool+boxedThawPristine = mutableBoxedPristineBase+{-# INLINE boxedThawPristine #-}++-- | Return a contiguous run of slots to the store's fill. A slot no write has+-- reached already reports the fill, so a page absent from both the base and the+-- dirty set is left absent: recycling an element at its default keeps the store+-- sparse. Only a page holding written values is materialized and overwritten.+resetBoxedRange :: MutableBoxedPaged s a -> a -> Int -> Int -> ST s ()+resetBoxedRange paged@MutableBoxedPaged{mutableBoxedBase, mutableBoxedDirty} fill start count+  | count <= 0 = pure ()+  | otherwise = traverse_ resetChunk chunkStarts+ where+  !end = start + count+  chunkStarts =+    List.unfoldr+      (\index ->+         if index >= end+           then Nothing+           else+             let !width = min (pageSize - offsetOf index) (end - index)+              in Just ((index, width), index + width))+      start++  resetChunk (index, width) = do+    dirty <- readSTRef mutableBoxedDirty+    let !page = pageOf index+        !offset = offsetOf index+        !written =+          IntMap.member page dirty+            || case boxedStorage mutableBoxedBase of+              DenseBoxedPages pages ->+                page < V.length pages+                  && offset < V.length (V.unsafeIndex pages page)+              DefaultedBoxedPages _ pages ->+                case lookupDirectory page pages of+                  Just values -> offset < V.length values+                  Nothing -> False+    when written $ do+      values <- ensureMutableBoxedPage paged page+      MV.set (MV.slice offset width values) fill++ensureMutableBoxedPage :: forall s a. MutableBoxedPaged s a -> Int -> ST s (MV.MVector s a)+ensureMutableBoxedPage MutableBoxedPaged{mutableBoxedBase, mutableBoxedDirty, mutableBoxedStats} page = do+  dirty <- readSTRef mutableBoxedDirty+  case IntMap.lookup page dirty of+    Just values -> pure values+    Nothing -> do+      -- Copying a page slot by slot writes every element twice — once to+      -- establish the fill and once to overwrite it — and pays a write barrier+      -- per store. A full page is one thaw; a short tail page fills only the+      -- slots the base does not reach. This is the same shape the unboxed+      -- store already uses.+      (values, copiedCells) <- case boxedStorage mutableBoxedBase of+        DenseBoxedPages pages+          | page < V.length pages -> copyExisting (V.unsafeIndex pages page)+          | otherwise -> do+              vector <- MV.new pageSize+              pure (vector, 0)+        DefaultedBoxedPages fill pages ->+          case lookupDirectory page pages of+            Just old -> copyExisting old+            Nothing -> do+              vector <- MV.replicate pageSize fill+              pure (vector, 0)+      writeSTRef mutableBoxedDirty $! IntMap.insert page values dirty+      let !basePageCount = boxedPageCount mutableBoxedBase+          !basePage = page < basePageCount+      recordPublicationStats+        mutableBoxedStats+        (emptyPublicationStats+             { publicationBoxedBasePageOpens = if basePage then 1 else 0+             , publicationBoxedDirtyBasePages = if basePage then 1 else 0+             , publicationBoxedDirtyAppendedPages = if basePage then 0 else 1+             , publicationBoxedCopiedCells = copiedCells+             })+      pure values+ where+  boxedPageCount :: BoxedPaged a -> Int+  boxedPageCount base+    | boxedLength base <= 0 = 0+    | otherwise = pageOf (boxedLength base - 1) + 1++  copyExisting :: V.Vector a -> ST s (MV.MVector s a, Int)+  copyExisting old+    | V.length old == pageSize = (, V.length old) <$> V.thaw old+    | otherwise = do+        vector <- case boxedStorage mutableBoxedBase of+          DenseBoxedPages _ -> MV.new pageSize+          DefaultedBoxedPages fill _ -> MV.replicate pageSize fill+        V.copy (MV.slice 0 (V.length old) vector) old+        pure (vector, V.length old)++recordPublicationStats :: Maybe (STRef s PublicationStats) -> PublicationStats -> ST s ()+recordPublicationStats Nothing _ = pure ()+recordPublicationStats (Just statsRef) delta = modifySTRef' statsRef (addPublicationStats delta)+{-# INLINE recordPublicationStats #-}++freezeBoxedPaged :: forall s a. Int -> MutableBoxedPaged s a -> ST s (Either BoxedStorageError (BoxedPaged a))+freezeBoxedPaged length' MutableBoxedPaged{mutableBoxedBase, mutableBoxedDirty, mutableBoxedStats}+  | length' < 0 = pure (Left (BoxedFreezeLengthNegative length'))+  | otherwise = do+      dirty <- readSTRef mutableBoxedDirty+      frozenDirty <- traverse V.unsafeFreeze dirty+      case boxedStorage mutableBoxedBase of+        DenseBoxedPages _ ->+          recordPublicationStats+            mutableBoxedStats+            (emptyPublicationStats+                 { publicationBoxedBasePageEnumerations = pageCount+                 , publicationBoxedBasePageFreezes = pageCount+                 })+        DefaultedBoxedPages _ _ -> pure ()+      pure $ case boxedStorage mutableBoxedBase of+        DenseBoxedPages basePages -> do+          pages <-+            traverse+              (densePage frozenDirty basePages)+              [0 .. pageCount - 1]+          pure+            BoxedPaged+              { boxedLength = length'+              , boxedStorage = DenseBoxedPages (V.fromList pages)+              }+        DefaultedBoxedPages fill basePages ->+          let !merged =+                List.foldl'+                  (\pages (page, values) -> insertDirectory page values pages)+                  basePages+                  (IntMap.toAscList frozenDirty)+              !kept = directoryRestrict pageCount merged+              !trimmed = case directoryLookupMax kept of+                Nothing -> kept+                Just (lastPage, values) ->+                  let !lastLength = length' - lastPage * pageSize+                   in if lastLength < V.length values+                        then insertDirectory lastPage (V.take lastLength values) kept+                        else kept+           in Right+                BoxedPaged+                  { boxedLength = length'+                  , boxedStorage = DefaultedBoxedPages fill trimmed+                }+ where+  !pageCount = if length' <= 0 then 0 else pageOf (length' - 1) + 1++  densePage+    :: IntMap.IntMap (V.Vector a)+    -> V.Vector (V.Vector a)+    -> Int+    -> Either BoxedStorageError (V.Vector a)+  densePage frozenDirty basePages page =+    let !width = min pageSize (length' - page * pageSize)+     in case IntMap.lookup page frozenDirty of+          Just values -> Right (V.take width values)+          Nothing -> case basePages V.!? page of+            Just values -> Right (V.take width values)+            Nothing -> Left (BoxedFreezeDensePageMissing page pageCount)++readMutableBoxedPublicationStats :: MutableBoxedPaged s a -> ST s PublicationStats+readMutableBoxedPublicationStats MutableBoxedPaged{mutableBoxedStats} =+  maybe (pure emptyPublicationStats) readSTRef mutableBoxedStats++boxedUpdate :: Int -> a -> BoxedPaged a -> BoxedPaged a+boxedUpdate index value source@BoxedPaged{boxedStorage} =+  source{boxedStorage = updateStorage boxedStorage}+ where+  !page = pageOf index+  !offset = offsetOf index++  updateStorage (DenseBoxedPages pages) =+    let !values = V.unsafeIndex pages page+        !updated = V.modify (\mutable -> MV.unsafeWrite mutable offset value) values+     in DenseBoxedPages (V.modify (\mutable -> MV.unsafeWrite mutable page updated) pages)+  updateStorage (DefaultedBoxedPages fill pages) =+    let !values = case lookupDirectory page pages of+          Just existing+            | V.length existing == pageSize -> existing+            | otherwise -> existing V.++ V.replicate (pageSize - V.length existing) fill+          Nothing -> V.replicate pageSize fill+        !updated = V.modify (\mutable -> MV.unsafeWrite mutable offset value) values+     in DefaultedBoxedPages fill (insertDirectory page updated pages)
+ src-core/Moonlight/Triangulation/Internal/Dyadic.hs view
@@ -0,0 +1,747 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++module Moonlight.Triangulation.Internal.Dyadic+  ( exactOrientDet+  , exactOrientSignDouble+  , exactInCircleDet+  , exactQuarterSquaredDistanceRational+  , exactCircumradiusSquaredRational+  , exactCircumradiusSquaredWithin+  , exactBarycentricDeterminants+  , exactDiametralDot+  , integerRatioToDouble+  , integerBitLength+  ) where++import Data.Bits+  ( countLeadingZeros+  , countTrailingZeros+  , finiteBitSize+  , shiftL+  , shiftR+  )+import qualified Data.List as List+import Data.Word (Word64)+import GHC.Exts (Int (I#), (+#))+import GHC.Integer.Logarithms (integerLog2#)+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactArithmeticError+  , ExactRational+  , exactRationalFromDyadic+  , exactRationalFromDyadicRatio+  )+#if WORD_SIZE_IN_BITS == 64+import GHC.Exts+  ( Double (D#)+  , Double#+  , Int#+  , Word#+  , and#+  , castDoubleToWord64#+  , eqWord#+  , gtWord#+  , int2Word#+  , isTrue#+  , or#+  , plusWord#+  , plusWord2#+  , subWordC#+  , timesWord2#+  , uncheckedShiftL#+  , uncheckedShiftRL#+  , word2Int#+  , word64ToWord#+  , (*#)+  , (-#)+  , (<=#)+  , (==#)+  , (>#)+  , (>=#)+  )+#endif++-- Every finite binary64 value is a dyadic rational. Aligning all mantissas to+-- one exponent gives exact integer predicates without constructing Rational+-- expression trees.+type Decoded = (Integer, Int)++commonExponent :: [Decoded] -> Int+commonExponent = List.foldl' step 0+ where+  step :: Int -> Decoded -> Int+  step !current (!mantissa, !power)+    | mantissa == 0 = current+    | otherwise = min current power+{-# INLINE commonExponent #-}++alignDecoded :: Int -> Decoded -> Integer+alignDecoded !power (!mantissa, !sourcePower)+  | mantissa == 0 = 0+  | otherwise = mantissa `shiftL` (sourcePower - power)+{-# INLINE alignDecoded #-}++decodedExponentFloor :: Decoded -> Int+decodedExponentFloor (mantissa, power)+  | mantissa == 0 = 0+  | otherwise = min 0 power+{-# INLINE decodedExponentFloor #-}++commonExponent4 :: Decoded -> Decoded -> Decoded -> Decoded -> Int+commonExponent4 firstValue secondValue thirdValue fourthValue =+  min+    (min (decodedExponentFloor firstValue) (decodedExponentFloor secondValue))+    (min (decodedExponentFloor thirdValue) (decodedExponentFloor fourthValue))+{-# INLINE commonExponent4 #-}++commonExponent6+  :: Decoded+  -> Decoded+  -> Decoded+  -> Decoded+  -> Decoded+  -> Decoded+  -> Int+commonExponent6 firstValue secondValue thirdValue fourthValue fifthValue sixthValue =+  min+    ( commonExponent4+        firstValue+        secondValue+        thirdValue+        fourthValue+    )+    (min (decodedExponentFloor fifthValue) (decodedExponentFloor sixthValue))+{-# INLINE commonExponent6 #-}++aligned4+  :: Double -> Double -> Double -> Double+  -> (Int, Integer, Integer, Integer, Integer)+aligned4 a b c d =+  let !da = decodeFloat a+      !db = decodeFloat b+      !dc = decodeFloat c+      !dd = decodeFloat d+      !power = commonExponent4 da db dc dd+   in ( power+      , alignDecoded power da+      , alignDecoded power db+      , alignDecoded power dc+      , alignDecoded power dd+      )+{-# INLINE aligned4 #-}++aligned6+  :: Double -> Double -> Double -> Double -> Double -> Double+  -> (Int, Integer, Integer, Integer, Integer, Integer, Integer)+aligned6 a b c d e f =+  let !da = decodeFloat a+      !db = decodeFloat b+      !dc = decodeFloat c+      !dd = decodeFloat d+      !de = decodeFloat e+      !df = decodeFloat f+      !power = commonExponent6 da db dc dd de df+   in ( power+      , alignDecoded power da+      , alignDecoded power db+      , alignDecoded power dc+      , alignDecoded power dd+      , alignDecoded power de+      , alignDecoded power df+      )++aligned8+  :: Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double+  -> (Integer, Integer, Integer, Integer, Integer, Integer, Integer, Integer)+aligned8 a b c d e f g h =+  let !da = decodeFloat a+      !db = decodeFloat b+      !dc = decodeFloat c+      !dd = decodeFloat d+      !de = decodeFloat e+      !df = decodeFloat f+      !dg = decodeFloat g+      !dh = decodeFloat h+      !power = commonExponent [da, db, dc, dd, de, df, dg, dh]+   in ( alignDecoded power da+      , alignDecoded power db+      , alignDecoded power dc+      , alignDecoded power dd+      , alignDecoded power de+      , alignDecoded power df+      , alignDecoded power dg+      , alignDecoded power dh+      )++exactOrientDet+  :: Double -> Double -> Double -> Double -> Double -> Double -> Integer+exactOrientDet ax ay bx by cx cy =+  let (!_, !iax, !iay, !ibx, !iby, !icx, !icy) = aligned6 ax ay bx by cx cy+      !acx = iax - icx+      !acy = iay - icy+      !bcx = ibx - icx+      !bcy = iby - icy+   in acx * bcy - acy * bcx++-- | One quarter of the exact squared distance between two finite binary64+-- points. Alpha's Gabriel-edge birth needs this value directly, so the dyadic+-- exponent absorbs the quarter before the single rational normalization.+exactQuarterSquaredDistanceRational+  :: Double -> Double -> Double -> Double -> ExactRational+exactQuarterSquaredDistanceRational ax ay bx by =+  let (!coordinatePower, !iax, !iay, !ibx, !iby) = aligned4 ax ay bx by+      !deltaX = ibx - iax+      !deltaY = iby - iay+      !squaredDistance = deltaX * deltaX + deltaY * deltaY+   in exactRationalFromDyadic squaredDistance (2 * coordinatePower - 2)+{-# INLINE exactQuarterSquaredDistanceRational #-}++-- | Exact squared circumradius of three finite binary64 points. The local+-- dyadic section computes the integer numerator and denominator without+-- constructing intermediate ratios; descent normalizes the authoritative+-- result exactly once. A degenerate triangle is the typed zero-divisor+-- obstruction from 'ExactRational'.+exactCircumradiusSquaredRational+  :: Double -> Double -> Double -> Double -> Double -> Double+  -> Either ExactArithmeticError ExactRational+exactCircumradiusSquaredRational 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+      !radiusDenominator = 4 * determinant * determinant+   in exactRationalFromDyadicRatio+        radiusNumerator+        radiusDenominator+        (2 * coordinatePower)+{-# INLINE exactCircumradiusSquaredRational #-}++-- | 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+exactInCircleDet ax ay bx by cx cy dx dy =+  let (!iax, !iay, !ibx, !iby, !icx, !icy, !idx, !idy) =+        aligned8 ax ay bx by cx cy dx dy+      !adx = iax - idx+      !ady = iay - idy+      !bdx = ibx - idx+      !bdy = iby - idy+      !cdx = icx - idx+      !cdy = icy - idy+      !abdet = adx * bdy - bdx * ady+      !bcdet = bdx * cdy - cdx * bdy+      !cadet = cdx * ady - adx * cdy+      !alift = adx * adx + ady * ady+      !blift = bdx * bdx + bdy * bdy+      !clift = cdx * cdx + cdy * cdy+   in alift * bcdet + blift * cadet + clift * abdet++exactDiametralDot+  :: Double -> Double -> Double -> Double -> Double -> Double -> Integer+exactDiametralDot ax ay bx by px py =+  let (!_, !iax, !iay, !ibx, !iby, !ipx, !ipy) = aligned6 ax ay bx by px py+      !pax = ipx - iax+      !pay = ipy - iay+      !pbx = ipx - ibx+      !pby = ipy - iby+   in pax * pbx + pay * pby++exactBarycentricDeterminants+  :: Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double+  -> (Integer, Integer, Integer, Integer)+exactBarycentricDeterminants ax ay bx by cx cy qx qy =+  let (!iax, !iay, !ibx, !iby, !icx, !icy, !iqx, !iqy) =+        aligned8 ax ay bx by cx cy qx qy+      determinant :: Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer+      determinant px py rx ry sx sy =+        let !psx = px - sx+            !psy = py - sy+            !rsx = rx - sx+            !rsy = ry - sy+         in psx * rsy - psy * rsx+      !denominator = determinant iax iay ibx iby icx icy+      !weightA = determinant iqx iqy ibx iby icx icy+      !weightB = determinant iax iay iqx iqy icx icy+      !weightC = determinant iax iay ibx iby iqx iqy+   in (denominator, weightA, weightB, weightC)++integerRatioToDouble :: Integer -> Integer -> Double+integerRatioToDouble numerator denominator+  | denominator == 0 = 0 / 0+  | numerator == 0 = 0+  | otherwise =+      let !precision = floatDigits (0 :: Double)+          !numeratorMagnitude = abs numerator+          !denominatorMagnitude = abs denominator+          !numeratorBits = integerBitLength numeratorMagnitude+          !denominatorBits = integerBitLength denominatorMagnitude+          !numeratorShift = max 0 (numeratorBits - precision)+          !denominatorShift = max 0 (denominatorBits - precision)+          !scaledNumerator = fromInteger (numeratorMagnitude `shiftR` numeratorShift)+          !scaledDenominator = fromInteger (denominatorMagnitude `shiftR` denominatorShift)+          !magnitude = scaleFloat (numeratorShift - denominatorShift) (scaledNumerator / scaledDenominator)+          !sameSign = (numerator < 0) == (denominator < 0)+       in if sameSign then magnitude else negate magnitude++integerBitLength :: Integer -> Int+integerBitLength value+  | value <= 0 = 0+  | otherwise = I# (integerLog2# value +# 1#)+{-# INLINE integerBitLength #-}++-- ---------------------------------------------------------------------------+-- Fixed-precision exact orient sign for Double.+--+-- The generic dyadic path answers every exact query with arbitrary-precision+-- Integers: six decodes, one alignment, and two multiplies, each allocating.+-- Practical inputs have an exponent spread small enough that the determinant's+-- exact sign is decided by 128-bit differences and 256-bit products in machine+-- words, without a single heap object. 'exactOrientSignDouble' takes that path+-- and falls back to 'exactOrientDet' the moment an operand is non-finite or an+-- alignment shift would outgrow the fixed width. The two agree by+-- construction: both compute the sign of the same integer determinant.+--+-- The fixed-width worker reads a Double as one machine word and aligns+-- mantissas across a 128-bit pair, so it is only meaningful where a machine+-- word is 64 bits wide. On a narrower target the same sign is taken from the+-- arbitrary-precision determinant directly, which is the branch this path+-- already falls back to whenever an alignment shift would outgrow the width.++#if WORD_SIZE_IN_BITS == 64++exactOrientSignDouble+  :: Double -> Double -> Double -> Double -> Double -> Double -> Ordering+exactOrientSignDouble ax ay bx by cx cy =+  case ax of+    D# axw ->+      case ay of+        D# ayw ->+          case bx of+            D# bxw ->+              case by of+                D# byw ->+                  case cx of+                    D# cxw ->+                      case cy of+                        D# cyw ->+                          case orientSignWorker axw ayw bxw byw cxw cyw of+                            2# -> compare (exactOrientDet ax ay bx by cx cy) 0+                            0# -> EQ+                            sign ->+                              case sign ># 0# of+                                1# -> GT+                                _ -> LT+{-# NOINLINE exactOrientSignDouble #-}++-- Decode a Double into sign bit (0/1), mantissa, and power-of-two exponent+-- with value = (-1)^sign * mantissa * 2^exponent. Zero decodes to a zero+-- mantissa; subnormals decode without a hidden bit. The fourth component is 1+-- when the value is finite and 0 when it is not.+decodeExact :: Double# -> (# Int#, Word#, Int#, Int# #)+decodeExact d =+  case word64ToWord# (castDoubleToWord64# d) of+    bits ->+      let neg = word2Int# (uncheckedShiftRL# bits 63#)+          exponentField = word2Int# (and# (uncheckedShiftRL# bits 52#) 2047##)+          mantissaField = and# bits 4503599627370495##+       in case exponentField of+            0# -> (# neg, mantissaField, -1074#, 1# #)+            2047# -> (# neg, mantissaField, 0#, 0# #)+            raw -> (# neg, or# mantissaField 4503599627370496##, raw -# 1075#, 1# #)++-- A mantissa of at most 53 bits shifted left by at most 73 bits: the pair+-- (high, low) of a value below 2^126.+shiftMantissa :: Word# -> Int# -> (# Word#, Word# #)+shiftMantissa mantissa k =+  case k >=# 64# of+    1# -> (# uncheckedShiftL# mantissa (k -# 64#), 0## #)+    _ ->+      case k ==# 0# of+        1# -> (# 0##, mantissa #)+        _ ->+          (#+            uncheckedShiftRL# mantissa (64# -# k),+            uncheckedShiftL# mantissa k+          #)++-- The exact sign and 128-bit magnitude of sa*ma*2^ea - sc*mc*2^ec, aligned+-- to the caller-supplied floor exponent, as (sign, high, low, status) with+-- sign in {-1, 0, 1} and status 1 when an alignment shift outgrows the fixed+-- width. The floor never exceeds the exponent of a nonzero operand, so every+-- shift is non-negative; one shared floor is what makes the four differences+-- of one determinant comparable after multiplication.+differenceExact+  :: Int# -> Word# -> Int# -> Int# -> Word# -> Int# -> Int# -> (# Int#, Word#, Word#, Int# #)+differenceExact nega ma ea negc mc ec emin =+  case ma of+    0## ->+      case mc of+        0## -> (# 0#, 0##, 0##, 0# #)+        _ -> aligned (negateSign (positiveSign negc)) mc (ec -# emin)+    _ ->+      case mc of+        0## -> aligned (positiveSign nega) ma (ea -# emin)+        _ ->+          case ea -# emin of+            da ->+              case da ># 73# of+                1# -> (# 0#, 0##, 0##, 1# #)+                _ ->+                  case ec -# emin of+                    dc ->+                      case dc ># 73# of+                        1# -> (# 0#, 0##, 0##, 1# #)+                        _ ->+                          case shiftMantissa ma da of+                            (# ahi, alo #) ->+                              case shiftMantissa mc dc of+                                (# chi, clo #) ->+                                  case nega ==# negc of+                                    1# ->+                                      -- Same operand signs: subtract magnitudes.+                                      case compareWord2 ahi alo chi clo of+                                        0# -> (# 0#, 0##, 0##, 0# #)+                                        1# ->+                                          case subtractWord2 ahi alo chi clo of+                                            (# hi, lo #) -> (# positiveSign nega, hi, lo, 0# #)+                                        _ ->+                                          case subtractWord2 chi clo ahi alo of+                                            (# hi, lo #) -> (# negateSign (positiveSign nega), hi, lo, 0# #)+                                    _ ->+                                      -- Opposite operand signs: add magnitudes.+                                      case addWord2 ahi alo chi clo of+                                        (# hi, lo #) -> (# positiveSign nega, hi, lo, 0# #)+  where+    aligned sign mantissa k =+      case k ># 73# of+        1# -> (# 0#, 0##, 0##, 1# #)+        _ ->+          case shiftMantissa mantissa k of+            (# hi, lo #) -> (# sign, hi, lo, 0# #)+    positiveSign neg = case neg of+      1# -> -1#+      _ -> 1#+    negateSign sign = case sign of+      1# -> -1#+      _ -> 1#++-- Lexicographic comparison of 128-bit magnitudes: 1, 0, or -1.+compareWord2 :: Word# -> Word# -> Word# -> Word# -> Int#+compareWord2 ahi alo chi clo =+  case eqWord# ahi chi of+    1# ->+      case eqWord# alo clo of+        1# -> 0#+        _ ->+          case gtWord# alo clo of+            1# -> 1#+            _ -> -1#+    _ ->+      case gtWord# ahi chi of+        1# -> 1#+        _ -> -1#++-- 128-bit difference of magnitudes, first operand at least the second.+subtractWord2 :: Word# -> Word# -> Word# -> Word# -> (# Word#, Word# #)+subtractWord2 ahi alo chi clo =+  case subWordC# alo clo of+    (# low, borrow #) ->+      case subWordC# ahi chi of+        (# high0, _ #) ->+          case subWordC# high0 (int2Word# borrow) of+            (# high, _ #) -> (# high, low #)++-- 128-bit sum of magnitudes each below 2^126: the total stays below 2^127 and+-- the final carry is empty by the shift bound.+addWord2 :: Word# -> Word# -> Word# -> Word# -> (# Word#, Word# #)+addWord2 ahi alo chi clo =+  case plusWord2# alo clo of+    (# carry0, low #) ->+      case plusWord2# ahi chi of+        (# _, high0 #) ->+          case plusWord2# high0 carry0 of+            (# _, high #) -> (# high, low #)++-- 128-bit by 128-bit exact product, (r3, r2, r1, r0), most significant first.+-- Each factor stays below 2^127, so the product stays below 2^254 and the top+-- accumulation cannot overflow.+multiplyWord2 :: Word# -> Word# -> Word# -> Word# -> (# Word#, Word#, Word#, Word# #)+multiplyWord2 ahi alo bhi blo =+  case timesWord2# alo blo of+    (# h00, l00 #) ->+      case timesWord2# alo bhi of+        (# h01, l01 #) ->+          case timesWord2# ahi blo of+            (# h10, l10 #) ->+              case timesWord2# ahi bhi of+                (# h11, l11 #) ->+                  case plusWord2# h00 l01 of+                    (# carryA, sumA #) ->+                      case plusWord2# sumA l10 of+                        (# carryB, r1 #) ->+                          case plusWord# carryA carryB of+                            carry2 ->+                              case plusWord2# h01 h10 of+                                (# carryC, sumC #) ->+                                  case plusWord2# sumC l11 of+                                    (# carryD, sumD #) ->+                                      case plusWord2# sumD carry2 of+                                        (# carryE, r2 #) ->+                                          case plusWord# (plusWord# carryC carryD) carryE of+                                            carry3 ->+                                              case plusWord# h11 carry3 of+                                                r3 -> (# r3, r2, r1, l00 #)++-- Lexicographic comparison of 256-bit magnitudes: 1, 0, or -1.+compareWord4+  :: Word# -> Word# -> Word# -> Word# -> Word# -> Word# -> Word# -> Word# -> Int#+compareWord4 a3 a2 a1 a0 b3 b2 b1 b0 =+  case compareWord2 a3 a2 b3 b2 of+    0# -> compareWord2 a1 a0 b1 b0+    answer -> answer++-- The exponent a mantissa contributes to the alignment floor: a zero+-- mantissa is exact at any floor and votes for the impossibly high sentinel.+floorExp :: Word# -> Int# -> Int#+floorExp mantissa power =+  case mantissa of+    0## -> 2000000#+    _ -> power++minExp :: Int# -> Int# -> Int#+minExp a b = if isTrue# (a <=# b) then a else b++orientSignWorker :: Double# -> Double# -> Double# -> Double# -> Double# -> Double# -> Int#+orientSignWorker ax ay bx by cx cy =+  case decodeExact ax of+    (# negax, max_, eax, okax #) ->+      case decodeExact ay of+        (# negay, may, eay, okay #) ->+          case decodeExact bx of+            (# negbx, mbx, ebx, okbx #) ->+              case decodeExact by of+                (# negby, mby, eby, okby #) ->+                  case decodeExact cx of+                    (# negcx, mcx, ecx, okcx #) ->+                      case decodeExact cy of+                        (# negcy, mcy, ecy, okcy #) ->+                          case okax +# okay +# okbx +# okby +# okcx +# okcy of+                            6# ->+                              -- The alignment floor is the least exponent+                              -- among nonzero mantissas; a zero mantissa is+                              -- exact at any floor and must not drag it down.+                              case floorExp max_ eax `minExp` floorExp may eay `minExp` floorExp mbx ebx `minExp` floorExp mby eby `minExp` floorExp mcx ecx `minExp` floorExp mcy ecy of+                                emin ->+                                  case differenceExact negax max_ eax negcx mcx ecx emin of+                                    (# s1, d1hi, d1lo, f1 #) ->+                                      case differenceExact negby mby eby negcy mcy ecy emin of+                                        (# s2, d2hi, d2lo, f2 #) ->+                                          case differenceExact negay may eay negcy mcy ecy emin of+                                            (# s3, d3hi, d3lo, f3 #) ->+                                              case differenceExact negbx mbx ebx negcx mcx ecx emin of+                                                (# s4, d4hi, d4lo, f4 #) ->+                                                  case f1 +# f2 +# f3 +# f4 of+                                                    0# ->+                                                      combineSigns+                                                        (s1 *# s2) d1hi d1lo d2hi d2lo+                                                        (s3 *# s4) d3hi d3lo d4hi d4lo+                                                    _ -> 2#+                            _ -> 2#+  where+    -- det = leftSign * leftProduct - rightSign * rightProduct+    combineSigns leftSign d1hi d1lo d2hi d2lo rightSign d3hi d3lo d4hi d4lo =+      case leftSign of+        0# ->+          case rightSign of+            0# -> 0#+            _ -> 0# -# rightSign+        _ ->+          case rightSign of+            0# -> leftSign+            _ ->+              case leftSign ==# rightSign of+                1# ->+                  case multiplyWord2 d1hi d1lo d2hi d2lo of+                    (# p3, p2, p1, p0 #) ->+                      case multiplyWord2 d3hi d3lo d4hi d4lo of+                        (# q3, q2, q1, q0 #) ->+                          case compareWord4 p3 p2 p1 p0 q3 q2 q1 q0 of+                            0# -> 0#+                            1# -> leftSign+                            _ -> 0# -# leftSign+                _ -> leftSign++#else++-- The narrow-word answer to the same question. 'exactOrientDet' is the+-- determinant the fixed-width worker exists to avoid allocating, not a+-- different quantity, so the two branches agree by construction.+exactOrientSignDouble+  :: Double -> Double -> Double -> Double -> Double -> Double -> Ordering+exactOrientSignDouble ax ay bx by cx cy =+  compare (exactOrientDet ax ay bx by cx cy) 0+{-# NOINLINE exactOrientSignDouble #-}++#endif
+ src-core/Moonlight/Triangulation/Internal/ExactRational.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}++-- | Normalized exact rational arithmetic without geometric dependencies.+module Moonlight.Triangulation.Internal.ExactRational+  ( ExactRational+  , ExactArithmeticError (..)+  , exactRational+  , exactRationalFromDouble+  , exactRationalFromFiniteDouble+  , exactRationalFromDyadic+  , exactRationalFromDyadicRatio+  , exactRationalFromNormalizedRatio+  , exactRationalNumerator+  , exactRationalDenominator+  , exactRationalBitWidth+  , exactRationalDenominatorBitWidth+  , exactRationalIsZero+  , exactDivide+  , exactSignum+  ) where++import Control.DeepSeq (NFData)+import Data.Bits ((.&.), shiftL, shiftR)+import Data.Ratio (Ratio, (%))+import qualified Data.Ratio as Ratio+import GHC.Generics (Generic)+import GHC.Exts (Int (I#))+import GHC.Integer.Logarithms (integerLog2#)+import GHC.Real (Ratio ((:%)))++-- | A checked wrapper around a reduced ratio with a strictly positive+-- denominator. '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+  | numerator == 0 = ExactRational (0 :% 1)+  | power >= 0 = ExactRational ((numerator `shiftL` power) :% 1)+  | otherwise =+      let denominatorPower = negate power+          removableFactor =+            min denominatorPower (integerTrailingZeroBits numerator)+          reducedNumerator = numerator `shiftR` removableFactor+          reducedDenominator =+            1 `shiftL` (denominatorPower - removableFactor)+       in ExactRational (reducedNumerator :% reducedDenominator)+{-# INLINE exactRationalFromDyadic #-}++-- | The denominator of a dyadic rational is a power of two, so its complete+-- normalization requires only the numerator's least set bit. Calling generic+-- rational GCD here merely rediscovers that closed arithmetic fact.+integerTrailingZeroBits :: Integer -> Int+integerTrailingZeroBits value =+  let magnitude = abs value+   in I# (integerLog2# (magnitude .&. negate magnitude))+{-# INLINE integerTrailingZeroBits #-}++-- | Construct @(numerator / denominator) * 2^power@ with one final rational+-- normalization. This is the publication boundary for exact dyadic kernels:+-- their integer arithmetic must not pay a greatest-common-divisor reduction+-- after every intermediate operation.+exactRationalFromDyadicRatio+  :: Integer+  -> Integer+  -> Int+  -> Either ExactArithmeticError ExactRational+exactRationalFromDyadicRatio _ 0 _ = Left ExactZeroDivisor+exactRationalFromDyadicRatio 0 _ _ = Right (ExactRational (0 :% 1))+exactRationalFromDyadicRatio numerator denominator power =+  let numeratorFactor = integerTrailingZeroBits numerator+      denominatorFactor = integerTrailingZeroBits denominator+      oddNumerator = numerator `shiftR` numeratorFactor+      oddDenominator = denominator `shiftR` denominatorFactor+      residualPower = power + numeratorFactor - denominatorFactor+   in if residualPower >= 0+        then exactRational (oddNumerator `shiftL` residualPower) oddDenominator+        else exactRational oddNumerator (oddDenominator `shiftL` negate residualPower)+{-# INLINE exactRationalFromDyadicRatio #-}++-- | Internal bridge from the normalized carrier owned by @Data.Ratio@. This+-- exists for statically nonzero rational constants in exact kernels; public+-- callers continue through 'exactRational'.+exactRationalFromNormalizedRatio :: Ratio Integer -> ExactRational+exactRationalFromNormalizedRatio = ExactRational+{-# INLINE exactRationalFromNormalizedRatio #-}++-- | 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 #-}++-- | Maximum bit width of the reduced numerator magnitude and strictly+-- positive denominator. This is an observation, not an arithmetic bound.+exactRationalBitWidth :: ExactRational -> Int+exactRationalBitWidth value =+  max+    (integerBitWidth (abs (exactRationalNumerator value)))+    (exactRationalDenominatorBitWidth value)+{-# INLINE exactRationalBitWidth #-}++-- | Bit width of the reduced, strictly positive denominator.+exactRationalDenominatorBitWidth :: ExactRational -> Int+exactRationalDenominatorBitWidth =+  integerBitWidth . exactRationalDenominator+{-# INLINE exactRationalDenominatorBitWidth #-}++integerBitWidth :: Integer -> Int+integerBitWidth value+  | value <= 0 = 0+  | otherwise = I# (integerLog2# value) + 1+{-# INLINE integerBitWidth #-}++-- | 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/FaceQueue.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++-- | The set of faces still owed a refinement decision.+module Moonlight.Triangulation.Internal.FaceQueue+  ( FaceQueue+  , newFaceQueue+  , pushFace+  , popFace+  ) where++import Control.Monad.ST (ST)+import qualified Data.IntSet as IntSet+import Data.STRef (STRef, modifySTRef', newSTRef, readSTRef)+import Data.Word (Word32)+import qualified Data.Vector.Unboxed.Mutable as MUV+import Moonlight.Triangulation.Internal.Growable+  ( GrowableWord32+  , newGrowableWord32+  , popGrowableOr+  , pushGrowable+  )+import Moonlight.Triangulation.Internal.PackedIndex (noIndex, packIndex)++-- A worst-first heap has to be told a score for every face it is offered, so+-- the caller derives one — circumradius, area, the encroachment verdict — for+-- faces that are then found acceptable and dropped. Ruppert's termination does+-- not rest on that order; it rests on every bad face being reached before the+-- run ends. So this only has to be a set with a discipline for draining it.+--+-- A stack is that, and it makes membership O(1) with nothing to compute. The+-- pending flags are what keep it a set: a face touched by several insertions+-- before it is drained is decided once, not once per touch.+--+-- The size lives in an unboxed cell for the reason the growable stack's does:+-- it is written on every push and every pop, and a boxed counter allocates a+-- box per write once the size leaves the shared small-'Int' range.+data FaceQueue s+  = DenseFaceQueue+      !(MUV.MVector s Word32)+      !(MUV.MVector s Bool)+      !(MUV.MVector s Int)+  | SparseFaceQueue+      !(GrowableWord32 s)+      !(STRef s IntSet.IntSet)++newFaceQueue :: Maybe Int -> ST s (FaceQueue s)+newFaceQueue capacity =+  case capacity of+    Just size -> do+      faces <- MUV.new (max 1 size)+      pending <- MUV.replicate (max 1 size) False+      stackSize <- MUV.replicate 1 0+      pure (DenseFaceQueue faces pending stackSize)+    Nothing -> do+      faces <- newGrowableWord32 16+      pending <- newSTRef IntSet.empty+      pure (SparseFaceQueue faces pending)++-- The checked read of the pending flag is the one bound this module does not+-- establish itself: the face arrives from mesh topology. Once it succeeds,+-- uniqueness proves the stack write: at most one slot exists for each pending+-- flag, and the two vectors have the same length.+pushFace :: FaceQueue s -> Int -> ST s ()+pushFace queue face =+  case queue of+    DenseFaceQueue faces pending stackSize -> do+      isPending <- MUV.unsafeRead pending face+      if isPending+        then pure ()+        else do+          size <- MUV.unsafeRead stackSize 0+          MUV.unsafeWrite faces size (packIndex face)+          MUV.unsafeWrite pending face True+          MUV.unsafeWrite stackSize 0 (size + 1)+    SparseFaceQueue faces pending -> do+      isPending <- IntSet.member face <$> readSTRef pending+      if isPending+        then pure ()+        else do+          pushGrowable faces (packIndex face)+          modifySTRef' pending (IntSet.insert face)++popFace :: FaceQueue s -> ST s (Maybe Int)+popFace queue =+  case queue of+    DenseFaceQueue faces pending stackSize -> do+      size <- MUV.unsafeRead stackSize 0+      if size == 0+        then pure Nothing+        else do+          let !index = size - 1+          face <- fromIntegral <$> MUV.unsafeRead faces index+          MUV.unsafeWrite pending face False+          MUV.unsafeWrite stackSize 0 index+          pure (Just face)+    SparseFaceQueue faces pending -> do+      packed <- popGrowableOr noIndex faces+      if packed == noIndex+        then pure Nothing+        else do+          let !face = fromIntegral packed+          modifySTRef' pending (IntSet.delete face)+          pure (Just face)
+ src-core/Moonlight/Triangulation/Internal/Growable.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}++module Moonlight.Triangulation.Internal.Growable+  ( GrowableWord32+  , newGrowableWord32+  , clearGrowable+  , growableLength+  , pushGrowable+  , popGrowableOr+  , readGrowable+  , writeGrowable+  ) where++import Control.Monad (when)+import Control.Monad.ST (ST)+import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32)++-- | Transaction-local vector. It starts small and grows only with the local+-- frontier; no operation allocates scratch memory proportional to mesh size.+-- The size lives in an unboxed cell: the stack is popped and pushed inside+-- every legalization drain, and a boxed counter would allocate on each step.+data GrowableWord32 s = GrowableWord32+  { growableVector :: !(STRef s (MUV.MVector s Word32))+  , growableSize :: !(MUV.MVector s Int)+  }++newGrowableWord32 :: Int -> ST s (GrowableWord32 s)+newGrowableWord32 requested = do+  vector <- MUV.new (max 8 requested)+  growableVector <- newSTRef vector+  growableSize <- MUV.replicate 1 0+  pure GrowableWord32{growableVector, growableSize}++clearGrowable :: GrowableWord32 s -> ST s ()+clearGrowable GrowableWord32{growableSize} = MUV.unsafeWrite growableSize 0 0+{-# INLINE clearGrowable #-}++growableLength :: GrowableWord32 s -> ST s Int+growableLength GrowableWord32{growableSize} = MUV.unsafeRead growableSize 0+{-# INLINE growableLength #-}++pushGrowable :: GrowableWord32 s -> Word32 -> ST s ()+pushGrowable growable@GrowableWord32{growableSize} value = do+  index <- MUV.unsafeRead growableSize 0+  vector <- ensureCapacity growable (index + 1)+  MUV.unsafeWrite vector index value+  MUV.unsafeWrite growableSize 0 (index + 1)+{-# INLINE pushGrowable #-}++-- | Pop, answering the caller's sentinel on emptiness instead of allocating a+-- 'Maybe' per step. Sound only against a sentinel no push can store.+popGrowableOr :: Word32 -> GrowableWord32 s -> ST s Word32+popGrowableOr sentinel GrowableWord32{growableVector, growableSize} = do+  size <- MUV.unsafeRead growableSize 0+  if size <= 0+    then pure sentinel+    else do+      let !index = size - 1+      vector <- readSTRef growableVector+      value <- MUV.unsafeRead vector index+      MUV.unsafeWrite growableSize 0 index+      pure value+{-# INLINE popGrowableOr #-}++readGrowable :: GrowableWord32 s -> Int -> ST s Word32+readGrowable GrowableWord32{growableVector} index = do+  vector <- readSTRef growableVector+  MUV.unsafeRead vector index+{-# INLINE readGrowable #-}++writeGrowable :: GrowableWord32 s -> Int -> Word32 -> ST s ()+writeGrowable growable@GrowableWord32{growableSize} index value = do+  vector <- ensureCapacity growable (index + 1)+  MUV.unsafeWrite vector index value+  size <- MUV.unsafeRead growableSize 0+  when (index >= size) (MUV.unsafeWrite growableSize 0 (index + 1))+{-# INLINE writeGrowable #-}++-- Answering with the vector is what keeps a push to one cell read: the caller+-- would otherwise re-read the reference this just proved current.+ensureCapacity :: GrowableWord32 s -> Int -> ST s (MUV.MVector s Word32)+ensureCapacity GrowableWord32{growableVector} required = do+  vector <- readSTRef growableVector+  let !current = MUV.length vector+  if required <= current+    then pure vector+    else do+      let !next = until (>= required) (* 2) current+      grown <- MUV.grow vector (next - current)+      writeSTRef growableVector grown+      pure grown
+ src-core/Moonlight/Triangulation/Internal/PackedIndex.hs view
@@ -0,0 +1,34 @@+module Moonlight.Triangulation.Internal.PackedIndex+  ( noIndex+  , indexLimit+  , packIndex+  , unpackIndex+  , unpackOptionalIndex+  ) where++import Data.Word (Word32)++noIndex :: Word32+noIndex = maxBound++indexLimit :: Int+indexLimit = fromIntegral (maxBound - 1 :: Word32)++-- | Pack an admitted arena handle. The build boundary limits vertex capacity+-- so the mutable topology reservation, @8n + 16@, stays below 'indexLimit';+-- every caller supplies a non-negative handle or worklist position derived+-- from those arenas. Optional @-1@ handles are represented separately by+-- 'noIndex' before this function is reached.+packIndex :: Int -> Word32+packIndex = fromIntegral+{-# INLINE packIndex #-}++unpackIndex :: Word32 -> Int+unpackIndex = fromIntegral+{-# INLINE unpackIndex #-}++unpackOptionalIndex :: Word32 -> Maybe Int+unpackOptionalIndex value+  | value == noIndex = Nothing+  | otherwise = Just (unpackIndex value)+{-# INLINE unpackOptionalIndex #-}
+ src-core/Moonlight/Triangulation/Internal/PageDirectory.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | The map from page number to page, for the paged stores.+module Moonlight.Triangulation.Internal.PageDirectory+  ( PageDirectory+  , emptyDirectory+  , lookupDirectory+  , insertDirectory+  , directoryFromAscList+  , directoryToAscList+  , directorySize+  , directoryLookupMax+  , directoryRestrict+  ) where++import Control.DeepSeq (NFData)+import Data.Bits (shiftL, shiftR, (.&.))+import qualified Data.List as List+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import GHC.Generics (Generic)++-- Page numbers are small, dense and non-negative, and the read path resolves+-- one on every field access that misses its owner's current page. An ordered+-- map answers that with a chain of prefix comparisons whose length grows with+-- the mesh; a 32-way radix answers it with two indexed loads at every size the+-- meshes reach, and the arithmetic is shifts and masks rather than branches.+--+-- Absence is representable because the boxed payload store leaves a page out+-- entirely when every slot in it still holds the fill.+data Slot a+  = Absent+  | Page !a+  | Fanout !(V.Vector (Slot a))+  deriving stock (Generic, Functor)+  deriving anyclass (NFData)++-- | @directoryHeight@ counts the fanout levels below the root: at height 0 the+-- root's children are pages, at height 1 they are fanouts of pages, and so on.+data PageDirectory a = PageDirectory+  { directoryHeight :: {-# UNPACK #-} !Int+  , directoryRoot :: !(Slot a)+  , directorySize :: {-# UNPACK #-} !Int+  }+  deriving stock (Generic, Functor)+  deriving anyclass (NFData)++fanout :: Int+fanout = 32+{-# INLINE fanout #-}++slotBits :: Int+slotBits = 5+{-# INLINE slotBits #-}++-- Path copying replaces one slot per level, and the bulk-update operator would+-- route that through a list of one pair. This is the copy the level needs and+-- nothing besides.+updateSlot :: V.Vector (Slot a) -> Int -> Slot a -> V.Vector (Slot a)+updateSlot children index child =+  V.modify (\node -> MV.unsafeWrite node index child) children+{-# INLINE updateSlot #-}++-- | The first page number a directory of this height cannot address.+capacity :: Int -> Int+capacity height = 1 `shiftL` (slotBits * (height + 1))+{-# INLINE capacity #-}++emptyDirectory :: PageDirectory a+emptyDirectory = PageDirectory 0 Absent 0++lookupDirectory :: Int -> PageDirectory a -> Maybe a+lookupDirectory key PageDirectory{directoryHeight, directoryRoot}+  | key < 0 || key >= capacity directoryHeight = Nothing+  | otherwise = go directoryHeight directoryRoot+ where+  go !height slot = case slot of+    Absent -> Nothing+    Page value -> Just value+    Fanout children ->+      go (height - 1) (V.unsafeIndex children ((key `shiftR` (slotBits * height)) .&. (fanout - 1)))+{-# INLINE lookupDirectory #-}++insertDirectory :: Int -> a -> PageDirectory a -> PageDirectory a+insertDirectory key value directory+  | key >= capacity (directoryHeight directory) = insertDirectory key value (grow directory)+  | otherwise =+      let (!root, !added) = write (directoryHeight directory) (directoryRoot directory)+       in directory+            { directoryRoot = root+            , directorySize = directorySize directory + if added then 1 else 0+            }+ where+  write !height slot+    | height < 0 = (Page value, case slot of Page _ -> False; _ -> True)+    | otherwise =+        let !index = (key `shiftR` (slotBits * height)) .&. (fanout - 1)+            !children = case slot of+              Fanout existing -> existing+              _ -> V.replicate fanout Absent+            (!child, !added) = write (height - 1) (V.unsafeIndex children index)+         in (Fanout (updateSlot children index child), added)++-- A directory that has run out of addressable pages gains a level, and its+-- whole former extent becomes child zero of the new root.+grow :: PageDirectory a -> PageDirectory a+grow directory@PageDirectory{directoryHeight, directoryRoot} =+  directory+    { directoryHeight = directoryHeight + 1+    , directoryRoot = case directoryRoot of+        Absent -> Absent+        occupied -> Fanout (updateSlot (V.replicate fanout Absent) 0 occupied)+    }++-- | Build from ascending, distinct page numbers in one descent.+--+-- Every dense transaction ends by publishing a whole directory, so this is on+-- the freeze path of bulk load, constraint recovery and refinement alike.+-- Folding 'insertDirectory' over the list would copy each root path once per+-- page; laying the levels down directly touches each node once.+directoryFromAscList :: [(Int, a)] -> PageDirectory a+directoryFromAscList [] = emptyDirectory+directoryFromAscList entries@((firstKey, _) : remainingEntries) =+  PageDirectory+    { directoryHeight = height+    , directoryRoot = fst (build height 0 entries)+    , directorySize = length entries+    }+ where+  !largest = List.foldl' (\largestKey (key, _) -> max largestKey key) firstKey remainingEntries+  !height = heightFor 0+  heightFor !candidate+    | largest < capacity candidate = candidate+    | otherwise = heightFor (candidate + 1)++  build :: Int -> Int -> [(Int, b)] -> (Slot b, [(Int, b)])+  build !level !base remaining = case remaining of+    [] -> (Absent, [])+    ((key, value) : rest)+      | key >= base + capacity level -> (Absent, remaining)+      | level < 0 -> (Page value, rest)+      | otherwise ->+          let !childSpan = capacity (level - 1)+              step (children, unconsumed) index =+                let (!child, !beyond) = build (level - 1) (base + index * childSpan) unconsumed+                 in (child : children, beyond)+              (!reversed, !left) = List.foldl' step ([], remaining) [0 .. fanout - 1]+           in (Fanout (V.fromListN fanout (reverse reversed)), left)++directoryToAscList :: PageDirectory a -> [(Int, a)]+directoryToAscList PageDirectory{directoryHeight, directoryRoot} = go directoryHeight 0 directoryRoot []+ where+  go :: Int -> Int -> Slot b -> [(Int, b)] -> [(Int, b)]+  go !height !prefix slot rest = case slot of+    Absent -> rest+    Page value -> (prefix, value) : rest+    Fanout children ->+      foldr+        (\index accumulated ->+          go+            (height - 1)+            (prefix + (index `shiftL` (slotBits * height)))+            (V.unsafeIndex children index)+            accumulated+        )+        rest+        [0 .. fanout - 1]++directoryLookupMax :: PageDirectory a -> Maybe (Int, a)+directoryLookupMax PageDirectory{directoryHeight, directoryRoot} = go directoryHeight 0 directoryRoot+ where+  go :: Int -> Int -> Slot b -> Maybe (Int, b)+  go !height !prefix slot = case slot of+    Absent -> Nothing+    Page value -> Just (prefix, value)+    Fanout children -> descend (fanout - 1)+     where+      descend !index+        | index < 0 = Nothing+        | otherwise =+            case go (height - 1) (prefix + (index `shiftL` (slotBits * height))) (V.unsafeIndex children index) of+              Nothing -> descend (index - 1)+              found -> found++-- | Keep only the pages a directory of the given page count can hold. The+-- common case is that every page is already within the count, and that is+-- settled by one descent rather than a rebuild.+directoryRestrict :: Int -> PageDirectory a -> PageDirectory a+directoryRestrict pageCount directory+  | pageCount <= 0 = emptyDirectory+  | otherwise = case directoryLookupMax directory of+      Nothing -> directory+      Just (largest, _)+        | largest < pageCount -> directory+        | otherwise ->+            directoryFromAscList (filter ((< pageCount) . fst) (directoryToAscList directory))
+ src-core/Moonlight/Triangulation/Internal/Paged.hs view
@@ -0,0 +1,416 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Moonlight.Triangulation.Internal.Paged+  ( Paged+  , MutablePaged+  , FlatMutablePaged+  , emptyPaged+  , fromVector+  , fromLocalVector+  , toVector+  , pagedLength+  , pagedPageCount+  , pagedOverlayPageCount+  , PublicationStats (..)+  , emptyPublicationStats+  , addPublicationStats+  , pagedUnsafeIndex+  , pagedFoldl'+  , newMutablePaged+  , newLocalMutablePaged+  , TransactionShape (..)+  , thawPaged+  , thawPagedDense+  , thawPagedShaped+  , flatMutableSection+  , readFlatMutable+  , writeFlatMutable+  , readPaged+  , writePaged+  , freezePaged+  , readMutablePagedPublicationStats+  ) where++import Control.DeepSeq (NFData (..))+import Control.Monad (when)+import Control.Monad.ST (ST)+import Data.Bits (shiftL, shiftR, (.&.))+import qualified Data.IntMap.Strict as IntMap+import Data.List (unfoldr)+import Data.STRef (STRef, modifySTRef', newSTRef, readSTRef, writeSTRef)+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MUV+import Moonlight.Triangulation.Internal.PageDirectory+  ( PageDirectory+  , directoryRestrict+  , directorySize+  , emptyDirectory+  , insertDirectory+  , lookupDirectory+  )++-- | One flat root plus one cumulative page overlay. An extension never wraps+-- a published value in another 'Paged' node: dirty pages are merged into the+-- existing directory, so an untouched read remains one overlay lookup plus+-- one root lookup regardless of extension count.+data Paged a+  = FlatPaged {-# UNPACK #-} !Int {-# UNPACK #-} !Int !(U.Vector a)+  | SharedPaged+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+      !(U.Vector a)+      !(PageDirectory (U.Vector a))++-- | Exact storage work observed by one persistent publication.  The dense+-- page counters describe a whole-base traversal; dirty-page and copied-cell+-- counters describe only pages opened by the local write set.  A zero dense+-- counter is therefore a storage fact from the transaction owner, never a+-- benchmark inference; page work is independent of the resident prefix except+-- for directory-path depth.+data PublicationStats = PublicationStats+  { publicationUnboxedBasePageEnumerations :: {-# UNPACK #-} !Int+  , publicationUnboxedBasePageOpens :: {-# UNPACK #-} !Int+  , publicationUnboxedBasePageFreezes :: {-# UNPACK #-} !Int+  , publicationUnboxedDirtyBasePages :: {-# UNPACK #-} !Int+  , publicationUnboxedDirtyAppendedPages :: {-# UNPACK #-} !Int+  , publicationUnboxedCopiedCells :: {-# UNPACK #-} !Int+  , publicationBoxedBasePageEnumerations :: {-# UNPACK #-} !Int+  , publicationBoxedBasePageOpens :: {-# UNPACK #-} !Int+  , publicationBoxedBasePageFreezes :: {-# UNPACK #-} !Int+  , publicationBoxedDirtyBasePages :: {-# UNPACK #-} !Int+  , publicationBoxedDirtyAppendedPages :: {-# UNPACK #-} !Int+  , publicationBoxedCopiedCells :: {-# UNPACK #-} !Int+  }+  deriving stock (Eq, Show)++instance NFData PublicationStats where+  rnf stats = stats `seq` ()++emptyPublicationStats :: PublicationStats+emptyPublicationStats =+  PublicationStats+    { publicationUnboxedBasePageEnumerations = 0+    , publicationUnboxedBasePageOpens = 0+    , publicationUnboxedBasePageFreezes = 0+    , publicationUnboxedDirtyBasePages = 0+    , publicationUnboxedDirtyAppendedPages = 0+    , publicationUnboxedCopiedCells = 0+    , publicationBoxedBasePageEnumerations = 0+    , publicationBoxedBasePageOpens = 0+    , publicationBoxedBasePageFreezes = 0+    , publicationBoxedDirtyBasePages = 0+    , publicationBoxedDirtyAppendedPages = 0+    , publicationBoxedCopiedCells = 0+    }++addPublicationStats :: PublicationStats -> PublicationStats -> PublicationStats+addPublicationStats left right =+  PublicationStats+    { publicationUnboxedBasePageEnumerations = publicationUnboxedBasePageEnumerations left + publicationUnboxedBasePageEnumerations right+    , publicationUnboxedBasePageOpens = publicationUnboxedBasePageOpens left + publicationUnboxedBasePageOpens right+    , publicationUnboxedBasePageFreezes = publicationUnboxedBasePageFreezes left + publicationUnboxedBasePageFreezes right+    , publicationUnboxedDirtyBasePages = publicationUnboxedDirtyBasePages left + publicationUnboxedDirtyBasePages right+    , publicationUnboxedDirtyAppendedPages = publicationUnboxedDirtyAppendedPages left + publicationUnboxedDirtyAppendedPages right+    , publicationUnboxedCopiedCells = publicationUnboxedCopiedCells left + publicationUnboxedCopiedCells right+    , publicationBoxedBasePageEnumerations = publicationBoxedBasePageEnumerations left + publicationBoxedBasePageEnumerations right+    , publicationBoxedBasePageOpens = publicationBoxedBasePageOpens left + publicationBoxedBasePageOpens right+    , publicationBoxedBasePageFreezes = publicationBoxedBasePageFreezes left + publicationBoxedBasePageFreezes right+    , publicationBoxedDirtyBasePages = publicationBoxedDirtyBasePages left + publicationBoxedDirtyBasePages right+    , publicationBoxedDirtyAppendedPages = publicationBoxedDirtyAppendedPages left + publicationBoxedDirtyAppendedPages right+    , publicationBoxedCopiedCells = publicationBoxedCopiedCells left + publicationBoxedCopiedCells right+    }++-- | A fresh build owns a contiguous arena. A local transaction owns only its+-- dirty pages; clean values remain reachable through the immutable base.+data MutablePaged s a+  = MutableFlatPaged {-# UNPACK #-} !Int !(MUV.MVector s a)+  | MutableSharedPaged+      {-# UNPACK #-} !Int+      !(Paged a)+      !(STRef s (IntMap.IntMap (MUV.MVector s a)))+      !(STRef s PublicationStats)++-- | A proof that one mutable sequence is in its contiguous physical section.+data FlatMutablePaged s a = FlatMutablePaged !(MUV.MVector s a)++localPageBits :: Int+localPageBits = 8+{-# INLINE localPageBits #-}++traversalPageBits :: Int+traversalPageBits = 10+{-# INLINE traversalPageBits #-}++pageSize :: Int -> Int+pageSize bits = 1 `shiftL` bits+{-# INLINE pageSize #-}++pageOf :: Int -> Int -> Int+pageOf bits index = index `shiftR` bits+{-# INLINE pageOf #-}++offsetOf :: Int -> Int -> Int+offsetOf bits index = index .&. (pageSize bits - 1)+{-# INLINE offsetOf #-}++pagesFor :: Int -> Int -> Int+pagesFor bits count+  | count <= 0 = 0+  | otherwise = pageOf bits (count - 1) + 1+{-# INLINE pagesFor #-}++pagedLength :: Paged a -> Int+pagedLength paged = case paged of+  FlatPaged count _ _ -> count+  SharedPaged count _ _ _ -> count+{-# INLINE pagedLength #-}++pagedPageCount :: Paged a -> Int+pagedPageCount paged = pagesFor (pagedBits paged) (pagedLength paged)+{-# INLINE pagedPageCount #-}++-- | Number of pages in the persistent overlay.  A flat root has no copied+-- pages; a shared value records only pages dirtied by its transaction.  This+-- is an observation for publication receipts, not a read-path traversal.+pagedOverlayPageCount :: Paged a -> Int+pagedOverlayPageCount paged = case paged of+  FlatPaged{} -> 0+  SharedPaged _ _ _ directory -> directorySize directory+{-# INLINE pagedOverlayPageCount #-}++pagedBits :: Paged a -> Int+pagedBits paged = case paged of+  FlatPaged _ bits _ -> bits+  SharedPaged _ bits _ _ -> bits+{-# INLINE pagedBits #-}++instance (U.Unbox a, Eq a) => Eq (Paged a) where+  left == right =+    pagedLength left == pagedLength right+      && case (left, right) of+        (FlatPaged _ _ leftValues, FlatPaged _ _ rightValues) -> leftValues == rightValues+        _ -> pagedChunksEqual left right++pagedChunksEqual :: forall a. (U.Unbox a, Eq a) => Paged a -> Paged a -> Bool+pagedChunksEqual left right =+  foldl'+    (\equal (index, width) ->+       equal+         && U.unsafeSlice 0 width (pageSlice left index)+              == U.unsafeSlice 0 width (pageSlice right index))+    True+    chunks+ where+  !count = pagedLength left+  !leftBits = pagedBits left+  !rightBits = pagedBits right+  chunks = unfoldr nextChunk 0++  nextChunk !index+    | index >= count = Nothing+    | otherwise = Just ((index, width), index + width)+    where+      !leftPageEnd = (pageOf leftBits index + 1) * pageSize leftBits+      !rightPageEnd = (pageOf rightBits index + 1) * pageSize rightBits+      !width = min (count - index) (min (leftPageEnd - index) (rightPageEnd - index))+  pageSlice :: Paged a -> Int -> U.Vector a+  pageSlice paged index =+    let !bits = pagedBits paged+        !page = pageOf bits index+        !offset = offsetOf bits index+     in case paged of+          FlatPaged _ _ values -> U.unsafeSlice index (U.length values - index) values+          SharedPaged _ _ root directory ->+            case lookupDirectory page directory of+              Just values -> U.unsafeSlice offset (U.length values - offset) values+              Nothing -> U.unsafeSlice index (U.length root - index) root++instance (U.Unbox a, Show a) => Show (Paged a) where+  showsPrec precedence = showsPrec precedence . U.toList . toVector++instance NFData (Paged a) where+  rnf paged = case paged of+    FlatPaged count bits values -> count `seq` bits `seq` values `seq` ()+    SharedPaged count bits root directory ->+      count `seq` bits `seq` root `seq` directory `seq` ()++emptyPaged :: U.Unbox a => Paged a+emptyPaged = FlatPaged 0 traversalPageBits U.empty++fromVector :: U.Unbox a => a -> U.Vector a -> Paged a+fromVector _padding values = FlatPaged (U.length values) traversalPageBits values++fromLocalVector :: U.Unbox a => a -> U.Vector a -> Paged a+fromLocalVector _padding values = FlatPaged (U.length values) localPageBits values++toVector :: U.Unbox a => Paged a -> U.Vector a+toVector paged = case paged of+  FlatPaged count _ values -> U.unsafeSlice 0 count values+  SharedPaged count _ _ _ -> U.generate count (pagedUnsafeIndex paged)++pagedUnsafeIndex :: U.Unbox a => Paged a -> Int -> a+pagedUnsafeIndex paged index =+  case paged of+    FlatPaged _ _ values -> U.unsafeIndex values index+    SharedPaged _ bits root directory ->+      case lookupDirectory (pageOf bits index) directory of+        Just values -> U.unsafeIndex values (offsetOf bits index)+        Nothing -> U.unsafeIndex root index+{-# INLINE pagedUnsafeIndex #-}++-- | Fold directly over the physical sections. Unlike the old implementation,+-- this does not allocate a complete vector merely to consume it.+pagedFoldl' :: U.Unbox a => (b -> a -> b) -> b -> Paged a -> b+pagedFoldl' step initial paged =+  case paged of+    FlatPaged count _ values -> U.foldl' step initial (U.take count values)+    SharedPaged count bits root directory ->+      foldl' foldPage initial [0 .. pagesFor bits count - 1]+     where+      foldPage !accumulated page =+        let !start = page * pageSize bits+            !width = min (pageSize bits) (count - start)+            !values =+              case lookupDirectory page directory of+                Just pageValues -> U.unsafeSlice 0 width pageValues+                Nothing -> U.unsafeSlice start width root+         in U.foldl' step accumulated values+{-# INLINE pagedFoldl' #-}++newMutablePaged :: U.Unbox a => Int -> ST s (MutablePaged s a)+newMutablePaged capacity = do+  values <- MUV.new (max 0 capacity)+  pure (MutableFlatPaged traversalPageBits values)++newLocalMutablePaged :: U.Unbox a => Int -> ST s (MutablePaged s a)+newLocalMutablePaged capacity = do+  values <- MUV.new (max 0 capacity)+  pure (MutableFlatPaged localPageBits values)++-- | Open a persistent transaction without constructing a page table over the+-- resident mesh. The mutable dictionary starts empty and acquires storage only+-- when a write first reaches a page.+thawPaged :: Int -> Paged a -> ST s (MutablePaged s a)+thawPaged _requestedCapacity paged = do+  dirty <- newSTRef IntMap.empty+  stats <- newSTRef emptyPublicationStats+  pure (MutableSharedPaged (pagedBits paged) paged dirty stats)++data TransactionShape = DenseTransaction | LocalTransaction++thawPagedShaped :: U.Unbox a => TransactionShape -> Int -> Paged a -> ST s (MutablePaged s a)+thawPagedShaped shape = case shape of+  DenseTransaction -> thawPagedDense+  LocalTransaction -> thawPaged+{-# INLINE thawPagedShaped #-}++thawPagedDense :: U.Unbox a => Int -> Paged a -> ST s (MutablePaged s a)+thawPagedDense requestedCapacity paged = do+  let !count = pagedLength paged+      !capacity = max requestedCapacity count+  values <- MUV.new capacity+  U.copy (MUV.unsafeSlice 0 count values) (toVector paged)+  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 = case mutable of+  MutableFlatPaged _ values -> MUV.unsafeRead values index+  MutableSharedPaged bits base dirtyRef _ -> do+    dirty <- readSTRef dirtyRef+    case IntMap.lookup (pageOf bits index) dirty of+      Just values -> MUV.unsafeRead values (offsetOf bits index)+      Nothing -> pure (pagedUnsafeIndex base index)+{-# INLINE readPaged #-}++writePaged :: U.Unbox a => MutablePaged s a -> Int -> a -> ST s ()+writePaged mutable index value = case mutable of+  MutableFlatPaged _ values -> MUV.unsafeWrite values index value+  MutableSharedPaged bits base dirtyRef statsRef -> do+    let !page = pageOf bits index+        !start = page * pageSize bits+        !existingWidth = min (pageSize bits) (max 0 (pagedLength base - start))+    dirty <- readSTRef dirtyRef+    values <- case IntMap.lookup page dirty of+      Just existing -> pure existing+      Nothing -> do+        pageValues <- MUV.new (pageSize bits)+        when (existingWidth > 0) $+            U.copy+              (MUV.unsafeSlice 0 existingWidth pageValues)+              (U.generate existingWidth (\offset -> pagedUnsafeIndex base (start + offset)))+        writeSTRef dirtyRef $! IntMap.insert page pageValues dirty+        modifySTRef'+          statsRef+          (addPublicationStats+             emptyPublicationStats+               { publicationUnboxedBasePageOpens = if existingWidth > 0 then 1 else 0+               , publicationUnboxedDirtyBasePages = if existingWidth > 0 then 1 else 0+               , publicationUnboxedDirtyAppendedPages = if existingWidth > 0 then 0 else 1+               , publicationUnboxedCopiedCells = existingWidth+               })+        pure pageValues+    MUV.unsafeWrite values (offsetOf bits index) value+{-# INLINE writePaged #-}++-- | Publish only dirty pages. A local publication retains one immutable root+-- and merges the changed page paths into its cumulative directory.+freezePaged :: forall s a. U.Unbox a => Int -> MutablePaged s a -> ST s (Paged a)+freezePaged count mutable+  | count <= 0 = pure emptyPaged+  | otherwise = case mutable of+      MutableFlatPaged bits values+        | MUV.length values <= count + (count `quot` 8) ->+            FlatPaged count bits . U.take count <$> U.unsafeFreeze values+        | otherwise ->+            FlatPaged count bits <$> U.freeze (MUV.unsafeSlice 0 count values)+      MutableSharedPaged bits base dirtyRef _statsRef -> do+        dirty <- readSTRef dirtyRef+        if IntMap.null dirty && count == pagedLength base+          then pure base+          else do+            frozen <- traverse freezePage (IntMap.toAscList dirty)+            let !priorDirectory = sharedDirectory base+                !directory =+                  foldl'+                    (\accumulated (page, values) -> insertDirectory page values accumulated)+                    priorDirectory+                    frozen+                !root = sharedRoot base+            pure (SharedPaged count bits root (directoryRestrict (pagesFor bits count) directory))+ where+  freezePage :: (Int, MUV.MVector s a) -> ST s (Int, U.Vector a)+  freezePage (page, values) = do+    frozen <- U.unsafeFreeze values+    pure (page, frozen)++sharedRoot :: Paged a -> U.Vector a+sharedRoot paged = case paged of+  FlatPaged _ _ values -> values+  SharedPaged _ _ root _ -> root+{-# INLINE sharedRoot #-}++sharedDirectory :: Paged a -> PageDirectory (U.Vector a)+sharedDirectory paged = case paged of+  FlatPaged _ _ _ -> emptyDirectory+  SharedPaged _ _ _ directory -> directory+{-# INLINE sharedDirectory #-}++readMutablePagedPublicationStats :: MutablePaged s a -> ST s PublicationStats+readMutablePagedPublicationStats mutable = case mutable of+  MutableFlatPaged _ _ -> pure emptyPublicationStats+  MutableSharedPaged _ _ _ statsRef -> readSTRef statsRef
+ src-core/Moonlight/Triangulation/LineSideInfo.hs view
@@ -0,0 +1,55 @@+-- | Which side of a directed line a point falls on, as a total three-valued+-- answer that carries the collinear case rather than rounding it away.+module Moonlight.Triangulation.LineSideInfo+  ( LineSideInfo+  , fromDeterminant+  , fromOrdering+  , sideOrdering+  , isOnLeftSide+  , isOnRightSide+  , isOnLine+  , isOnLeftSideOrLine+  , isOnRightSideOrLine+  , reverseSide+  ) where++-- | A three-valued side: the collinear case is a value, not a rounding.+newtype LineSideInfo = LineSideInfo Ordering+  deriving stock (Show)+  deriving newtype (Eq, Ord)++-- | The side an orientation determinant's sign names.+fromDeterminant :: Double -> LineSideInfo+fromDeterminant value = LineSideInfo (compare value 0)+{-# INLINE fromDeterminant #-}++-- | The side an 'Ordering' names.+fromOrdering :: Ordering -> LineSideInfo+fromOrdering = LineSideInfo+{-# INLINE fromOrdering #-}++-- | The underlying 'Ordering'.+sideOrdering :: LineSideInfo -> Ordering+sideOrdering (LineSideInfo ordering) = ordering+{-# INLINE sideOrdering #-}++-- | The five side tests; the @OrLine@ pair admit the collinear case.+isOnLeftSide, isOnRightSide, isOnLine, isOnLeftSideOrLine, isOnRightSideOrLine :: LineSideInfo -> Bool+isOnLeftSide (LineSideInfo ordering) = ordering == GT+isOnRightSide (LineSideInfo ordering) = ordering == LT+isOnLine (LineSideInfo ordering) = ordering == EQ+isOnLeftSideOrLine side = not (isOnRightSide side)+isOnRightSideOrLine side = not (isOnLeftSide side)+{-# INLINE isOnLeftSide #-}+{-# INLINE isOnRightSide #-}+{-# INLINE isOnLine #-}+{-# INLINE isOnLeftSideOrLine #-}+{-# INLINE isOnRightSideOrLine #-}++-- | The same point, seen along the reversed line.+reverseSide :: LineSideInfo -> LineSideInfo+reverseSide (LineSideInfo ordering) = LineSideInfo $ case ordering of+  LT -> GT+  EQ -> EQ+  GT -> LT+{-# INLINE reverseSide #-}
+ src-core/Moonlight/Triangulation/Scalar.hs view
@@ -0,0 +1,124 @@+{-# OPTIONS_GHC -O3 -fllvm -optlo-O3 -optlc-O3 #-}++-- | The binary64 coordinate kernel and exact predicate boundary.+module Moonlight.Triangulation.Scalar+  ( scalarName+  , scalarByteSize+  , scalarBinaryFormat+  , scalarEpsilon+  , scalarUnitRoundoff+  , scalarCcwErrorBound+  , scalarInCircleErrorBound+  , circumradiusSquaredWithinCoordinates+  , BinaryFormat+  , formatRadix+  , formatMantissaDigits+  , formatExponentRange+  , minimumAllowedCoordinate+  , maximumAllowedCoordinate+  , isFinite+  , canonicalScalarZero+  ) where++import Moonlight.Triangulation.Internal.Dyadic+  ( exactCircumradiusSquaredWithin+  )++-- | The coordinate component of canonical point identity. IEEE signed zeros+-- compare equal but hash differently by bits; every coordinate-keyed owner+-- therefore normalizes them before storage or hashing.+canonicalScalarZero :: Double -> Double+canonicalScalarZero value+  | value == 0 = 0+  | otherwise = value+{-# INLINE canonicalScalarZero #-}++-- | Machine format of the coordinate scalar.+data BinaryFormat = BinaryFormat+  { formatRadix :: !Integer+    -- ^ Numeric base of the significand.+  , formatMantissaDigits :: !Int+    -- ^ Number of base-'formatRadix' digits in the significand.+  , formatExponentRange :: !(Int, Int)+    -- ^ Inclusive minimum and exclusive maximum exponent bounds.+  }+  deriving stock (Eq, Show)++-- | Stable name of the coordinate scalar.+scalarName :: String+scalarName = "binary64"++-- | Bytes occupied by one coordinate component.+scalarByteSize :: Int+scalarByteSize = 8++-- | Runtime-confirmed binary format of 'Double'.+scalarBinaryFormat :: BinaryFormat+scalarBinaryFormat =+  BinaryFormat+    { formatRadix = floatRadix (0 :: Double)+    , formatMantissaDigits = floatDigits (0 :: Double)+    , formatExponentRange = floatRange (0 :: Double)+    }++-- | Difference between one and the next representable value above one.+scalarEpsilon :: Double+scalarEpsilon = 2.220446049250313e-16++-- | Maximum relative rounding error of one binary64 operation.+scalarUnitRoundoff :: Double+scalarUnitRoundoff = 1.1102230246251565e-16++-- | Error coefficient for the filtered orientation predicate.+scalarCcwErrorBound :: Double+scalarCcwErrorBound = 3.3306690738754716e-16++-- | Error coefficient for the filtered in-circle predicate.+scalarInCircleErrorBound :: Double+scalarInCircleErrorBound = 1.1102230246251577e-15++-- | 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 smallest coordinate magnitude the exact predicates accept.+minimumAllowedCoordinate :: Double+minimumAllowedCoordinate = 1.793662034335766e-43++-- | The largest coordinate magnitude the exact predicates accept.+maximumAllowedCoordinate :: Double+maximumAllowedCoordinate = 3.2138760885179806e60
+ src-dcel/Moonlight/Triangulation/Alpha.hs view
@@ -0,0 +1,427 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Exact alpha births over one resident Delaunay triangulation. Geometry+-- remains owned by the DCEL and 'ExactCellSet'; this module supplies the+-- handle-indexed filtration section used by topology consumers.+module Moonlight.Triangulation.Alpha+  ( AlphaBirth+  , alphaBirthNumerator+  , alphaBirthDenominator+  , alphaBirthToDouble+  , alphaBirthFromRadiusSquared+  , AlphaFiltration+  , AlphaFiltrationError (..)+  , alphaFiltration+  , alphaFiltrationCellSet+  , alphaVertexBirth+  , alphaEdgeBirth+  , alphaFaceBirth+  , alphaFiltrationCriticalBirths+  , alphaComplexAtBirth+  , alphaComplexAtRadius+  , alphaShapeContainsFace+  ) where++import Control.DeepSeq (NFData)+import Data.Bifunctor (first)+import Data.Bits (shiftL)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Set qualified as Set+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import Data.Word (Word64)+import GHC.Generics (Generic)+import Moonlight.Triangulation.CellSet+  ( CellSelectionError+  , exactCellSet+  )+import Moonlight.Triangulation.Dcel qualified as Dcel+import Moonlight.Triangulation.Internal.HandleDefs+  ( FaceId (..)+  , UndirectedEdgeId (..)+  , VertexId (..)+  , directedPair+  , faceIdIndex+  , undirectedEdgeIdIndex+  , vertexIdIndex+  )+import Moonlight.Triangulation.Internal.CellSet+  ( ExactCellSet (..)+  , residentExactCellSet+  )+import Moonlight.Triangulation.Internal.Dyadic+  ( exactCircumradiusSquaredRational+  , exactQuarterSquaredDistanceRational+  , integerBitLength+  , integerRatioToDouble+  )+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactArithmeticError (..)+  , ExactRational+  , exactRationalDenominator+  , exactRationalFromFiniteDouble+  , exactRationalNumerator+  )+import Moonlight.Triangulation.Internal.Representation+  ( DelaunayTriangulation+  , Triangulation+  )+import Moonlight.Triangulation.Internal.Predicates (inDiametralCircle)+import Moonlight.Triangulation.Scalar (circumradiusSquaredWithinCoordinates)+import Moonlight.Triangulation.Types+  ( ConstraintMode (Unconstrained)+  , Point (..)+  , RadiusSquared+  , radiusSquaredValue+  )++-- | One exact squared-radius birth. The constructor is withheld so negative+-- exact rationals cannot masquerade as geometric radii.+data AlphaBirth = AlphaBirth !AlphaOrderKey !ExactRational+  deriving stock (Generic)+  deriving anyclass (NFData)++data AlphaOrderKey+  = NonPositiveAlphaOrder+  | PositiveAlphaOrder !Int !Word64+  deriving stock (Eq, Ord, Generic)+  deriving anyclass (NFData)++instance Eq AlphaBirth where+  AlphaBirth _ leftValue == AlphaBirth _ rightValue = leftValue == rightValue++instance Ord AlphaBirth where+  compare (AlphaBirth leftKey leftValue) (AlphaBirth rightKey rightValue) =+    case compare leftKey rightKey of+      EQ -> compare leftValue rightValue+      distinctKeyOrder -> distinctKeyOrder++instance Show AlphaBirth where+  showsPrec precedence (AlphaBirth _ value) =+    showParen+      (precedence > 10)+      (showString "AlphaBirth " . showsPrec 11 value)++-- | Numerator of the reduced exact squared-radius birth.+alphaBirthNumerator :: AlphaBirth -> Integer+alphaBirthNumerator (AlphaBirth _ value) = exactRationalNumerator value++-- | Positive denominator of the reduced exact squared-radius birth.+alphaBirthDenominator :: AlphaBirth -> Integer+alphaBirthDenominator (AlphaBirth _ value) = exactRationalDenominator value++-- | Binary64 display projection. Equality and filtration order must use the+-- 'AlphaBirth' itself, not this rounded view.+alphaBirthToDouble :: AlphaBirth -> Double+alphaBirthToDouble birth =+  integerRatioToDouble+    (alphaBirthNumerator birth)+    (alphaBirthDenominator birth)++-- | Embed an admitted binary64 threshold into the exact alpha order without+-- loss. Every finite binary64 value is a dyadic rational.+alphaBirthFromRadiusSquared :: RadiusSquared -> AlphaBirth+alphaBirthFromRadiusSquared =+  alphaBirthFromExact . exactRationalFromFiniteDouble . radiusSquaredValue++-- | The exact handle-indexed filtration of one Delaunay DCEL. The cell set is+-- the only geometry inventory; the maps are derived birth sections over those+-- resident handles.+data AlphaFiltration = AlphaFiltration+  { alphaFiltrationCells :: !ExactCellSet+  , alphaVertexBirths :: !(Vector AlphaBirth)+  , alphaEdgeBirths :: !(Vector AlphaBirth)+  , alphaFaceBirths :: !(Vector AlphaBirth)+  }++data FaceAlphaSection = FaceAlphaSection+  { faceAlphaBirth :: !AlphaBirth+  , faceAlphaVertices :: !(VertexId, VertexId, VertexId)+  }++-- | Typed obstruction to deriving the exact birth section from a resident+-- Delaunay triangulation. Every incidence failure retains the affected handle.+data AlphaFiltrationError+  = AlphaFiltrationCellSelection !CellSelectionError+  | AlphaFaceVerticesUnavailable !FaceId+  | AlphaFaceDegenerate !FaceId+  | AlphaCircumradiusDivisionFailed !FaceId !ExactArithmeticError+  | AlphaFaceEdgeIncidenceInvalid !FaceId !UndirectedEdgeId ![VertexId]+  | AlphaIncidentFaceBirthMissing !UndirectedEdgeId !FaceId+  | AlphaEdgeBirthWitnessMissing !UndirectedEdgeId+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Construct every exact alpha birth once. Faces descend first because a+-- non-Gabriel edge is born at the least incident-face circumradius.+alphaFiltration+  :: DelaunayTriangulation vertex+  -> Either AlphaFiltrationError AlphaFiltration+alphaFiltration triangulation = do+  cellSet <-+    first AlphaFiltrationCellSelection+      (residentExactCellSet triangulation)+  let vertexBirths = Vector.replicate (Dcel.numVertices triangulation) zeroAlphaBirth+  faceSections <-+    Vector.imapM+      (\faceIndex -> exactFaceSection triangulation (FaceId (fromIntegral (faceIndex + 1))))+      (Dcel.innerFaceVertexTriples triangulation)+  edgeBirths <-+    Vector.generateM+      (Dcel.numUndirectedEdges triangulation)+      (exactEdgeBirth faceSections triangulation . UndirectedEdgeId . fromIntegral)+  let faceBirths = fmap faceAlphaBirth faceSections+  pure+    AlphaFiltration+      { alphaFiltrationCells = cellSet+      , alphaVertexBirths = vertexBirths+      , alphaEdgeBirths = edgeBirths+      , alphaFaceBirths = faceBirths+      }++-- | The authoritative resident cells underlying this filtration. This is a+-- read-only projection rather than an exported record field, so callers cannot+-- splice births from one triangulation onto the cells of another.+alphaFiltrationCellSet :: AlphaFiltration -> ExactCellSet+alphaFiltrationCellSet = alphaFiltrationCells++-- | Exact birth of a resident vertex, when the handle belongs to this+-- filtration.+alphaVertexBirth :: AlphaFiltration -> VertexId -> Maybe AlphaBirth+alphaVertexBirth filtration vertex =+  alphaVertexBirths filtration Vector.!? vertexIdIndex vertex++-- | Exact birth of a resident undirected edge, when the handle belongs to this+-- filtration.+alphaEdgeBirth :: AlphaFiltration -> UndirectedEdgeId -> Maybe AlphaBirth+alphaEdgeBirth filtration edge =+  alphaEdgeBirths filtration Vector.!? undirectedEdgeIdIndex edge++-- | Exact birth of a resident bounded face, when the handle belongs to this+-- filtration.+alphaFaceBirth :: AlphaFiltration -> FaceId -> Maybe AlphaBirth+alphaFaceBirth filtration =+  faceBirthAt (alphaFaceBirths filtration)++-- | Distinct critical births in exact ascending order.+alphaFiltrationCriticalBirths :: AlphaFiltration -> [AlphaBirth]+alphaFiltrationCriticalBirths filtration =+  Set.toAscList+    ( Set.fromList+        ( Vector.toList (alphaVertexBirths filtration)+            <> Vector.toList (alphaEdgeBirths filtration)+            <> Vector.toList (alphaFaceBirths filtration)+        )+    )++-- | Select the closed alpha subcomplex at one exact birth. The resident DCEL+-- is retained; only its downward-closed cell section changes.+alphaComplexAtBirth+  :: AlphaBirth+  -> AlphaFiltration+  -> Either CellSelectionError ExactCellSet+alphaComplexAtBirth threshold filtration =+  case alphaFiltrationCells filtration of+    ExactCellSet triangulation _ _ _ ->+      exactCellSet+        triangulation+        (selectedHandles (VertexId . fromIntegral) (alphaVertexBirths filtration))+        (selectedHandles (UndirectedEdgeId . fromIntegral) (alphaEdgeBirths filtration))+        (selectedHandles (FaceId . fromIntegral . (+ 1)) (alphaFaceBirths filtration))+ where+  selectedHandles :: (Int -> handle) -> Vector AlphaBirth -> [handle]+  selectedHandles handleAt =+    Vector.ifoldr+      (\indexValue birthValue selected -> if birthValue <= threshold then handleAt indexValue : selected else selected)+      []++alphaComplexAtRadius+  :: RadiusSquared+  -> AlphaFiltration+  -> Either CellSelectionError ExactCellSet+alphaComplexAtRadius radius =+  alphaComplexAtBirth (alphaBirthFromRadiusSquared radius)++-- | Membership of a bounded face in the closed alpha shape. Exact dyadic+-- comparison makes equality independent of circumcenter rounding. This+-- specialized observation does not construct the full filtration.+alphaShapeContainsFace+  :: RadiusSquared+  -> Triangulation 'Unconstrained vertex directed undirected face+  -> FaceId+  -> Bool+alphaShapeContainsFace radius triangulation =+  maybe False withinRadius . Dcel.innerFaceVertices triangulation+ where+  threshold = radiusSquaredValue radius+  withinRadius (firstVertex, secondVertex, thirdVertex) =+    let Point ax ay = Dcel.vertexPoint triangulation firstVertex+        Point bx by = Dcel.vertexPoint triangulation secondVertex+        Point cx cy = Dcel.vertexPoint triangulation thirdVertex+     in circumradiusSquaredWithinCoordinates threshold ax ay bx by cx cy++zeroAlphaBirth :: AlphaBirth+zeroAlphaBirth = alphaBirthFromExact 0++exactFaceSection+  :: DelaunayTriangulation vertex+  -> FaceId+  -> (VertexId, VertexId, VertexId)+  -> Either AlphaFiltrationError FaceAlphaSection+exactFaceSection triangulation face verticesValue@(firstVertex, secondVertex, thirdVertex) =+  let Point ax ay = Dcel.vertexPoint triangulation firstVertex+      Point bx by = Dcel.vertexPoint triangulation secondVertex+      Point cx cy = Dcel.vertexPoint triangulation thirdVertex+   in case exactCircumradiusSquaredRational ax ay bx by cx cy of+        Left ExactZeroDivisor -> Left (AlphaFaceDegenerate face)+        Left arithmeticError -> Left (AlphaCircumradiusDivisionFailed face arithmeticError)+        Right exactBirth ->+          Right+            FaceAlphaSection+              { faceAlphaBirth = alphaBirthFromExact exactBirth+              , faceAlphaVertices = verticesValue+              }++exactEdgeBirth+  :: Vector FaceAlphaSection+  -> DelaunayTriangulation vertex+  -> UndirectedEdgeId+  -> Either AlphaFiltrationError AlphaBirth+exactEdgeBirth faceSections triangulation edge = do+  let (fromVertex, toVertex) = Dcel.undirectedEndpoints triangulation edge+      fromPoint = Dcel.vertexPoint triangulation fromVertex+      toPoint = Dcel.vertexPoint triangulation toVertex+      incidentFaces = innerIncidentFaces triangulation edge+  oppositeVertices <-+    traverse+      (oppositeVertexAcross faceSections triangulation edge fromVertex toVertex)+      incidentFaces+  let oppositePoints = fmap (Dcel.vertexPoint triangulation) oppositeVertices+  if all (diametralWitnessOutside fromPoint toPoint) oppositePoints+    then pure (alphaBirthFromExact (quarterSquaredPointDistance fromPoint toPoint))+    else leastIncidentFaceBirth edge faceSections incidentFaces++innerIncidentFaces+  :: DelaunayTriangulation vertex+  -> UndirectedEdgeId+  -> [FaceId]+innerIncidentFaces triangulation edge =+  let (forward, backward) = directedPair edge+      forwardFace = Dcel.incidentFace triangulation forward+      backwardFace = Dcel.incidentFace triangulation backward+   in case (forwardFace == Dcel.outerFace, backwardFace == Dcel.outerFace) of+        (True, True) -> []+        (False, True) -> [forwardFace]+        (True, False) -> [backwardFace]+        (False, False)+          | forwardFace == backwardFace -> [forwardFace]+          | forwardFace < backwardFace -> [forwardFace, backwardFace]+          | otherwise -> [backwardFace, forwardFace]++oppositeVertexAcross+  :: Vector FaceAlphaSection+  -> DelaunayTriangulation vertex+  -> UndirectedEdgeId+  -> VertexId+  -> VertexId+  -> FaceId+  -> Either AlphaFiltrationError VertexId+oppositeVertexAcross faceSections triangulation edge fromVertex toVertex face =+  case faceSectionAt faceSections face of+    Nothing ->+      Left+        (AlphaFaceEdgeIncidenceInvalid face edge (Dcel.faceVertices triangulation face))+    Just faceSection ->+      let verticesValue@(firstVertex, secondVertex, thirdVertex) = faceAlphaVertices faceSection+          outsideEdge vertex = vertex /= fromVertex && vertex /= toVertex+       in case+            ( outsideEdge firstVertex+            , outsideEdge secondVertex+            , outsideEdge thirdVertex+            )+          of+            (True, False, False) -> Right firstVertex+            (False, True, False) -> Right secondVertex+            (False, False, True) -> Right thirdVertex+            _ ->+              Left+                ( AlphaFaceEdgeIncidenceInvalid+                    face+                    edge+                    (filter outsideEdge (triangleVertices verticesValue))+                )++diametralWitnessOutside :: Point -> Point -> Point -> Bool+diametralWitnessOutside firstPoint secondPoint =+  not . inDiametralCircle firstPoint secondPoint++quarterSquaredPointDistance :: Point -> Point -> ExactRational+quarterSquaredPointDistance (Point ax ay) (Point bx by) =+  exactQuarterSquaredDistanceRational ax ay bx by++leastIncidentFaceBirth+  :: UndirectedEdgeId+  -> Vector FaceAlphaSection+  -> [FaceId]+  -> Either AlphaFiltrationError AlphaBirth+leastIncidentFaceBirth edge faceSections incidentFaces = do+  births <-+    traverse+      (\face -> maybe (Left (AlphaIncidentFaceBirthMissing edge face)) (Right . faceAlphaBirth) (faceSectionAt faceSections face))+      incidentFaces+  case NonEmpty.nonEmpty births of+    Nothing -> Left (AlphaEdgeBirthWitnessMissing edge)+    Just nonEmptyBirths -> Right (minimum nonEmptyBirths)++faceSectionAt :: Vector FaceAlphaSection -> FaceId -> Maybe FaceAlphaSection+faceSectionAt faceSections face+  | face == Dcel.outerFace = Nothing+  | otherwise = faceSections Vector.!? (faceIdIndex face - 1)++faceBirthAt :: Vector AlphaBirth -> FaceId -> Maybe AlphaBirth+faceBirthAt faceBirths face+  | face == Dcel.outerFace = Nothing+  | otherwise = faceBirths Vector.!? (faceIdIndex face - 1)++triangleVertices :: (VertexId, VertexId, VertexId) -> [VertexId]+triangleVertices (firstVertex, secondVertex, thirdVertex) =+  [firstVertex, secondVertex, thirdVertex]++alphaBirthFromExact :: ExactRational -> AlphaBirth+alphaBirthFromExact exactValue =+  AlphaBirth (alphaOrderKey exactValue) exactValue++-- | A monotone exact fixed-point projection of the positive rational. Distinct+-- keys prove order; collisions descend to the authoritative rational. One+-- division at birth replaces repeated cross-products during every downstream+-- ordered-map comparison.+alphaOrderKey :: ExactRational -> AlphaOrderKey+alphaOrderKey exactValue =+  let numerator = exactRationalNumerator exactValue+      denominator = exactRationalDenominator exactValue+   in if numerator <= 0+        then NonPositiveAlphaOrder+        else+          let candidateExponent = integerBitLength numerator - integerBitLength denominator+              binaryExponent =+                if candidateExponent >= 0+                  then+                    if numerator < denominator `shiftL` candidateExponent+                      then candidateExponent - 1+                      else candidateExponent+                else+                  if numerator `shiftL` negate candidateExponent < denominator+                    then candidateExponent - 1+                    else candidateExponent+              scale = alphaOrderFractionBits - binaryExponent+              scaledMantissa =+                if scale >= 0+                  then (numerator `shiftL` scale) `quot` denominator+                  else numerator `quot` (denominator `shiftL` negate scale)+           in PositiveAlphaOrder binaryExponent (fromIntegral scaledMantissa)++alphaOrderFractionBits :: Int+alphaOrderFractionBits = 16
+ src-dcel/Moonlight/Triangulation/Canonical.hs view
@@ -0,0 +1,6 @@+-- | Construction-independent resident numbering for explicit global comparison.+module Moonlight.Triangulation.Canonical+  ( canonicalize+  ) where++import Moonlight.Triangulation.Internal.Canonical (canonicalize)
+ 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
@@ -0,0 +1,402 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}++-- | Constant-time fixed-index observations and persistent payload updates over+-- the immutable DCEL. This is the explicit unchecked resident-index kernel;+-- ordinary consumers should use scoped or owning handles so indices cannot+-- cross mesh boundaries.+module Moonlight.Triangulation.Dcel+  ( outerFace+  , numVertices+  , numDirectedEdges+  , numUndirectedEdges+  , numFaces+  , numInnerFaces+  , vertexPoint+  , vertexPoints+  , vertexData+  , directedEdgeData+  , undirectedEdgeData+  , faceData+  , setVertexData+  , setDirectedEdgeData+  , setUndirectedEdgeData+  , setFaceData+  , mapVertices+  , mapDirectedEdges+  , mapUndirectedEdges+  , mapFaces+  , imapUndirectedEdges+  , imapFaces+  , vertexOutEdge+  , adjacentEdge+  , origin+  , destination+  , next+  , previous+  , incidentFace+  , isOuterDirectedEdge+  , isBoundaryEdge+  , isConstraintEdge+  , numConstraints+  , undirectedEndpoints+  , faceDirectedEdges+  , faceVertices+  , innerFaceDirectedEdges+  , innerFaceDirectedEdgeTriples+  , innerFaceVertices+  , innerFaceVertexTriples+  , vertexOutgoingEdges+  , clockwise+  , counterClockwise+  , foldFaceDirectedEdges'+  , foldVertexOutgoingEdges'+  , topologyIndexBytes+  , geometryTopologyBytes+  ) where++import qualified Data.Vector as V+import Data.Word (Word8)+import GHC.Exts (build)+import Moonlight.Triangulation.Internal.BoxedPaged (boxedUnsafeIndex, boxedUpdate)+import Moonlight.Triangulation.Internal.Paged (pagedLength, pagedUnsafeIndex)+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Internal.PackedIndex (unpackOptionalIndex)+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Scalar (scalarByteSize)++-- | The unique unbounded face, always stored at index zero.+outerFace :: FaceId+outerFace = FaceId 0++-- | Number of vertices in the mesh.+numVertices :: Triangulation mode vertex directed undirected face -> Int+numVertices = pagedLength . triPointX+{-# INLINE numVertices #-}++-- | Number of oriented half-edges in the mesh.+numDirectedEdges :: Triangulation mode vertex directed undirected face -> Int+numDirectedEdges = (`quot` 4) . pagedLength . triHalfTopology+{-# INLINE numDirectedEdges #-}++-- | Number of twin pairs in the mesh.+numUndirectedEdges :: Triangulation mode vertex directed undirected face -> Int+numUndirectedEdges triangulation = numDirectedEdges triangulation `quot` 2+{-# INLINE numUndirectedEdges #-}++-- | Number of faces, including 'outerFace'.+numFaces :: Triangulation mode vertex directed undirected face -> Int+numFaces = pagedLength . triFaceEdge+{-# INLINE numFaces #-}++-- | Number of bounded triangular faces.+numInnerFaces :: Triangulation mode vertex directed undirected face -> Int+numInnerFaces triangulation = max 0 (numFaces triangulation - 1)+{-# INLINE numInnerFaces #-}++-- | Authoritative geometric position of an admitted vertex handle.+vertexPoint :: Triangulation mode vertex directed undirected face -> VertexId -> Point+vertexPoint triangulation vertex =+  let !index = vertexIdIndex vertex+   in Point (pagedUnsafeIndex (triPointX triangulation) index) (pagedUnsafeIndex (triPointY triangulation) index)+{-# INLINE vertexPoint #-}++-- | Dense vertex positions in handle order.+vertexPoints :: Triangulation mode vertex directed undirected face -> V.Vector Point+vertexPoints triangulation =+  V.generate (numVertices triangulation) (vertexPoint triangulation . VertexId . fromIntegral)+{-# INLINE vertexPoints #-}++-- | Annotation carried by an admitted vertex handle.+vertexData :: Triangulation mode vertex directed undirected face -> VertexId -> vertex+vertexData triangulation vertex =+  boxedUnsafeIndex (triVertexData triangulation) (vertexIdIndex vertex)+{-# INLINE vertexData #-}++-- | Annotation carried by an admitted directed edge.+directedEdgeData :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> directed+directedEdgeData triangulation edge =+  boxedUnsafeIndex (triDirectedData triangulation) (directedEdgeIdIndex edge)+{-# INLINE directedEdgeData #-}++-- | Annotation carried by an admitted undirected edge.+undirectedEdgeData :: Triangulation mode vertex directed undirected face -> UndirectedEdgeId -> undirected+undirectedEdgeData triangulation edge =+  boxedUnsafeIndex (triUndirectedData triangulation) (undirectedEdgeIdIndex edge)+{-# INLINE undirectedEdgeData #-}++-- | Annotation carried by an admitted face.+faceData :: Triangulation mode vertex directed undirected face -> FaceId -> face+faceData triangulation face =+  boxedUnsafeIndex (triFaceData triangulation) (faceIdIndex face)+{-# INLINE faceData #-}++-- | Replace one vertex annotation without changing geometry or topology.+setVertexData+  :: Triangulation mode vertex directed undirected face+  -> VertexId+  -> vertex+  -> Triangulation mode vertex directed undirected face+setVertexData triangulation vertex payload =+  triangulation{triVertexData = boxedUpdate (vertexIdIndex vertex) payload (triVertexData triangulation)}++-- | Replace one directed-edge annotation without changing geometry or topology.+setDirectedEdgeData+  :: Triangulation mode vertex directed undirected face+  -> DirectedEdgeId+  -> directed+  -> Triangulation mode vertex directed undirected face+setDirectedEdgeData triangulation edge payload =+  triangulation{triDirectedData = boxedUpdate (directedEdgeIdIndex edge) payload (triDirectedData triangulation)}++-- | Replace one undirected-edge annotation without changing geometry or topology.+setUndirectedEdgeData+  :: Triangulation mode vertex directed undirected face+  -> UndirectedEdgeId+  -> undirected+  -> Triangulation mode vertex directed undirected face+setUndirectedEdgeData triangulation edge payload =+  triangulation{triUndirectedData = boxedUpdate (undirectedEdgeIdIndex edge) payload (triUndirectedData triangulation)}++-- | Replace one face annotation without changing geometry or topology.+setFaceData+  :: Triangulation mode vertex directed undirected face+  -> FaceId+  -> face+  -> Triangulation mode vertex directed undirected face+setFaceData triangulation face payload =+  triangulation{triFaceData = boxedUpdate (faceIdIndex face) payload (triFaceData triangulation)}++-- | One outgoing directed edge, if the vertex is connected.+vertexOutEdge :: Triangulation mode vertex directed undirected face -> VertexId -> Maybe DirectedEdgeId+vertexOutEdge triangulation vertex =+  DirectedEdgeId . fromIntegral <$> unpackOptionalIndex (pagedUnsafeIndex (triVertexOut triangulation) (vertexIdIndex vertex))+{-# INLINE vertexOutEdge #-}++-- | One boundary edge of a face, if the face has a boundary.+adjacentEdge :: Triangulation mode vertex directed undirected face -> FaceId -> Maybe DirectedEdgeId+adjacentEdge triangulation face =+  DirectedEdgeId . fromIntegral <$> unpackOptionalIndex (pagedUnsafeIndex (triFaceEdge triangulation) (faceIdIndex face))+{-# INLINE adjacentEdge #-}++-- | Origin vertex of an admitted directed edge.+origin :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> VertexId+origin triangulation edge =+  VertexId (pagedUnsafeIndex (triHalfTopology triangulation) (4 * directedEdgeIdIndex edge))+{-# INLINE origin #-}++-- | Destination vertex of an admitted directed edge.+destination :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> VertexId+destination triangulation = origin triangulation . reverseEdge+{-# INLINE destination #-}++-- | Next directed edge around the incident face.+next :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> DirectedEdgeId+next triangulation edge =+  DirectedEdgeId (pagedUnsafeIndex (triHalfTopology triangulation) (4 * directedEdgeIdIndex edge + 1))+{-# INLINE next #-}++-- | Previous directed edge around the incident face.+previous :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> DirectedEdgeId+previous triangulation edge =+  DirectedEdgeId (pagedUnsafeIndex (triHalfTopology triangulation) (4 * directedEdgeIdIndex edge + 2))+{-# INLINE previous #-}++-- | Face on the left of an admitted directed edge.+incidentFace :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> FaceId+incidentFace triangulation edge =+  FaceId (pagedUnsafeIndex (triHalfTopology triangulation) (4 * directedEdgeIdIndex edge + 3))+{-# INLINE incidentFace #-}++-- | Whether the directed edge is incident to the unbounded face.+isOuterDirectedEdge :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> Bool+isOuterDirectedEdge triangulation edge = incidentFace triangulation edge == outerFace+{-# INLINE isOuterDirectedEdge #-}++-- | Whether either orientation is incident to the outer face.+isBoundaryEdge :: Triangulation mode vertex directed undirected face -> UndirectedEdgeId -> Bool+isBoundaryEdge triangulation edge =+  let (forward, backward) = directedPair edge+   in isOuterDirectedEdge triangulation forward || isOuterDirectedEdge triangulation backward+{-# INLINE isBoundaryEdge #-}++-- | Whether the edge belongs to the constrained-edge section.+isConstraintEdge :: Triangulation mode vertex directed undirected face -> UndirectedEdgeId -> Bool+isConstraintEdge triangulation edge =+  pagedUnsafeIndex (triConstraint triangulation) (undirectedEdgeIdIndex edge) /= (0 :: Word8)+{-# INLINE isConstraintEdge #-}++-- | Number of constrained undirected edges.+numConstraints :: Triangulation mode vertex directed undirected face -> Int+numConstraints = triConstraintCount+{-# INLINE numConstraints #-}++-- | Endpoints in the normalized orientation.+undirectedEndpoints :: Triangulation mode vertex directed undirected face -> UndirectedEdgeId -> (VertexId, VertexId)+undirectedEndpoints triangulation edge =+  let forward = normalizedDirected edge+   in (origin triangulation forward, destination triangulation forward)+{-# INLINE undirectedEndpoints #-}++-- | Boundary cycle of a face in traversal order.+faceDirectedEdges :: Triangulation mode vertex directed undirected face -> FaceId -> [DirectedEdgeId]+faceDirectedEdges triangulation face =+  case adjacentEdge triangulation face of+    Nothing -> []+    Just start -> circularWalk triangulation start (next triangulation)+{-# INLINE faceDirectedEdges #-}++-- | Origins along a face boundary cycle, in traversal order.+faceVertices :: Triangulation mode vertex directed undirected face -> FaceId -> [VertexId]+faceVertices triangulation = map (origin triangulation) . faceDirectedEdges triangulation+{-# INLINE faceVertices #-}++-- | 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 || faceIdIndex face >= numFaces triangulation = Nothing+  | otherwise = do+      e0 <- adjacentEdge triangulation face+      let !e1 = next triangulation e0+          !e2 = next triangulation e1+      if next triangulation e2 == e0+        then Just (e0, e1, e2)+        else Nothing+{-# INLINE innerFaceDirectedEdges #-}++-- | 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+  (e0, e1, e2) <- innerFaceDirectedEdges triangulation face+  pure (origin triangulation e0, origin triangulation e1, origin triangulation e2)+{-# INLINE innerFaceVertices #-}++-- | Dense bounded-face vertex triples in face-handle order.+innerFaceVertexTriples+  :: Triangulation mode vertex directed undirected face+  -> V.Vector (VertexId, VertexId, VertexId)+innerFaceVertexTriples triangulation =+  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.+vertexOutgoingEdges :: Triangulation mode vertex directed undirected face -> VertexId -> [DirectedEdgeId]+vertexOutgoingEdges triangulation vertex =+  case vertexOutEdge triangulation vertex of+    Nothing -> []+    Just start -> circularWalk triangulation start (counterClockwise triangulation)+{-# INLINE vertexOutgoingEdges #-}++-- | Previous directed edge around its origin vertex.+clockwise :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> DirectedEdgeId+clockwise triangulation edge = next triangulation (reverseEdge edge)+{-# INLINE clockwise #-}++-- | Next directed edge around its origin vertex.+counterClockwise :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> DirectedEdgeId+counterClockwise triangulation edge = reverseEdge (previous triangulation edge)+{-# INLINE counterClockwise #-}++-- | Strict fold over the directed edges around a face.+foldFaceDirectedEdges'+  :: Triangulation mode vertex directed undirected face -> FaceId+  -> (a -> DirectedEdgeId -> a)+  -> a+  -> a+foldFaceDirectedEdges' triangulation face step initial =+  case adjacentEdge triangulation face of+    Nothing -> initial+    Just start -> circularFold triangulation start (next triangulation) step initial+{-# INLINE foldFaceDirectedEdges' #-}++-- | Strict fold over the directed edges originating at a vertex.+foldVertexOutgoingEdges'+  :: Triangulation mode vertex directed undirected face -> VertexId+  -> (a -> DirectedEdgeId -> a)+  -> a+  -> a+foldVertexOutgoingEdges' triangulation vertex step initial =+  case vertexOutEdge triangulation vertex of+    Nothing -> initial+    Just start -> circularFold triangulation start (counterClockwise triangulation) step initial+{-# INLINE foldVertexOutgoingEdges' #-}++-- Constraint bytes are intentionally reported separately by the CDT layer.+-- | Bytes occupied by vertex, half-edge, and face topology indices.+topologyIndexBytes :: Triangulation mode vertex directed undirected face -> Integer+topologyIndexBytes triangulation =+  4 * toInteger+    ( pagedLength (triVertexOut triangulation)+        + pagedLength (triHalfTopology triangulation)+        + pagedLength (triFaceEdge triangulation)+    )++-- | Bytes occupied by authoritative coordinates and topology indices.+geometryTopologyBytes :: Triangulation mode vertex directed undirected face -> Integer+geometryTopologyBytes triangulation =+  2 * toInteger scalarByteSize * toInteger (numVertices triangulation)+    + topologyIndexBytes triangulation++-- | The cycle reached from an edge by repeated advance, in visit order.+--+-- Emitted forwards. Consing in reverse and reversing at the end is the right+-- shape for a strict accumulator, and the wrong one for a producer: it built+-- the ring twice and handed back a list no consumer could fuse with. The+-- guard bound is on the steps taken, which is what it was before — the two+-- forms stop after the same edges.+circularWalk+  :: Triangulation mode vertex directed undirected face -> DirectedEdgeId+  -> (DirectedEdgeId -> DirectedEdgeId)+  -> [DirectedEdgeId]+circularWalk triangulation start advance =+  build+    ( \(link :: DirectedEdgeId -> result -> result) (stop :: result) ->+        let go :: Int -> DirectedEdgeId -> Bool -> result+            go !remaining !current !visited+              | remaining <= 0 = stop+              | visited && current == start = stop+              | otherwise = link current (go (remaining - 1) (advance current) True)+         in go (numDirectedEdges triangulation + 1) start False+    )+{-# INLINE circularWalk #-}++circularFold+  :: forall mode vertex directed undirected face a.+     Triangulation mode vertex directed undirected face -> DirectedEdgeId+  -> (DirectedEdgeId -> DirectedEdgeId)+  -> (a -> DirectedEdgeId -> a)+  -> a+  -> a+circularFold triangulation start advance step =+  go (numDirectedEdges triangulation + 1) start False+ where+  go :: Int -> DirectedEdgeId -> Bool -> a -> a+  go !remaining !current !visited !accumulator+    | remaining <= 0 = accumulator+    | visited && current == start = accumulator+    | otherwise =+        let !nextAccumulator = step accumulator current+         in go (remaining - 1) (advance current) True nextAccumulator+{-# INLINE circularFold #-}
+ src-dcel/Moonlight/Triangulation/Exact.hs view
@@ -0,0 +1,1256 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Exact rational planar geometry over admitted binary64 points.+module Moonlight.Triangulation.Exact+  ( ExactRational+  , ExactArithmeticError (..)+  , exactRational+  , exactRationalNumerator+  , exactRationalDenominator+  , exactRationalBitWidth+  , exactDivide+  , ExactPoint+  , exactPoint+  , exactPointCoordinates+  , exactPointCross+  , exactPointBitWidth+  , ExactAffineLine+  , ExactHalfPlaneError (..)+  , exactAffineLine+  , exactAffineLineCoefficients+  , oppositeExactAffineLine+  , exactAffineLineIntersection+  , ExactClosedHalfPlane+  , exactClosedHalfPlane+  , exactClosedHalfPlaneFromDirectedEdge+  , exactClosedHalfPlaneLine+  , classifyExactPoint+  , ExactRetainedPolygon+  , exactRetainedPolygon+  , exactRetainedPolygonPoints+  , ExactClipDisposition (..)+  , ExactClipError (..)+  , ExactClipReceipt (..)+  , exactClipRetainedPolygon+  , ExactVector (..)+  , exactVectorFromPoints+  , addExactVectors+  , exactCross+  , compareExactVectorAngle+  , translateExactPoint+  , ExactRay+  , exactRay+  , exactRayOrigin+  , exactRayDirection+  , ExactSegment+  , ExactGeometryError (..)+  , exactSegment+  , exactSegmentEndpoints+  , exactPointFromPoint+  , exactPointFromQueryPoint+  , exactPointToEmbeddingCandidate+  , exactOrient2d+  , exactOnClosedSegment+  , SegmentRelation (..)+  , allSegmentRelations+  , exactSegmentRelation+  , ExactIntersectionError (..)+  , exactLineIntersection+  , exactSupportingLineIntersection+  ) where++import Control.DeepSeq (NFData)+import Control.Monad (foldM)+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (mapMaybe)+import qualified Data.Sequence as Sequence+import Data.Sequence (Seq, ViewL (..), ViewR (..), (|>))+import GHC.Generics (Generic)+import Moonlight.Triangulation.Internal.Dyadic (integerRatioToDouble)+import Moonlight.Triangulation.Internal.BoundaryCycle+  ( admitsSimpleCycleEdgeRelation+  , cyclePairsNonEmpty+  , firstNonCounterClockwiseTurn+  , unorderedPairs+  )+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactArithmeticError (..)+  , ExactRational+  , exactDivide+  , exactRational+  , exactRationalBitWidth+  , exactRationalDenominator+  , exactRationalDenominatorBitWidth+  , exactRationalFromFiniteDouble+  , exactRationalIsZero+  , 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)++-- | An exact affine line @a*x + b*y + c = 0@ with a nonzero normal.+data ExactAffineLine =+  ExactAffineLine !ExactRational !ExactRational !ExactRational+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | The closed left half-plane of an oriented affine line. A point belongs+-- when the line evaluation is nonnegative.+newtype ExactClosedHalfPlane = ExactClosedHalfPlane ExactAffineLine+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | One polygon vertex together with the original affine line supporting its+-- incoming edge. Intersections therefore never reconstruct a line from+-- already-derived endpoints.+data ExactRetainedVertex =+  ExactRetainedVertex !ExactPoint !ExactAffineLine+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A strict counter-clockwise convex polygon whose incoming edges retain+-- their original supporting equations.+newtype ExactRetainedPolygon =+  ExactRetainedPolygon (NonEmpty ExactRetainedVertex)+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Typed refusals from affine-line and retained-polygon admission.+data ExactHalfPlaneError+  = ExactAffineLineZeroNormal+      !ExactRational+      !ExactRational+      !ExactRational+  | ExactRetainedPolygonTooFewVertices !Int+  | ExactRetainedPolygonNonConvexTurn !Int !Ordering+  | ExactRetainedPolygonSelfRelation !Int !Int !SegmentRelation+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Dimensional disposition after exact closed-half-plane clipping.+data ExactClipDisposition+  = ExactClipFullDimensional !ExactRetainedPolygon+  | ExactClipLowerDimensional !(NonEmpty ExactPoint)+  | ExactClipEmpty+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Typed obstructions from an affine intersection that should be unique or+-- from an impossible orientation reversal during convex descent.+data ExactClipError+  = ExactClipIntersection !ExactIntersectionError+  | ExactClipOrientationReversed !ExactRational+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Structural work and exact-rational width observations for one angular+-- half-plane descent. Submitted half-planes exclude the domain; active+-- boundaries include domain edges admitted to the deque after+-- equal-direction coalescence; zero records a single-plane domain rejection+-- before deque construction.+-- Compatibility checks count deque endpoint predicates; intersections count+-- successful affine-line intersections actually evaluated. Widths describe+-- observed reduced values, not bounds.+data ExactClipReceipt = ExactClipReceipt+  { exactClipSubmittedHalfPlanes :: !Int+  , exactClipActiveBoundaries :: !Int+  , exactClipBoundaryCompatibilityChecks :: !Int+  , exactClipExactIntersections :: !Int+  , exactClipInputCoordinateBits :: !Int+  , exactClipMaximumAffineCoefficientBits :: !Int+  , exactClipPeakIntermediateCoordinateBits :: !Int+  , exactClipFinalCoordinateBits :: !Int+  , exactClipFinalDenominatorBits :: !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++instance Semigroup ExactClipReceipt where+  left <> right =+    ExactClipReceipt+      { exactClipSubmittedHalfPlanes =+          exactClipSubmittedHalfPlanes left + exactClipSubmittedHalfPlanes right+      , exactClipActiveBoundaries =+          exactClipActiveBoundaries left + exactClipActiveBoundaries right+      , exactClipBoundaryCompatibilityChecks =+          exactClipBoundaryCompatibilityChecks left+            + exactClipBoundaryCompatibilityChecks right+      , exactClipExactIntersections =+          exactClipExactIntersections left + exactClipExactIntersections right+      , exactClipInputCoordinateBits =+          max (exactClipInputCoordinateBits left) (exactClipInputCoordinateBits right)+      , exactClipMaximumAffineCoefficientBits =+          max+            (exactClipMaximumAffineCoefficientBits left)+            (exactClipMaximumAffineCoefficientBits right)+      , exactClipPeakIntermediateCoordinateBits =+          max+            (exactClipPeakIntermediateCoordinateBits left)+            (exactClipPeakIntermediateCoordinateBits right)+      , exactClipFinalCoordinateBits =+          max (exactClipFinalCoordinateBits left) (exactClipFinalCoordinateBits right)+      , exactClipFinalDenominatorBits =+          max (exactClipFinalDenominatorBits left) (exactClipFinalDenominatorBits right)+      }++instance Monoid ExactClipReceipt where+  mempty = ExactClipReceipt 0 0 0 0 0 0 0 0 0++-- | A strict exact segment whose endpoints are distinct.+data ExactSegment = ExactSegment !ExactPoint !ExactPoint+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | An exact half-line with an admitted nonzero direction.+data ExactRay = ExactRay !ExactPoint !ExactVector+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Witness-bearing refusals from exact segment construction.+data ExactGeometryError+  = ExactSegmentEndpointsCoincide !ExactPoint+  | ExactRayZeroDirection !ExactPoint+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Admit a half-line, rejecting the only direction that cannot carry one.+exactRay+  :: ExactPoint+  -> ExactVector+  -> Either ExactGeometryError ExactRay+exactRay originPoint direction@(ExactVector directionX directionY)+  | exactRationalIsZero directionX && exactRationalIsZero directionY =+      Left (ExactRayZeroDirection originPoint)+  | otherwise = Right (ExactRay originPoint direction)++-- | Finite endpoint of an exact ray.+exactRayOrigin :: ExactRay -> ExactPoint+exactRayOrigin (ExactRay originPoint _) = originPoint+{-# INLINE exactRayOrigin #-}++-- | Nonzero direction of an exact ray.+exactRayDirection :: ExactRay -> ExactVector+exactRayDirection (ExactRay _ direction) = direction+{-# INLINE exactRayDirection #-}++-- | 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 #-}++-- | Admit an affine line, refusing precisely the zero normal. Coefficients+-- are retained verbatim because their source identity, rather than a chosen+-- scalar normalization, is the point of this carrier.+exactAffineLine+  :: ExactRational+  -> ExactRational+  -> ExactRational+  -> Either ExactHalfPlaneError ExactAffineLine+exactAffineLine coefficientX coefficientY constant+  | exactRationalIsZero coefficientX+      && exactRationalIsZero coefficientY =+      Left+        ( ExactAffineLineZeroNormal+            coefficientX+            coefficientY+            constant+        )+  | otherwise =+      Right (ExactAffineLine coefficientX coefficientY constant)++-- | Read the retained coefficients @(a,b,c)@ of @a*x+b*y+c=0@.+exactAffineLineCoefficients+  :: ExactAffineLine+  -> (ExactRational, ExactRational, ExactRational)+exactAffineLineCoefficients (ExactAffineLine coefficientX coefficientY constant) =+  (coefficientX, coefficientY, constant)+{-# INLINE exactAffineLineCoefficients #-}++-- | Reverse the oriented normal without changing the geometric line.+-- Admission already proves the normal nonzero, so negation is total.+oppositeExactAffineLine :: ExactAffineLine -> ExactAffineLine+oppositeExactAffineLine (ExactAffineLine coefficientX coefficientY constant) =+  ExactAffineLine (negate coefficientX) (negate coefficientY) (negate constant)+{-# INLINE oppositeExactAffineLine #-}++-- | Intersect two admitted affine lines directly from their retained source+-- coefficients. A parallel pair retains the exact determinant witness.+exactAffineLineIntersection+  :: ExactAffineLine+  -> ExactAffineLine+  -> Either ExactIntersectionError ExactPoint+exactAffineLineIntersection+  (ExactAffineLine firstX firstY firstConstant)+  (ExactAffineLine secondX secondY secondConstant) =+    -- Descend in homogeneous integer coordinates and normalize each published+    -- coordinate once. Generic Ratio arithmetic would normalize every product+    -- in Cramer's rule even though those intermediate rationals are invisible.+    let (firstXNumerator, firstXDenominator) = exactRationalParts firstX+        (firstYNumerator, firstYDenominator) = exactRationalParts firstY+        (firstConstantNumerator, firstConstantDenominator) =+          exactRationalParts firstConstant+        (secondXNumerator, secondXDenominator) = exactRationalParts secondX+        (secondYNumerator, secondYDenominator) = exactRationalParts secondY+        (secondConstantNumerator, secondConstantDenominator) =+          exactRationalParts secondConstant+        determinantNumerator =+          firstXNumerator+            * secondYNumerator+            * secondXDenominator+            * firstYDenominator+            - secondXNumerator+              * firstYNumerator+              * firstXDenominator+              * secondYDenominator+        xNumerator =+          ( firstYNumerator+              * secondConstantNumerator+              * secondYDenominator+              * firstConstantDenominator+              - secondYNumerator+                * firstConstantNumerator+                * firstYDenominator+                * secondConstantDenominator+          )+            * firstXDenominator+            * secondXDenominator+        yNumerator =+          ( firstConstantNumerator+              * secondXNumerator+              * secondConstantDenominator+              * firstXDenominator+              - secondConstantNumerator+                * firstXNumerator+                * firstConstantDenominator+                * secondXDenominator+          )+            * firstYDenominator+            * secondYDenominator+        coordinateDenominator =+          determinantNumerator+            * firstConstantDenominator+            * secondConstantDenominator+     in if determinantNumerator == 0+          then Left (ExactIntersectionParallelOrDegenerate 0)+          else do+            x <- admitCoordinate xNumerator coordinateDenominator+            y <- admitCoordinate yNumerator coordinateDenominator+            pure (ExactPoint x y)+ where+  admitCoordinate numerator denominator =+    case exactRational numerator denominator of+      Left arithmeticError ->+        Left (ExactIntersectionArithmetic arithmeticError)+      Right coordinate -> Right coordinate++exactRationalParts :: ExactRational -> (Integer, Integer)+exactRationalParts value =+  (exactRationalNumerator value, exactRationalDenominator value)+{-# INLINE exactRationalParts #-}++-- | Orient an admitted affine line so its nonnegative side is retained.+exactClosedHalfPlane :: ExactAffineLine -> ExactClosedHalfPlane+exactClosedHalfPlane = ExactClosedHalfPlane+{-# INLINE exactClosedHalfPlane #-}++-- | Construct the closed half-plane to the left of a directed edge.+exactClosedHalfPlaneFromDirectedEdge+  :: ExactPoint+  -> ExactPoint+  -> Either ExactHalfPlaneError ExactClosedHalfPlane+exactClosedHalfPlaneFromDirectedEdge+  (ExactPoint fromX fromY)+  (ExactPoint toX toY) =+  exactClosedHalfPlane+    <$> exactAffineLine+      (fromY - toY)+      (toX - fromX)+      (toY * fromX - toX * fromY)++-- | Read the original affine boundary retained by a closed half-plane.+exactClosedHalfPlaneLine :: ExactClosedHalfPlane -> ExactAffineLine+exactClosedHalfPlaneLine (ExactClosedHalfPlane line) = line+{-# INLINE exactClosedHalfPlaneLine #-}++-- | Classify a point against a closed half-plane. 'GT' is strict interior,+-- 'EQ' lies on the boundary, and 'LT' is exterior.+classifyExactPoint :: ExactClosedHalfPlane -> ExactPoint -> Ordering+classifyExactPoint+  (ExactClosedHalfPlane (ExactAffineLine coefficientX coefficientY constant))+  (ExactPoint x y) =+  -- The common denominator is strictly positive, so its unnormalized integer+  -- numerator is already the authoritative sign witness.+  let (coefficientXNumerator, coefficientXDenominator) =+        exactRationalParts coefficientX+      (coefficientYNumerator, coefficientYDenominator) =+        exactRationalParts coefficientY+      (constantNumerator, constantDenominator) = exactRationalParts constant+      (xNumerator, xDenominator) = exactRationalParts x+      (yNumerator, yDenominator) = exactRationalParts y+      evaluationNumerator =+        coefficientXNumerator+          * xNumerator+          * coefficientYDenominator+          * yDenominator+          * constantDenominator+          + coefficientYNumerator+            * yNumerator+            * coefficientXDenominator+            * xDenominator+            * constantDenominator+          + constantNumerator+            * coefficientXDenominator+            * xDenominator+            * coefficientYDenominator+            * yDenominator+   in compare evaluationNumerator 0+{-# INLINE classifyExactPoint #-}++-- | Admit strict counter-clockwise convex points and retain the original+-- supporting line of every incoming edge.+exactRetainedPolygon+  :: NonEmpty ExactPoint+  -> Either ExactHalfPlaneError ExactRetainedPolygon+exactRetainedPolygon points+  | NonEmpty.length points < 3 =+      Left (ExactRetainedPolygonTooFewVertices (NonEmpty.length points))+  | otherwise =+      case firstNonCounterClockwiseTurn exactOrient2d points of+        Just (index, turn) ->+          Left (ExactRetainedPolygonNonConvexTurn index turn)+        Nothing -> do+          validateSimpleRetainedCycle points+          ExactRetainedPolygon+            <$> traverse retainIncomingLine (cyclePairsNonEmpty points)+ where+  retainIncomingLine (from, to) = do+    halfPlane <- exactClosedHalfPlaneFromDirectedEdge from to+    pure (ExactRetainedVertex to (exactClosedHalfPlaneLine halfPlane))++validateSimpleRetainedCycle+  :: NonEmpty ExactPoint+  -> Either ExactHalfPlaneError ()+validateSimpleRetainedCycle points =+  case+    [ (leftIndex, rightIndex, relation)+    | ( (leftIndex, (leftFrom, leftTo))+        , (rightIndex, (rightFrom, rightTo))+        ) <- unorderedPairs indexedEdges+    , let relation =+            exactSegmentRelation+              leftFrom+              leftTo+              rightFrom+              rightTo+    , not+        ( admitsSimpleCycleEdgeRelation+            segmentCount+            leftIndex+            rightIndex+            relation+        )+    ] of+    (leftIndex, rightIndex, relation) : _ ->+      Left+        ( ExactRetainedPolygonSelfRelation+            leftIndex+            rightIndex+            relation+        )+    [] -> Right ()+ where+  indexedEdges = zip [0 :: Int ..] (NonEmpty.toList (cyclePairsNonEmpty points))+  segmentCount = NonEmpty.length points++-- | Project the retained-edge carrier to its authoritative point cycle.+exactRetainedPolygonPoints :: ExactRetainedPolygon -> NonEmpty ExactPoint+exactRetainedPolygonPoints (ExactRetainedPolygon vertices) =+  fmap retainedVertexPoint vertices++-- | Intersect a retained convex polygon with exact closed half-planes.+-- Boundaries descend in exact angular order through one immutable deque;+-- every published edge retains one submitted source line, and derived+-- endpoints never become line coefficients.+exactClipRetainedPolygon+  :: ExactRetainedPolygon+  -> [ExactClosedHalfPlane]+  -> Either ExactClipError (ExactClipDisposition, ExactClipReceipt)+exactClipRetainedPolygon polygon halfPlanes = do+  let inputPoints = exactRetainedPolygonPoints polygon+      inputBits = maximumPointBitWidth inputPoints+      domainHalfPlanes = retainedPolygonHalfPlanes polygon+      allHalfPlanes = domainHalfPlanes <> halfPlanes+      initialReceipt =+        ExactClipReceipt+          { exactClipSubmittedHalfPlanes = length halfPlanes+          , exactClipActiveBoundaries =+              if null halfPlanes then NonEmpty.length inputPoints else 0+          , exactClipBoundaryCompatibilityChecks = 0+          , exactClipExactIntersections = 0+          , exactClipInputCoordinateBits = inputBits+          , exactClipMaximumAffineCoefficientBits =+              List.foldl'+                (\bits -> max bits . affineLineBitWidth . exactClosedHalfPlaneLine)+                0+                allHalfPlanes+          , exactClipPeakIntermediateCoordinateBits = inputBits+          , exactClipFinalCoordinateBits = inputBits+          , exactClipFinalDenominatorBits =+              maximumPointDenominatorBitWidth inputPoints+          }+  if null halfPlanes+    then pure (ExactClipFullDimensional polygon, initialReceipt)+    else case List.find (`excludesExactDomain` inputPoints) halfPlanes of+      Just _ ->+        pure+          ( ExactClipEmpty+          , initialReceipt+              { exactClipFinalCoordinateBits = 0+              , exactClipFinalDenominatorBits = 0+              }+          )+      Nothing -> do+        let orderedBoundaries =+              coalesceAngularBoundaries (fmap angularBoundary allHalfPlanes)+            descentReceipt =+              initialReceipt+                { exactClipActiveBoundaries = length orderedBoundaries+                }+        (openDeque, descendedReceipt) <-+          foldM insertAngularBoundary (Sequence.empty, descentReceipt) orderedBoundaries+        (closedDeque, accumulatedReceipt) <- closeAngularBoundaryDeque openDeque descendedReceipt+        (finalState, finalizedReceipt) <-+          angularBoundaryDequeState orderedBoundaries closedDeque accumulatedReceipt+        let disposition = exactClipStateDisposition finalState+            finalPoints = exactClipDispositionPoints disposition+            finalReceipt =+              finalizedReceipt+                { exactClipFinalCoordinateBits = maybe 0 maximumPointBitWidth finalPoints+                , exactClipFinalDenominatorBits =+                    maybe 0 maximumPointDenominatorBitWidth finalPoints+                }+        pure (disposition, finalReceipt)++-- | A linear functional attains its maximum over a convex polygon at a+-- vertex.  One half-plane whose closed side contains no domain vertex is+-- therefore an exact emptiness certificate; recognizing it before angular+-- descent avoids sorting a section that has no global point to glue.+excludesExactDomain+  :: ExactClosedHalfPlane+  -> NonEmpty ExactPoint+  -> Bool+excludesExactDomain halfPlane =+  all ((== LT) . classifyExactPoint halfPlane)++-- | One original source boundary together with its exact counter-clockwise+-- direction.  Equal-direction gluing retains one of these values verbatim.+data ExactAngularBoundary = ExactAngularBoundary+  { angularBoundaryLine :: !ExactAffineLine+  , angularBoundaryDirection :: !ExactVector+  }++angularBoundary :: ExactClosedHalfPlane -> ExactAngularBoundary+angularBoundary halfPlane =+  let line@(ExactAffineLine coefficientX coefficientY _) =+        exactClosedHalfPlaneLine halfPlane+   in ExactAngularBoundary+        { angularBoundaryLine = line+        , angularBoundaryDirection = ExactVector coefficientY (negate coefficientX)+        }++angularBoundaryHalfPlane :: ExactAngularBoundary -> ExactClosedHalfPlane+angularBoundaryHalfPlane = exactClosedHalfPlane . angularBoundaryLine+{-# INLINE angularBoundaryHalfPlane #-}++retainedPolygonHalfPlanes :: ExactRetainedPolygon -> [ExactClosedHalfPlane]+retainedPolygonHalfPlanes (ExactRetainedPolygon vertices) =+  fmap+    (exactClosedHalfPlane . retainedVertexIncomingLine)+    (NonEmpty.toList vertices)++-- | Descent over one angular stalk.  A stricter parallel boundary replaces a+-- weaker one; coincident boundaries retain the least original source line so+-- input permutations cannot alter the glued carrier.+coalesceAngularBoundaries :: [ExactAngularBoundary] -> [ExactAngularBoundary]+coalesceAngularBoundaries =+  fmap strongestAngularBoundary+    . mapMaybe NonEmpty.nonEmpty+    . List.groupBy sameBoundaryDirection+    . List.sortBy compareAngularBoundaries+ where+  sameBoundaryDirection left right =+    compareExactVectorAngle+      (angularBoundaryDirection left)+      (angularBoundaryDirection right)+      == EQ++compareAngularBoundaries :: ExactAngularBoundary -> ExactAngularBoundary -> Ordering+compareAngularBoundaries left right =+  case+    compareExactVectorAngle+      (angularBoundaryDirection left)+      (angularBoundaryDirection right) of+    EQ -> compare (angularBoundaryLine left) (angularBoundaryLine right)+    ordering -> ordering++strongestAngularBoundary :: NonEmpty ExactAngularBoundary -> ExactAngularBoundary+strongestAngularBoundary (initial :| remaining) =+  List.foldl' chooseStrongerAngularBoundary initial remaining++chooseStrongerAngularBoundary+  :: ExactAngularBoundary+  -> ExactAngularBoundary+  -> ExactAngularBoundary+chooseStrongerAngularBoundary selected candidate =+  case compareParallelBoundaryStrength selected candidate of+    LT -> candidate+    GT -> selected+    EQ ->+      if angularBoundaryLine candidate < angularBoundaryLine selected+        then candidate+        else selected++-- | Compare same-direction boundaries.  'LT' means the right boundary is+-- stricter, 'GT' means the left is stricter, and 'EQ' means the closed+-- half-planes coincide.  Cross multiplication avoids inventing a normalized+-- replacement line.+compareParallelBoundaryStrength+  :: ExactAngularBoundary+  -> ExactAngularBoundary+  -> Ordering+compareParallelBoundaryStrength left right =+  let ExactAffineLine leftX leftY leftConstant = angularBoundaryLine left+      ExactAffineLine rightX rightY rightConstant = angularBoundaryLine right+      compareScaled leftScale rightScale scaleSign =+        let raw = compare (rightConstant * leftScale) (rightScale * leftConstant)+         in if exactSignum scaleSign == LT then reverseOrdering raw else raw+   in if exactRationalIsZero leftX+        then compareScaled leftY rightY leftY+        else compareScaled leftX rightX leftX++reverseOrdering :: Ordering -> Ordering+reverseOrdering LT = GT+reverseOrdering EQ = EQ+reverseOrdering GT = LT++-- | One active source boundary and its cached intersection with the preceding+-- deque boundary.  Every adjacency point is derived once and reused by both+-- compatibility trims and final publication.+data ExactAngularBoundaryNode = ExactAngularBoundaryNode+  { angularNodeBoundary :: !ExactAngularBoundary+  , angularNodePreviousIntersection :: !(Maybe ExactPoint)+  }++type ExactAngularBoundaryDeque = Seq ExactAngularBoundaryNode++insertAngularBoundary+  :: (ExactAngularBoundaryDeque, ExactClipReceipt)+  -> ExactAngularBoundary+  -> Either ExactClipError (ExactAngularBoundaryDeque, ExactClipReceipt)+insertAngularBoundary (boundaries, receipt) incoming = do+  (backTrimmed, backReceipt) <- trimAngularBack incoming boundaries receipt+  (frontTrimmed, frontReceipt) <- trimAngularFront incoming backTrimmed backReceipt+  appendAngularBoundary incoming frontTrimmed frontReceipt++appendAngularBoundary+  :: ExactAngularBoundary+  -> ExactAngularBoundaryDeque+  -> ExactClipReceipt+  -> Either ExactClipError (ExactAngularBoundaryDeque, ExactClipReceipt)+appendAngularBoundary incoming boundaries receipt =+  case Sequence.viewr boundaries of+    EmptyR ->+      Right+        ( Sequence.singleton (ExactAngularBoundaryNode incoming Nothing)+        , receipt+        )+    _ :> finalNode -> do+      (intersection, observedReceipt) <-+        observeAdjacentIntersection+          (angularNodeBoundary finalNode)+          incoming+          receipt+      pure+        ( boundaries+            |> ExactAngularBoundaryNode incoming intersection+        , observedReceipt+        )++trimAngularBack+  :: ExactAngularBoundary+  -> ExactAngularBoundaryDeque+  -> ExactClipReceipt+  -> Either ExactClipError (ExactAngularBoundaryDeque, ExactClipReceipt)+trimAngularBack incoming boundaries receipt =+  case Sequence.viewr boundaries of+    EmptyR -> Right (boundaries, receipt)+    remaining :> finalNode ->+      case Sequence.viewr remaining of+        EmptyR -> Right (boundaries, receipt)+        _ :> _ ->+          case angularNodePreviousIntersection finalNode of+            Nothing -> Right (boundaries, receipt)+            Just point ->+              let checkedReceipt = observeBoundaryCompatibility receipt+               in if classifyExactPoint (angularBoundaryHalfPlane incoming) point == LT+                    then trimAngularBack incoming remaining checkedReceipt+                    else Right (boundaries, checkedReceipt)++trimAngularFront+  :: ExactAngularBoundary+  -> ExactAngularBoundaryDeque+  -> ExactClipReceipt+  -> Either ExactClipError (ExactAngularBoundaryDeque, ExactClipReceipt)+trimAngularFront incoming boundaries receipt =+  case Sequence.viewl boundaries of+    EmptyL -> Right (boundaries, receipt)+    _ :< remaining ->+      case Sequence.viewl remaining of+        EmptyL -> Right (boundaries, receipt)+        secondNode :< suffix ->+          case angularNodePreviousIntersection secondNode of+            Nothing -> Right (boundaries, receipt)+            Just point ->+              let checkedReceipt = observeBoundaryCompatibility receipt+               in if classifyExactPoint (angularBoundaryHalfPlane incoming) point == LT+                    then+                      trimAngularFront+                        incoming+                        ( secondNode+                            { angularNodePreviousIntersection = Nothing+                            }+                            Sequence.<| suffix+                        )+                        checkedReceipt+                    else Right (boundaries, checkedReceipt)++closeAngularBoundaryDeque+  :: ExactAngularBoundaryDeque+  -> ExactClipReceipt+  -> Either ExactClipError (ExactAngularBoundaryDeque, ExactClipReceipt)+closeAngularBoundaryDeque boundaries receipt = do+  (backClosed, backReceipt) <- closeAngularBack boundaries receipt+  (frontClosed, frontReceipt) <- closeAngularFront backClosed backReceipt+  if Sequence.length frontClosed == Sequence.length boundaries+    then Right (frontClosed, frontReceipt)+    else closeAngularBoundaryDeque frontClosed frontReceipt++closeAngularBack+  :: ExactAngularBoundaryDeque+  -> ExactClipReceipt+  -> Either ExactClipError (ExactAngularBoundaryDeque, ExactClipReceipt)+closeAngularBack boundaries receipt =+  case (Sequence.viewl boundaries, Sequence.viewr boundaries) of+    (firstNode :< _, remaining :> finalNode) ->+      case Sequence.viewr remaining of+        _ :> _ ->+          case angularNodePreviousIntersection finalNode of+            Nothing -> Right (boundaries, receipt)+            Just point ->+              let checkedReceipt = observeBoundaryCompatibility receipt+               in if+                    classifyExactPoint+                      (angularBoundaryHalfPlane (angularNodeBoundary firstNode))+                      point+                      == LT+                    then closeAngularBack remaining checkedReceipt+                    else Right (boundaries, checkedReceipt)+        EmptyR -> Right (boundaries, receipt)+    _ -> Right (boundaries, receipt)++closeAngularFront+  :: ExactAngularBoundaryDeque+  -> ExactClipReceipt+  -> Either ExactClipError (ExactAngularBoundaryDeque, ExactClipReceipt)+closeAngularFront boundaries receipt =+  case (Sequence.viewl boundaries, Sequence.viewr boundaries) of+    (_ :< remaining, _ :> finalNode) ->+      case Sequence.viewl remaining of+        secondNode :< suffix ->+          case angularNodePreviousIntersection secondNode of+            Nothing -> Right (boundaries, receipt)+            Just point ->+              let checkedReceipt = observeBoundaryCompatibility receipt+               in if+                    classifyExactPoint+                      (angularBoundaryHalfPlane (angularNodeBoundary finalNode))+                      point+                      == LT+                    then+                      closeAngularFront+                        ( secondNode+                            { angularNodePreviousIntersection = Nothing+                            }+                            Sequence.<| suffix+                        )+                        checkedReceipt+                    else Right (boundaries, checkedReceipt)+        EmptyL -> Right (boundaries, receipt)+    _ -> Right (boundaries, receipt)++observeAdjacentIntersection+  :: ExactAngularBoundary+  -> ExactAngularBoundary+  -> ExactClipReceipt+  -> Either ExactClipError (Maybe ExactPoint, ExactClipReceipt)+observeAdjacentIntersection left right receipt =+  let leftLine = angularBoundaryLine left+      rightLine = angularBoundaryLine right+   in case exactAffineLineIntersection leftLine rightLine of+        Left (ExactIntersectionParallelOrDegenerate _) ->+          Right (Nothing, receipt)+        Left obstruction -> Left (ExactClipIntersection obstruction)+        Right point ->+          pure+            ( Just point+            , receipt+                { exactClipExactIntersections =+                    exactClipExactIntersections receipt + 1+                , exactClipPeakIntermediateCoordinateBits =+                    max+                      (exactClipPeakIntermediateCoordinateBits receipt)+                      (exactPointBitWidth point)+                }+            )++observeBoundaryCompatibility :: ExactClipReceipt -> ExactClipReceipt+observeBoundaryCompatibility receipt =+  receipt+    { exactClipBoundaryCompatibilityChecks =+        exactClipBoundaryCompatibilityChecks receipt + 1+    }++angularBoundaryDequeState+  :: [ExactAngularBoundary]+  -> ExactAngularBoundaryDeque+  -> ExactClipReceipt+  -> Either ExactClipError (ExactClipState, ExactClipReceipt)+angularBoundaryDequeState allBoundaries boundaries receipt = do+  let nodeList = foldr (:) [] boundaries+      linearVertices =+        mapMaybe+          retainedLinearVertex+          (zip nodeList (drop 1 nodeList))+  (closingVertices, finalizedReceipt) <-+    case (Sequence.viewl boundaries, Sequence.viewr boundaries) of+      (firstNode :< _, _ :> finalNode) -> do+        (intersection, observedReceipt) <-+          observeAdjacentIntersection+            (angularNodeBoundary finalNode)+            (angularNodeBoundary firstNode)+            receipt+        pure+          ( maybe+              []+              (\point ->+                 [ ExactRetainedVertex+                     point+                     (angularBoundaryLine (angularNodeBoundary finalNode))+                 ])+              intersection+          , observedReceipt+          )+      _ -> Right ([], receipt)+  state <-+    retainedVerticesToClipState+      (normalizeRetainedVertices (linearVertices <> closingVertices))+  pure (validateLowerDimensionalState allBoundaries state, finalizedReceipt)+ where+  retainedLinearVertex (node, successor) =+    fmap+      (\point ->+         ExactRetainedVertex+           point+           (angularBoundaryLine (angularNodeBoundary node)))+      (angularNodePreviousIntersection successor)++validateLowerDimensionalState+  :: [ExactAngularBoundary]+  -> ExactClipState+  -> ExactClipState+validateLowerDimensionalState boundaries state =+  case state of+    ExactClipStateSegment from to ->+      if all (containsBoth from to) boundaries+        then state+        else ExactClipStateEmpty+    ExactClipStatePoint point ->+      if all+          (\boundary ->+             classifyExactPoint (angularBoundaryHalfPlane boundary) point /= LT)+          boundaries+        then state+        else ExactClipStateEmpty+    other -> other+ where+  containsBoth from to boundary =+    let halfPlane = angularBoundaryHalfPlane boundary+     in classifyExactPoint halfPlane from /= LT+          && classifyExactPoint halfPlane to /= LT++data ExactClipState+  = ExactClipStatePolygon !ExactRetainedPolygon+  | ExactClipStateSegment !ExactPoint !ExactPoint+  | ExactClipStatePoint !ExactPoint+  | ExactClipStateEmpty+exactSegmentClipState+  :: ExactPoint+  -> ExactPoint+  -> ExactClipState+exactSegmentClipState from to+  | from == to = ExactClipStatePoint from+  | otherwise = ExactClipStateSegment from to++retainedVerticesToClipState+  :: [ExactRetainedVertex]+  -> Either ExactClipError ExactClipState+retainedVerticesToClipState [] = Right ExactClipStateEmpty+retainedVerticesToClipState [vertex] =+  Right (ExactClipStatePoint (retainedVertexPoint vertex))+retainedVerticesToClipState [fromVertex, toVertex] =+  Right+    ( exactSegmentClipState+        (retainedVertexPoint fromVertex)+        (retainedVertexPoint toVertex)+    )+retainedVerticesToClipState (firstVertex : secondVertex : remaining) =+  let retained = firstVertex :| (secondVertex : remaining)+      twiceArea = retainedVerticesTwiceArea retained+   in case exactSignum twiceArea of+        GT -> Right (ExactClipStatePolygon (ExactRetainedPolygon retained))+        LT -> Left (ExactClipOrientationReversed twiceArea)+        EQ -> Right (lowerDimensionalClipState retained)++lowerDimensionalClipState+  :: NonEmpty ExactRetainedVertex+  -> ExactClipState+lowerDimensionalClipState vertices =+  let points = fmap retainedVertexPoint vertices+      initialPoint :| remainingPoints = points+      leastPoint = List.foldl' min initialPoint remainingPoints+      greatestPoint = List.foldl' max initialPoint remainingPoints+   in if leastPoint == greatestPoint+        then ExactClipStatePoint leastPoint+        else ExactClipStateSegment leastPoint greatestPoint++retainedVerticesTwiceArea+  :: NonEmpty ExactRetainedVertex+  -> ExactRational+retainedVerticesTwiceArea =+  List.foldl'+    (\area (from, to) ->+       area+         + exactPointCross+           (retainedVertexPoint from)+           (retainedVertexPoint to))+    0+    . cyclePairsNonEmpty++normalizeRetainedVertices+  :: [ExactRetainedVertex]+  -> [ExactRetainedVertex]+normalizeRetainedVertices = stripClosingDuplicate . deduplicateAdjacent+ where+  deduplicateAdjacent [] = []+  deduplicateAdjacent (firstVertex : remaining) =+    firstVertex : deduplicateAfter firstVertex remaining++  deduplicateAfter _ [] = []+  deduplicateAfter previous (candidate : remaining)+    | retainedVertexPoint previous == retainedVertexPoint candidate =+        deduplicateAfter previous remaining+    | otherwise = candidate : deduplicateAfter candidate remaining++  stripClosingDuplicate vertices@(firstVertex : remainingVertices) =+    case reverse remainingVertices of+      finalVertex : reversedInterior+        | retainedVertexPoint finalVertex == retainedVertexPoint firstVertex ->+            finalVertex : reverse reversedInterior+      _ -> vertices+  stripClosingDuplicate [] = []++exactClipStateDisposition :: ExactClipState -> ExactClipDisposition+exactClipStateDisposition state =+  case state of+    ExactClipStatePolygon polygon -> ExactClipFullDimensional polygon+    ExactClipStateSegment from to ->+      ExactClipLowerDimensional (from :| [to])+    ExactClipStatePoint point -> ExactClipLowerDimensional (point :| [])+    ExactClipStateEmpty -> ExactClipEmpty++exactClipDispositionPoints+  :: ExactClipDisposition+  -> Maybe (NonEmpty ExactPoint)+exactClipDispositionPoints disposition =+  case disposition of+    ExactClipFullDimensional polygon ->+      Just (exactRetainedPolygonPoints polygon)+    ExactClipLowerDimensional points -> Just points+    ExactClipEmpty -> Nothing++retainedVertexPoint :: ExactRetainedVertex -> ExactPoint+retainedVertexPoint (ExactRetainedVertex point _) = point+{-# INLINE retainedVertexPoint #-}++retainedVertexIncomingLine :: ExactRetainedVertex -> ExactAffineLine+retainedVertexIncomingLine (ExactRetainedVertex _ line) = line+{-# INLINE retainedVertexIncomingLine #-}++affineLineBitWidth :: ExactAffineLine -> Int+affineLineBitWidth (ExactAffineLine coefficientX coefficientY constant) =+  max+    (exactRationalBitWidth coefficientX)+    (max (exactRationalBitWidth coefficientY) (exactRationalBitWidth constant))++maximumPointBitWidth :: NonEmpty ExactPoint -> Int+maximumPointBitWidth =+  List.foldl'+    (\maximumBits (ExactPoint x y) ->+       max maximumBits (max (exactRationalBitWidth x) (exactRationalBitWidth y)))+    0++-- | Maximum reduced numerator-or-denominator width of either coordinate.+exactPointBitWidth :: ExactPoint -> Int+exactPointBitWidth (ExactPoint x y) =+  max (exactRationalBitWidth x) (exactRationalBitWidth y)+{-# INLINE exactPointBitWidth #-}++maximumPointDenominatorBitWidth :: NonEmpty ExactPoint -> Int+maximumPointDenominatorBitWidth =+  List.foldl'+    (\maximumBits (ExactPoint x y) ->+       max+         maximumBits+         ( max+             (exactRationalDenominatorBitWidth x)+             (exactRationalDenominatorBitWidth y)+         ))+    0++-- | 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 QueryPoint+exactPointToEmbeddingCandidate (ExactPoint x y) =+  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 exactCrossSign 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 #-}++exactCrossSign :: ExactVector -> ExactVector -> Ordering+exactCrossSign (ExactVector leftX leftY) (ExactVector rightX rightY) =+  -- Reduced rational denominators are positive; compare the two products in a+  -- common integer scale without constructing and normalizing their ratios.+  let (leftXNumerator, leftXDenominator) = exactRationalParts leftX+      (leftYNumerator, leftYDenominator) = exactRationalParts leftY+      (rightXNumerator, rightXDenominator) = exactRationalParts rightX+      (rightYNumerator, rightYDenominator) = exactRationalParts rightY+   in compare+        ( leftXNumerator+            * rightYNumerator+            * leftYDenominator+            * rightXDenominator+        )+        ( leftYNumerator+            * rightXNumerator+            * leftXDenominator+            * rightYDenominator+        )+{-# INLINE exactCrossSign #-}++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
@@ -0,0 +1,38 @@+-- | Shape queries, face descent, and boundary gluing over an immutable mesh.+module Moonlight.Triangulation.FloodFillIterator+  ( DistanceMetric (..)+  , CircleMetric+  , CircleMetricError (..)+  , RectangleMetric+  , RectangleMetricError (..)+  , circleMetric+  , rectangleMetric+  , edgesInShape+  , verticesInShape+  , edgesInCircle+  , verticesInCircle+  , edgesInRectangle+  , verticesInRectangle+  , floodFillFaces+  , outerFaceFloodFill+  , facesAtEvenBarrierDepth+  , FaceComponent+  , faceComponentFaces+  , BoundaryOrientation (..)+  , BoundaryLoop+  , boundaryLoopOrientation+  , boundaryLoopResidentVertices+  , boundaryLoopVertices+  , RegionBoundary+  , regionBoundaryOuterLoop+  , regionBoundaryHoleLoops+  , BoundaryObstruction (..)+  , faceComponents+  , faceComponentsBy+  , labelledRegionBoundaries+  , componentBoundaryLoops+  , componentBoundary+  , componentBoundaryForFaces+  ) where++import Moonlight.Triangulation.Internal.FloodFillIterator
+ src-dcel/Moonlight/Triangulation/Handles/Dynamic.hs view
@@ -0,0 +1,434 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RoleAnnotations #-}++-- | Owning handles that prevent identifiers from crossing mesh boundaries.+module Moonlight.Triangulation.Handles.Dynamic+  ( InnerTag+  , PossiblyOuterTag+  , FixedFaceHandle+  , asPossiblyOuter+  , fixedFaceId+  , VertexHandle+  , DirectedEdgeHandle+  , UndirectedEdgeHandle+  , FaceHandle+  , vertexHandle+  , directedEdgeHandle+  , undirectedEdgeHandle+  , faceHandle+  , innerFaceHandle+  , outerFaceHandle+  , fixVertex+  , fixDirectedEdge+  , fixUndirectedEdge+  , fixFace+  , vertexHandleData+  , vertexHandlePosition+  , vertexHandleOutEdge+  , vertexHandleOutEdges+  , directedEdgeDataH+  , directedEdgeFrom+  , directedEdgeTo+  , directedEdgeVertices+  , directedEdgePositions+  , directedEdgeReverse+  , directedEdgeNext+  , directedEdgePrevious+  , directedEdgeClockwise+  , directedEdgeCounterClockwise+  , directedEdgeFace+  , directedEdgeAsUndirected+  , directedEdgeIsOuter+  , directedEdgeSideQuery+  , directedEdgeOppositeVertex+  , directedEdgeOppositePosition+  , directedEdgeProjectionFactor+  , directedEdgeNearestPoint+  , undirectedEdgeDataH+  , undirectedEdgeAsDirected+  , undirectedEdgeVertices+  , undirectedEdgeIsConstraint+  , undirectedEdgeIsBoundary+  , faceDataH+  , faceIsOuter+  , faceAsInner+  , faceAdjacentEdge+  , faceAdjacentEdges+  , innerFaceVertices+  , innerFaceCircumcenter+  , innerFacePositions+  , innerFaceBarycentric+  ) where++import Moonlight.Triangulation.Dcel qualified as Dcel+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Internal.Predicates qualified as Admitted+import Moonlight.Triangulation.LineSideInfo (LineSideInfo)+import Moonlight.Triangulation.Math qualified as Math+import Moonlight.Triangulation.Types++-- | A face handle that is statically known not to denote the outer face.+data InnerTag++-- | A face handle that may denote the unique outer face.+data PossiblyOuterTag++type role FixedFaceHandle nominal+-- | Fixed face identifier refined by whether it may denote the outer face.+newtype FixedFaceHandle tag = FixedFaceHandle { unFixedFaceHandle :: FaceId }+  deriving stock (Show)+  deriving newtype (Eq, Ord)++-- | Forget the proof that a fixed face is bounded.+asPossiblyOuter :: FixedFaceHandle InnerTag -> FixedFaceHandle PossiblyOuterTag+asPossiblyOuter (FixedFaceHandle face) = FixedFaceHandle face+{-# INLINE asPossiblyOuter #-}++-- | Recover the unrefined face identifier.+fixedFaceId :: FixedFaceHandle tag -> FaceId+fixedFaceId (FixedFaceHandle face) = face+{-# INLINE fixedFaceId #-}++-- | Admitted vertex paired with its owning triangulation.+data VertexHandle mode vertex directed undirected face = VertexHandle+  !(Triangulation mode vertex directed undirected face)+  !VertexId++-- | Admitted directed edge paired with its owning triangulation.+data DirectedEdgeHandle mode vertex directed undirected face = DirectedEdgeHandle+  !(Triangulation mode vertex directed undirected face)+  !DirectedEdgeId++-- | Admitted undirected edge paired with its owning triangulation.+data UndirectedEdgeHandle mode vertex directed undirected face = UndirectedEdgeHandle+  !(Triangulation mode vertex directed undirected face)+  !UndirectedEdgeId++-- | Admitted face paired with its owning triangulation and outer-face proof.+data FaceHandle tag mode vertex directed undirected face = FaceHandle+  !(Triangulation mode vertex directed undirected face)+  !(FixedFaceHandle tag)++instance Show (VertexHandle mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixVertex++instance Show (DirectedEdgeHandle mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixDirectedEdge++instance Show (UndirectedEdgeHandle mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixUndirectedEdge++instance Show (FaceHandle tag mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixFace++-- | Admit a vertex identifier into a triangulation.+vertexHandle+  :: Triangulation mode vertex directed undirected face+  -> VertexId+  -> Maybe (VertexHandle mode vertex directed undirected face)+vertexHandle triangulation vertex+  | vertexIdIndex vertex < Dcel.numVertices triangulation = Just (VertexHandle triangulation vertex)+  | otherwise = Nothing++-- | Admit a directed-edge identifier into a triangulation.+directedEdgeHandle+  :: Triangulation mode vertex directed undirected face+  -> DirectedEdgeId+  -> Maybe (DirectedEdgeHandle mode vertex directed undirected face)+directedEdgeHandle triangulation edge+  | directedEdgeIdIndex edge < Dcel.numDirectedEdges triangulation = Just (DirectedEdgeHandle triangulation edge)+  | otherwise = Nothing++-- | Admit an undirected-edge identifier into a triangulation.+undirectedEdgeHandle+  :: Triangulation mode vertex directed undirected face+  -> UndirectedEdgeId+  -> Maybe (UndirectedEdgeHandle mode vertex directed undirected face)+undirectedEdgeHandle triangulation edge+  | undirectedEdgeIdIndex edge < Dcel.numUndirectedEdges triangulation = Just (UndirectedEdgeHandle triangulation edge)+  | otherwise = Nothing++-- | Admit a face identifier that may denote the outer face.+faceHandle+  :: Triangulation mode vertex directed undirected face+  -> FaceId+  -> Maybe (FaceHandle PossiblyOuterTag mode vertex directed undirected face)+faceHandle triangulation face+  | faceIdIndex face < Dcel.numFaces triangulation = Just (FaceHandle triangulation (FixedFaceHandle face))+  | otherwise = Nothing++-- | Admit a face identifier while proving that it is bounded.+innerFaceHandle+  :: Triangulation mode vertex directed undirected face+  -> FaceId+  -> Maybe (FaceHandle InnerTag mode vertex directed undirected face)+innerFaceHandle triangulation face+  | face == Dcel.outerFace = Nothing+  | otherwise = do+      FaceHandle _ (FixedFaceHandle valid) <- faceHandle triangulation face+      pure (FaceHandle triangulation (FixedFaceHandle valid))++-- | Owning handle to the unique unbounded face.+outerFaceHandle+  :: Triangulation mode vertex directed undirected face+  -> FaceHandle PossiblyOuterTag mode vertex directed undirected face+outerFaceHandle triangulation = FaceHandle triangulation (FixedFaceHandle Dcel.outerFace)++-- | Forget ownership and recover the vertex identifier.+fixVertex :: VertexHandle mode vertex directed undirected face -> VertexId+fixVertex (VertexHandle _ vertex) = vertex+{-# INLINE fixVertex #-}++-- | Forget ownership and recover the directed-edge identifier.+fixDirectedEdge :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeId+fixDirectedEdge (DirectedEdgeHandle _ edge) = edge+{-# INLINE fixDirectedEdge #-}++-- | Forget ownership and recover the undirected-edge identifier.+fixUndirectedEdge :: UndirectedEdgeHandle mode vertex directed undirected face -> UndirectedEdgeId+fixUndirectedEdge (UndirectedEdgeHandle _ edge) = edge+{-# INLINE fixUndirectedEdge #-}++-- | Forget ownership while retaining the outer-face refinement.+fixFace :: FaceHandle tag mode vertex directed undirected face -> FixedFaceHandle tag+fixFace (FaceHandle _ face) = face+{-# INLINE fixFace #-}++-- | Vertex annotation through an owning handle.+vertexHandleData :: VertexHandle mode vertex directed undirected face -> vertex+vertexHandleData (VertexHandle triangulation vertex) = Dcel.vertexData triangulation vertex+{-# INLINE vertexHandleData #-}++-- | Authoritative vertex position through an owning handle.+vertexHandlePosition+  :: VertexHandle mode vertex directed undirected face+  -> Point+vertexHandlePosition (VertexHandle triangulation vertex) = (Dcel.vertexPoint triangulation vertex)+{-# INLINE vertexHandlePosition #-}++-- | One outgoing edge of a connected vertex.+vertexHandleOutEdge+  :: VertexHandle mode vertex directed undirected face+  -> Maybe (DirectedEdgeHandle mode vertex directed undirected face)+vertexHandleOutEdge (VertexHandle triangulation vertex) = DirectedEdgeHandle triangulation <$> Dcel.vertexOutEdge triangulation vertex++-- | Directed edges leaving a vertex in ring order.+vertexHandleOutEdges+  :: VertexHandle mode vertex directed undirected face+  -> [DirectedEdgeHandle mode vertex directed undirected face]+vertexHandleOutEdges (VertexHandle triangulation vertex) = map (DirectedEdgeHandle triangulation) (Dcel.vertexOutgoingEdges triangulation vertex)++-- | Directed-edge annotation through an owning handle.+directedEdgeDataH :: DirectedEdgeHandle mode vertex directed undirected face -> directed+directedEdgeDataH (DirectedEdgeHandle triangulation edge) = Dcel.directedEdgeData triangulation edge+{-# INLINE directedEdgeDataH #-}++-- | Origin vertex of an owning directed edge.+directedEdgeFrom :: DirectedEdgeHandle mode vertex directed undirected face -> VertexHandle mode vertex directed undirected face+directedEdgeFrom (DirectedEdgeHandle triangulation edge) = VertexHandle triangulation (Dcel.origin triangulation edge)+{-# INLINE directedEdgeFrom #-}++-- | Destination vertex of an owning directed edge.+directedEdgeTo :: DirectedEdgeHandle mode vertex directed undirected face -> VertexHandle mode vertex directed undirected face+directedEdgeTo (DirectedEdgeHandle triangulation edge) = VertexHandle triangulation (Dcel.destination triangulation edge)+{-# INLINE directedEdgeTo #-}++-- | Origin and destination of an owning directed edge.+directedEdgeVertices+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> (VertexHandle mode vertex directed undirected face, VertexHandle mode vertex directed undirected face)+directedEdgeVertices edge = (directedEdgeFrom edge, directedEdgeTo edge)++-- | Origin and destination positions of an owning directed edge.+directedEdgePositions+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> (Point, Point)+directedEdgePositions edge = (vertexHandlePosition (directedEdgeFrom edge), vertexHandlePosition (directedEdgeTo edge))+{-# INLINE directedEdgePositions #-}++-- | Reverse an owning directed edge.+directedEdgeReverse :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeHandle mode vertex directed undirected face+directedEdgeReverse (DirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (reverseEdge edge)+{-# INLINE directedEdgeReverse #-}++-- | Next owning edge around the incident face.+directedEdgeNext :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeHandle mode vertex directed undirected face+directedEdgeNext (DirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (Dcel.next triangulation edge)+{-# INLINE directedEdgeNext #-}++-- | Previous owning edge around the incident face.+directedEdgePrevious :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeHandle mode vertex directed undirected face+directedEdgePrevious (DirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (Dcel.previous triangulation edge)+{-# INLINE directedEdgePrevious #-}++-- | Previous owning edge around its origin vertex.+directedEdgeClockwise :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeHandle mode vertex directed undirected face+directedEdgeClockwise (DirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (Dcel.clockwise triangulation edge)+{-# INLINE directedEdgeClockwise #-}++-- | Next owning edge around its origin vertex.+directedEdgeCounterClockwise :: DirectedEdgeHandle mode vertex directed undirected face -> DirectedEdgeHandle mode vertex directed undirected face+directedEdgeCounterClockwise (DirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (Dcel.counterClockwise triangulation edge)+{-# INLINE directedEdgeCounterClockwise #-}++-- | Owning handle to the incident face.+directedEdgeFace+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> FaceHandle PossiblyOuterTag mode vertex directed undirected face+directedEdgeFace (DirectedEdgeHandle triangulation edge) = FaceHandle triangulation (FixedFaceHandle (Dcel.incidentFace triangulation edge))++-- | Forget the orientation of an owning edge.+directedEdgeAsUndirected+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> UndirectedEdgeHandle mode vertex directed undirected face+directedEdgeAsUndirected (DirectedEdgeHandle triangulation edge) = UndirectedEdgeHandle triangulation (asUndirected edge)++-- | Whether the owning edge is incident to the outer face.+directedEdgeIsOuter :: DirectedEdgeHandle mode vertex directed undirected face -> Bool+directedEdgeIsOuter = faceIsOuter . directedEdgeFace++-- | Exact side of the owning edge's oriented line.+directedEdgeSideQuery+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> QueryPoint+  -> LineSideInfo+directedEdgeSideQuery edge query =+  let (from, to) = directedEdgePositions edge+   in Admitted.sideQuery from to (queryPointValue query)++-- | Undirected-edge annotation through an owning handle.+undirectedEdgeDataH :: UndirectedEdgeHandle mode vertex directed undirected face -> undirected+undirectedEdgeDataH (UndirectedEdgeHandle triangulation edge) = Dcel.undirectedEdgeData triangulation edge+{-# INLINE undirectedEdgeDataH #-}++-- | Normalized directed orientation of an owning undirected edge.+undirectedEdgeAsDirected+  :: UndirectedEdgeHandle mode vertex directed undirected face+  -> DirectedEdgeHandle mode vertex directed undirected face+undirectedEdgeAsDirected (UndirectedEdgeHandle triangulation edge) = DirectedEdgeHandle triangulation (normalizedDirected edge)++-- | Endpoints of an owning undirected edge.+undirectedEdgeVertices+  :: UndirectedEdgeHandle mode vertex directed undirected face+  -> (VertexHandle mode vertex directed undirected face, VertexHandle mode vertex directed undirected face)+undirectedEdgeVertices = directedEdgeVertices . undirectedEdgeAsDirected++-- | Face annotation through an owning handle.+faceDataH :: FaceHandle tag mode vertex directed undirected face -> face+faceDataH (FaceHandle triangulation (FixedFaceHandle face)) = Dcel.faceData triangulation face+{-# INLINE faceDataH #-}++-- | Whether the owning face is the unique unbounded face.+faceIsOuter :: FaceHandle tag mode vertex directed undirected face -> Bool+faceIsOuter (FaceHandle _ (FixedFaceHandle face)) = face == Dcel.outerFace+{-# INLINE faceIsOuter #-}++-- | Refine an owning face handle by excluding the outer face.+faceAsInner+  :: FaceHandle PossiblyOuterTag mode vertex directed undirected face+  -> Maybe (FaceHandle InnerTag mode vertex directed undirected face)+faceAsInner handle@(FaceHandle triangulation (FixedFaceHandle face))+  | faceIsOuter handle = Nothing+  | otherwise = Just (FaceHandle triangulation (FixedFaceHandle face))++-- | One owning edge on the face boundary.+faceAdjacentEdge+  :: FaceHandle tag mode vertex directed undirected face+  -> Maybe (DirectedEdgeHandle mode vertex directed undirected face)+faceAdjacentEdge (FaceHandle triangulation (FixedFaceHandle face)) = DirectedEdgeHandle triangulation <$> Dcel.adjacentEdge triangulation face++-- | Owning directed boundary of a face.+faceAdjacentEdges+  :: FaceHandle tag mode vertex directed undirected face+  -> [DirectedEdgeHandle mode vertex directed undirected face]+faceAdjacentEdges (FaceHandle triangulation (FixedFaceHandle face)) = map (DirectedEdgeHandle triangulation) (Dcel.faceDirectedEdges triangulation face)++-- | Three owning vertices of a bounded face.+innerFaceVertices+  :: FaceHandle InnerTag mode vertex directed undirected face+  -> Maybe+       ( VertexHandle mode vertex directed undirected face+       , VertexHandle mode vertex directed undirected face+       , VertexHandle mode vertex directed undirected face+       )+innerFaceVertices (FaceHandle triangulation (FixedFaceHandle face)) =+  (\(a, b, c) -> (VertexHandle triangulation a, VertexHandle triangulation b, VertexHandle triangulation c))+    <$> Dcel.innerFaceVertices triangulation face++-- | Circumcenter of an owning bounded face.+innerFaceCircumcenter+  :: FaceHandle InnerTag mode vertex directed undirected face+  -> Maybe (Point)+innerFaceCircumcenter face = do+  (a, b, c) <- innerFaceVertices face+  Math.circumcenter (vertexHandlePosition a) (vertexHandlePosition b) (vertexHandlePosition c)++-- | Vertex opposite an owning directed edge in its bounded incident face.+directedEdgeOppositeVertex+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> Maybe (VertexHandle mode vertex directed undirected face)+directedEdgeOppositeVertex (DirectedEdgeHandle triangulation edge)+  | Dcel.incidentFace triangulation edge == Dcel.outerFace = Nothing+  | otherwise =+      Just (VertexHandle triangulation (Dcel.destination triangulation (Dcel.next triangulation edge)))++-- | Position opposite an owning directed edge in its bounded incident face.+directedEdgeOppositePosition+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> Maybe (Point)+directedEdgeOppositePosition = fmap vertexHandlePosition . directedEdgeOppositeVertex+{-# INLINE directedEdgeOppositePosition #-}++-- | Projection parameter of a point onto an owning directed edge's line.+directedEdgeProjectionFactor+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> Point+  -> Double+directedEdgeProjectionFactor edge query =+  let (from, to) = directedEdgePositions edge+   in Math.projectionFactor from to query++-- | Nearest point on the closed owning directed edge.+directedEdgeNearestPoint+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> Point+  -> Point+directedEdgeNearestPoint edge query =+  let (from@(Point ax ay), to@(Point bx by)) = directedEdgePositions edge+      factor = max 0 (min 1 (Math.projectionFactor from to query))+   in Point (ax + factor * (bx - ax)) (ay + factor * (by - ay))++-- | Whether an owning undirected edge is constrained.+undirectedEdgeIsConstraint+  :: UndirectedEdgeHandle mode vertex directed undirected face+  -> Bool+undirectedEdgeIsConstraint (UndirectedEdgeHandle triangulation edge) =+  Dcel.isConstraintEdge triangulation edge++-- | Whether an owning undirected edge touches the outer face.+undirectedEdgeIsBoundary+  :: UndirectedEdgeHandle mode vertex directed undirected face+  -> Bool+undirectedEdgeIsBoundary (UndirectedEdgeHandle triangulation edge) =+  Dcel.isBoundaryEdge triangulation edge++-- | Positions of the three vertices of an owning bounded face.+innerFacePositions+  :: FaceHandle InnerTag mode vertex directed undirected face+  -> Maybe (Point, Point, Point)+innerFacePositions face = do+  (a, b, c) <- innerFaceVertices face+  pure (vertexHandlePosition a, vertexHandlePosition b, vertexHandlePosition c)+{-# INLINE innerFacePositions #-}++-- | Barycentric coordinates in an owning bounded face.+innerFaceBarycentric+  :: FaceHandle InnerTag mode vertex directed undirected face+  -> Point+  -> Maybe (Double, Double, Double)+innerFaceBarycentric face query = do+  (a, b, c) <- innerFacePositions face+  Math.barycentricCoordinates a b c query
+ src-dcel/Moonlight/Triangulation/Handles/HandleDefs.hs view
@@ -0,0 +1,22 @@+-- | Opaque compact resident indices and lawful orientation operations. The+-- indices do not encode mesh ownership: use "Moonlight.Triangulation.Handles.Scoped"+-- for local traversal or "Moonlight.Triangulation.Handles.Dynamic" when a handle+-- must escape its mesh scope.+module Moonlight.Triangulation.Handles.HandleDefs+  ( VertexId+  , unVertexId+  , FaceId+  , unFaceId+  , DirectedEdgeId+  , unDirectedEdgeId+  , UndirectedEdgeId+  , unUndirectedEdgeId+  , reverseEdge+  , asUndirected+  , normalizedDirected+  , reversedDirected+  , directedPair+  , isNormalized+  ) where++import Moonlight.Triangulation.Internal.HandleDefs
+ src-dcel/Moonlight/Triangulation/Handles/Iterators/CircularIterator.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE BangPatterns #-}++-- | Bounded traversal of a cyclic successor relation.+module Moonlight.Triangulation.Handles.Iterators.CircularIterator+  ( circularList+  , foldCircular'+  ) where++import GHC.Exts (build)++-- | The cycle reached from a start by repeated advance, in visit order.+--+-- Emitted forwards, for the reason 'Moonlight.Triangulation.Dcel.circularWalk'+-- is: accumulating in reverse and reversing at the end builds the ring twice+-- and hands back a list no consumer can fuse with.+circularList :: Eq a => Int -> (a -> a) -> a -> [a]+circularList limit advance start =+  build+    ( \link stop ->+        let go !remaining !current !visited+              | remaining <= 0 = stop+              | visited && current == start = stop+              | otherwise = link current (go (remaining - 1) (advance current) True)+         in go limit start False+    )+{-# INLINE circularList #-}++-- | Strictly fold a bounded cycle in visit order.+foldCircular' :: Eq a => Int -> (a -> a) -> a -> (b -> a -> b) -> b -> b+foldCircular' limit advance start step = go limit start False+ where+  go !remaining !current !visited !accumulator+    | remaining <= 0 = accumulator+    | visited && current == start = accumulator+    | otherwise = go (remaining - 1) (advance current) True (step accumulator current)
+ src-dcel/Moonlight/Triangulation/Handles/Iterators/DynamicIterators.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Whole-mesh traversal through topology-bound dynamic handles.+module Moonlight.Triangulation.Handles.Iterators.DynamicIterators+  ( vertexHandles+  , directedEdgeHandles+  , undirectedEdgeHandles+  , allFaceHandles+  , innerFaceHandles+  , hullEdgeHandles+  , hullVertexHandles+  , foldVertexHandles'+  , foldDirectedEdgeHandles'+  , foldUndirectedEdgeHandles'+  , foldAllFaceHandles'+  , foldInnerFaceHandles'+  , foldHullEdgeHandles'+  , foldHullVertexHandles'+  ) where++import Moonlight.Triangulation.Handles.Dynamic+import Moonlight.Triangulation.Handles.Iterators.FixedIterators qualified as Fixed+import Moonlight.Triangulation.Handles.Iterators.HullIterator qualified as Hull+import Moonlight.Triangulation.Types++-- | Dynamic handles in fixed-index order. The list spine is lazy; use the+-- strict folds below for allocation-free traversal in hot paths.+vertexHandles+  :: Triangulation mode vertex directed undirected face+  -> [VertexHandle mode vertex directed undirected face]+vertexHandles triangulation =+  mapValid (vertexHandle triangulation) (Fixed.vertices triangulation)++-- | Every directed-edge handle in fixed-index order.+directedEdgeHandles+  :: Triangulation mode vertex directed undirected face+  -> [DirectedEdgeHandle mode vertex directed undirected face]+directedEdgeHandles triangulation =+  mapValid (directedEdgeHandle triangulation) (Fixed.directedEdges triangulation)++-- | Every undirected-edge handle in fixed-index order.+undirectedEdgeHandles+  :: Triangulation mode vertex directed undirected face+  -> [UndirectedEdgeHandle mode vertex directed undirected face]+undirectedEdgeHandles triangulation =+  mapValid (undirectedEdgeHandle triangulation) (Fixed.undirectedEdges triangulation)++-- | Every face handle, including the outer face.+allFaceHandles+  :: Triangulation mode vertex directed undirected face+  -> [FaceHandle PossiblyOuterTag mode vertex directed undirected face]+allFaceHandles triangulation =+  mapValid (faceHandle triangulation) (Fixed.allFaces triangulation)++-- | Every inner-face handle.+innerFaceHandles+  :: Triangulation mode vertex directed undirected face+  -> [FaceHandle InnerTag mode vertex directed undirected face]+innerFaceHandles triangulation =+  mapValid (innerFaceHandle triangulation) (Fixed.innerFaces triangulation)++-- | Hull directed-edge handles in boundary order.+hullEdgeHandles+  :: Triangulation mode vertex directed undirected face+  -> [DirectedEdgeHandle mode vertex directed undirected face]+hullEdgeHandles triangulation =+  mapValid (directedEdgeHandle triangulation) (Hull.hullEdges triangulation)++-- | Hull vertex handles in boundary order.+hullVertexHandles+  :: Triangulation mode vertex directed undirected face+  -> [VertexHandle mode vertex directed undirected face]+hullVertexHandles triangulation =+  map directedEdgeFrom (hullEdgeHandles triangulation)++-- | Strict fold over every vertex handle.+foldVertexHandles'+  :: Triangulation mode vertex directed undirected face+  -> (accumulator -> VertexHandle mode vertex directed undirected face -> accumulator)+  -> accumulator+  -> accumulator+foldVertexHandles' triangulation step =+  Fixed.foldVertices' triangulation (applyValid (vertexHandle triangulation) step)++-- | Strict fold over every directed-edge handle.+foldDirectedEdgeHandles'+  :: Triangulation mode vertex directed undirected face+  -> (accumulator -> DirectedEdgeHandle mode vertex directed undirected face -> accumulator)+  -> accumulator+  -> accumulator+foldDirectedEdgeHandles' triangulation step =+  Fixed.foldDirectedEdges' triangulation (applyValid (directedEdgeHandle triangulation) step)++-- | Strict fold over every undirected-edge handle.+foldUndirectedEdgeHandles'+  :: Triangulation mode vertex directed undirected face+  -> (accumulator -> UndirectedEdgeHandle mode vertex directed undirected face -> accumulator)+  -> accumulator+  -> accumulator+foldUndirectedEdgeHandles' triangulation step =+  Fixed.foldUndirectedEdges' triangulation (applyValid (undirectedEdgeHandle triangulation) step)++-- | Strict fold over every face handle, including the outer face.+foldAllFaceHandles'+  :: Triangulation mode vertex directed undirected face+  -> (accumulator -> FaceHandle PossiblyOuterTag mode vertex directed undirected face -> accumulator)+  -> accumulator+  -> accumulator+foldAllFaceHandles' triangulation step =+  Fixed.foldAllFaces' triangulation (applyValid (faceHandle triangulation) step)++-- | Strict fold over every inner-face handle.+foldInnerFaceHandles'+  :: Triangulation mode vertex directed undirected face+  -> (accumulator -> FaceHandle InnerTag mode vertex directed undirected face -> accumulator)+  -> accumulator+  -> accumulator+foldInnerFaceHandles' triangulation step =+  Fixed.foldInnerFaces' triangulation (applyValid (innerFaceHandle triangulation) step)++-- | Strict fold over hull directed-edge handles.+foldHullEdgeHandles'+  :: Triangulation mode vertex directed undirected face+  -> (accumulator -> DirectedEdgeHandle mode vertex directed undirected face -> accumulator)+  -> accumulator+  -> accumulator+foldHullEdgeHandles' triangulation step =+  Hull.foldHullEdges' triangulation (applyValid (directedEdgeHandle triangulation) step)++-- | Strict fold over hull vertex handles.+foldHullVertexHandles'+  :: Triangulation mode vertex directed undirected face+  -> (accumulator -> VertexHandle mode vertex directed undirected face -> accumulator)+  -> accumulator+  -> accumulator+foldHullVertexHandles' triangulation step =+  foldHullEdgeHandles' triangulation (\accumulator edge -> step accumulator (directedEdgeFrom edge))++mapValid :: (fixed -> Maybe dynamic) -> [fixed] -> [dynamic]+mapValid make = foldr collect []+ where+  collect fixed rest = case make fixed of+    Just dynamic -> dynamic : rest+    Nothing -> rest++applyValid+  :: (fixed -> Maybe dynamic)+  -> (accumulator -> dynamic -> accumulator)+  -> accumulator+  -> fixed+  -> accumulator+applyValid make step !accumulator fixed = case make fixed of+  Just dynamic -> step accumulator dynamic+  Nothing -> accumulator
+ src-dcel/Moonlight/Triangulation/Handles/Iterators/FixedIterators.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE BangPatterns #-}++-- | Whole-mesh traversal by identifier range, each range paired with the+-- strict fold that consumes it.+module Moonlight.Triangulation.Handles.Iterators.FixedIterators+  ( vertices+  , directedEdges+  , undirectedEdges+  , allFaces+  , innerFaces+  , foldVertices'+  , foldDirectedEdges'+  , foldUndirectedEdges'+  , foldAllFaces'+  , foldInnerFaces'+  ) where++import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Types++-- | Every vertex identifier, ascending.+--+-- The enumerators are producers, so their bodies have to reach the consumer's+-- module: a fold over one of these should be a loop over an index, not a walk+-- over cons cells built by a call it could not see into.+vertices :: Triangulation mode vertex directed undirected face -> [VertexId]+vertices triangulation = [VertexId (fromIntegral index) | index <- [0 .. numVertices triangulation - 1]]+{-# INLINE vertices #-}++-- | Every directed-edge identifier, ascending.+directedEdges :: Triangulation mode vertex directed undirected face -> [DirectedEdgeId]+directedEdges triangulation = [DirectedEdgeId (fromIntegral index) | index <- [0 .. numDirectedEdges triangulation - 1]]+{-# INLINE directedEdges #-}++-- | Every undirected-edge identifier, ascending.+undirectedEdges :: Triangulation mode vertex directed undirected face -> [UndirectedEdgeId]+undirectedEdges triangulation = [UndirectedEdgeId (fromIntegral index) | index <- [0 .. numUndirectedEdges triangulation - 1]]+{-# INLINE undirectedEdges #-}++-- | Every face identifier, the outer face first.+allFaces :: Triangulation mode vertex directed undirected face -> [FaceId]+allFaces triangulation = [FaceId (fromIntegral index) | index <- [0 .. numFaces triangulation - 1]]+{-# INLINE allFaces #-}++-- | Every face identifier except the outer face.+innerFaces :: Triangulation mode vertex directed undirected face -> [FaceId]+innerFaces triangulation = [FaceId (fromIntegral index) | index <- [1 .. numFaces triangulation - 1]]+{-# INLINE innerFaces #-}++-- | Strict fold over 'vertices'; the rest of the family follows.+foldVertices' :: Triangulation mode vertex directed undirected face -> (a -> VertexId -> a) -> a -> a+foldVertices' triangulation step = foldRange (numVertices triangulation) (VertexId . fromIntegral) step+{-# INLINE foldVertices' #-}++-- | Strict fold over every directed-edge identifier.+foldDirectedEdges' :: Triangulation mode vertex directed undirected face -> (a -> DirectedEdgeId -> a) -> a -> a+foldDirectedEdges' triangulation step = foldRange (numDirectedEdges triangulation) (DirectedEdgeId . fromIntegral) step+{-# INLINE foldDirectedEdges' #-}++-- | Strict fold over every undirected-edge identifier.+foldUndirectedEdges' :: Triangulation mode vertex directed undirected face -> (a -> UndirectedEdgeId -> a) -> a -> a+foldUndirectedEdges' triangulation step = foldRange (numUndirectedEdges triangulation) (UndirectedEdgeId . fromIntegral) step+{-# INLINE foldUndirectedEdges' #-}++-- | Strict fold over every face, including the outer face.+foldAllFaces' :: Triangulation mode vertex directed undirected face -> (a -> FaceId -> a) -> a -> a+foldAllFaces' triangulation step = foldRange (numFaces triangulation) (FaceId . fromIntegral) step+{-# INLINE foldAllFaces' #-}++-- | Strict fold over every inner face.+foldInnerFaces' :: Triangulation mode vertex directed undirected face -> (a -> FaceId -> a) -> a -> a+foldInnerFaces' triangulation step initial = go 1 initial+ where+  !end = numFaces triangulation+  go !index !accumulator+    | index >= end = accumulator+    | otherwise = go (index + 1) (step accumulator (FaceId (fromIntegral index)))+{-# INLINE foldInnerFaces' #-}++foldRange :: Int -> (Int -> b) -> (a -> b -> a) -> a -> a+foldRange end make step = go 0+ where+  go !index !accumulator+    | index >= end = accumulator+    | otherwise = go (index + 1) (step accumulator (make index))+{-# INLINE foldRange #-}
+ src-dcel/Moonlight/Triangulation/Handles/Iterators/HullIterator.hs view
@@ -0,0 +1,29 @@+-- | The convex hull, walked as its edges or as its vertices.+module Moonlight.Triangulation.Handles.Iterators.HullIterator+  ( hullEdges+  , hullVertices+  , foldHullEdges'+  , foldHullVertices'+  ) where++import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Types++-- | The convex hull as directed edges, in order.+hullEdges :: Triangulation mode vertex directed undirected face -> [DirectedEdgeId]+hullEdges triangulation = faceDirectedEdges triangulation outerFace+{-# INLINE hullEdges #-}++-- | The convex hull as vertices, in order.+hullVertices :: Triangulation mode vertex directed undirected face -> [VertexId]+hullVertices triangulation = map (origin triangulation) (hullEdges triangulation)+{-# INLINE hullVertices #-}++-- | Strict fold over 'hullEdges'.+foldHullEdges' :: Triangulation mode vertex directed undirected face -> (a -> DirectedEdgeId -> a) -> a -> a+foldHullEdges' triangulation = foldFaceDirectedEdges' triangulation outerFace++-- | Strict fold over 'hullVertices'.+foldHullVertices' :: Triangulation mode vertex directed undirected face -> (a -> VertexId -> a) -> a -> a+foldHullVertices' triangulation step = foldHullEdges' triangulation (\acc edge -> step acc (origin triangulation edge))
+ src-dcel/Moonlight/Triangulation/Handles/Scoped.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}++-- | Zero-cost mesh-scoped identifiers. A scope is introduced only by+-- 'withScopedTriangulation', so an identifier from one mesh cannot be supplied+-- to observations of another mesh. Use owning handles when a handle must+-- escape the continuation.+module Moonlight.Triangulation.Handles.Scoped+  ( ScopedTriangulation+  , ScopedVertex+  , ScopedDirectedEdge+  , ScopedUndirectedEdge+  , ScopedFace+  , withScopedTriangulation+  , scopedVertices+  , scopedDirectedEdges+  , scopedUndirectedEdges+  , scopedFaces+  , scopedInnerFaces+  , scopedOuterFace+  , scopedVertexPoint+  , scopedVertexData+  , scopedDirectedEdgeData+  , scopedUndirectedEdgeData+  , scopedFaceData+  , scopedVertexOutEdge+  , scopedAdjacentEdge+  , scopedOrigin+  , scopedDestination+  , scopedReverseEdge+  , scopedAsUndirected+  , scopedNext+  , scopedPrevious+  , scopedIncidentFace+  , scopedIsOuterDirectedEdge+  , scopedIsBoundaryEdge+  , scopedIsConstraintEdge+  , scopedUndirectedEndpoints+  , scopedFaceDirectedEdges+  , scopedFaceVertices+  , scopedVertexOutgoingEdges+  ) where++import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.Handles.HandleDefs+  ( DirectedEdgeId+  , FaceId+  , UndirectedEdgeId+  , VertexId+  , asUndirected+  , reverseEdge+  )+import qualified Moonlight.Triangulation.Handles.Iterators.FixedIterators as Fixed+import Moonlight.Triangulation.Types+  ( Point+  , Triangulation+  )++type role ScopedTriangulation nominal nominal representational representational representational representational+newtype ScopedTriangulation scope mode vertex directed undirected face =+  ScopedTriangulation (Triangulation mode vertex directed undirected face)++type role ScopedVertex nominal+newtype ScopedVertex scope = ScopedVertex VertexId+  deriving stock (Eq, Ord, Show)++type role ScopedDirectedEdge nominal+newtype ScopedDirectedEdge scope = ScopedDirectedEdge DirectedEdgeId+  deriving stock (Eq, Ord, Show)++type role ScopedUndirectedEdge nominal+newtype ScopedUndirectedEdge scope = ScopedUndirectedEdge UndirectedEdgeId+  deriving stock (Eq, Ord, Show)++type role ScopedFace nominal+newtype ScopedFace scope = ScopedFace FaceId+  deriving stock (Eq, Ord, Show)++-- | Introduce one nominal scope for all identifiers derived from this mesh.+withScopedTriangulation+  :: Triangulation mode vertex directed undirected face+  -> (forall scope. ScopedTriangulation scope mode vertex directed undirected face -> result)+  -> result+withScopedTriangulation triangulation use = use (ScopedTriangulation triangulation)+{-# INLINE withScopedTriangulation #-}++scopedVertices+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> [ScopedVertex scope]+scopedVertices (ScopedTriangulation triangulation) =+  fmap ScopedVertex (Fixed.vertices triangulation)++scopedDirectedEdges+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> [ScopedDirectedEdge scope]+scopedDirectedEdges (ScopedTriangulation triangulation) =+  fmap ScopedDirectedEdge (Fixed.directedEdges triangulation)++scopedUndirectedEdges+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> [ScopedUndirectedEdge scope]+scopedUndirectedEdges (ScopedTriangulation triangulation) =+  fmap ScopedUndirectedEdge (Fixed.undirectedEdges triangulation)++scopedFaces+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> [ScopedFace scope]+scopedFaces (ScopedTriangulation triangulation) =+  fmap ScopedFace (Fixed.allFaces triangulation)++scopedInnerFaces+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> [ScopedFace scope]+scopedInnerFaces (ScopedTriangulation triangulation) =+  fmap ScopedFace (Fixed.innerFaces triangulation)++scopedOuterFace+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedFace scope+scopedOuterFace _ = ScopedFace Dcel.outerFace+{-# INLINE scopedOuterFace #-}++scopedVertexPoint+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedVertex scope+  -> Point+scopedVertexPoint (ScopedTriangulation triangulation) (ScopedVertex vertex) =+  Dcel.vertexPoint triangulation vertex+{-# INLINE scopedVertexPoint #-}++scopedVertexData+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedVertex scope+  -> vertex+scopedVertexData (ScopedTriangulation triangulation) (ScopedVertex vertex) =+  Dcel.vertexData triangulation vertex+{-# INLINE scopedVertexData #-}++scopedDirectedEdgeData+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedDirectedEdge scope+  -> directed+scopedDirectedEdgeData (ScopedTriangulation triangulation) (ScopedDirectedEdge edge) =+  Dcel.directedEdgeData triangulation edge+{-# INLINE scopedDirectedEdgeData #-}++scopedUndirectedEdgeData+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedUndirectedEdge scope+  -> undirected+scopedUndirectedEdgeData (ScopedTriangulation triangulation) (ScopedUndirectedEdge edge) =+  Dcel.undirectedEdgeData triangulation edge+{-# INLINE scopedUndirectedEdgeData #-}++scopedFaceData+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedFace scope+  -> face+scopedFaceData (ScopedTriangulation triangulation) (ScopedFace face) =+  Dcel.faceData triangulation face+{-# INLINE scopedFaceData #-}++scopedVertexOutEdge+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedVertex scope+  -> Maybe (ScopedDirectedEdge scope)+scopedVertexOutEdge (ScopedTriangulation triangulation) (ScopedVertex vertex) =+  ScopedDirectedEdge <$> Dcel.vertexOutEdge triangulation vertex++scopedAdjacentEdge+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedFace scope+  -> Maybe (ScopedDirectedEdge scope)+scopedAdjacentEdge (ScopedTriangulation triangulation) (ScopedFace face) =+  ScopedDirectedEdge <$> Dcel.adjacentEdge triangulation face++scopedOrigin+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedDirectedEdge scope+  -> ScopedVertex scope+scopedOrigin (ScopedTriangulation triangulation) (ScopedDirectedEdge edge) =+  ScopedVertex (Dcel.origin triangulation edge)+{-# INLINE scopedOrigin #-}++scopedDestination+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedDirectedEdge scope+  -> ScopedVertex scope+scopedDestination (ScopedTriangulation triangulation) (ScopedDirectedEdge edge) =+  ScopedVertex (Dcel.destination triangulation edge)+{-# INLINE scopedDestination #-}++scopedReverseEdge :: ScopedDirectedEdge scope -> ScopedDirectedEdge scope+scopedReverseEdge (ScopedDirectedEdge edge) = ScopedDirectedEdge (reverseEdge edge)+{-# INLINE scopedReverseEdge #-}++scopedAsUndirected :: ScopedDirectedEdge scope -> ScopedUndirectedEdge scope+scopedAsUndirected (ScopedDirectedEdge edge) = ScopedUndirectedEdge (asUndirected edge)+{-# INLINE scopedAsUndirected #-}++scopedNext+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedDirectedEdge scope+  -> ScopedDirectedEdge scope+scopedNext (ScopedTriangulation triangulation) (ScopedDirectedEdge edge) =+  ScopedDirectedEdge (Dcel.next triangulation edge)+{-# INLINE scopedNext #-}++scopedPrevious+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedDirectedEdge scope+  -> ScopedDirectedEdge scope+scopedPrevious (ScopedTriangulation triangulation) (ScopedDirectedEdge edge) =+  ScopedDirectedEdge (Dcel.previous triangulation edge)+{-# INLINE scopedPrevious #-}++scopedIncidentFace+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedDirectedEdge scope+  -> ScopedFace scope+scopedIncidentFace (ScopedTriangulation triangulation) (ScopedDirectedEdge edge) =+  ScopedFace (Dcel.incidentFace triangulation edge)+{-# INLINE scopedIncidentFace #-}++scopedIsOuterDirectedEdge+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedDirectedEdge scope+  -> Bool+scopedIsOuterDirectedEdge (ScopedTriangulation triangulation) (ScopedDirectedEdge edge) =+  Dcel.isOuterDirectedEdge triangulation edge+{-# INLINE scopedIsOuterDirectedEdge #-}++scopedIsBoundaryEdge+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedUndirectedEdge scope+  -> Bool+scopedIsBoundaryEdge (ScopedTriangulation triangulation) (ScopedUndirectedEdge edge) =+  Dcel.isBoundaryEdge triangulation edge+{-# INLINE scopedIsBoundaryEdge #-}++scopedIsConstraintEdge+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedUndirectedEdge scope+  -> Bool+scopedIsConstraintEdge (ScopedTriangulation triangulation) (ScopedUndirectedEdge edge) =+  Dcel.isConstraintEdge triangulation edge+{-# INLINE scopedIsConstraintEdge #-}++scopedUndirectedEndpoints+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedUndirectedEdge scope+  -> (ScopedVertex scope, ScopedVertex scope)+scopedUndirectedEndpoints (ScopedTriangulation triangulation) (ScopedUndirectedEdge edge) =+  let (firstVertex, secondVertex) = Dcel.undirectedEndpoints triangulation edge+   in (ScopedVertex firstVertex, ScopedVertex secondVertex)++scopedFaceDirectedEdges+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedFace scope+  -> [ScopedDirectedEdge scope]+scopedFaceDirectedEdges (ScopedTriangulation triangulation) (ScopedFace face) =+  fmap ScopedDirectedEdge (Dcel.faceDirectedEdges triangulation face)++scopedFaceVertices+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedFace scope+  -> [ScopedVertex scope]+scopedFaceVertices (ScopedTriangulation triangulation) (ScopedFace face) =+  fmap ScopedVertex (Dcel.faceVertices triangulation face)++scopedVertexOutgoingEdges+  :: ScopedTriangulation scope mode vertex directed undirected face+  -> ScopedVertex scope+  -> [ScopedDirectedEdge scope]+scopedVertexOutgoingEdges (ScopedTriangulation triangulation) (ScopedVertex vertex) =+  fmap ScopedDirectedEdge (Dcel.vertexOutgoingEdges triangulation vertex)
+ src-dcel/Moonlight/Triangulation/Internal/BoundaryCycle.hs view
@@ -0,0 +1,303 @@+-- | Shared pure algebra for descending oriented boundary graphs into simple+-- cycles, then simplifying and classifying those cycles.+module Moonlight.Triangulation.Internal.BoundaryCycle+  ( traceOrientedBoundaryCircuits+  , simplifyBoundaryCycle+  , rotateCycleLeast+  , rotateCycleLeastBy+  , consecutivePairs+  , unorderedPairs+  , orderedPair+  , cyclePairs+  , cyclePairsNonEmpty+  , cyclicTriples+  , firstNonCounterClockwiseTurn+  , admitsSimpleCycleEdgeRelation+  ) where++import Data.List (tails)+import qualified Data.List as List+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 Moonlight.Triangulation.Internal.SegmentRelation+  ( SegmentRelation (..)+  )++-- | Consume every supplied oriented edge exactly once and split point contacts+-- into vertex-simple cycles. The outgoing lists carry the caller's required+-- local angular or identifier order. A malformed graph is translated directly+-- through the caller's obstruction constructor; this shared worker owns no+-- disposable error vocabulary.+traceOrientedBoundaryCircuits+  :: (Ord vertex, Ord edge)+  => (edge -> vertex)+  -> (edge -> vertex)+  -> (edge -> edge -> obstruction)+  -> Map vertex [edge]+  -> Set edge+  -> Either obstruction [NonEmpty vertex]+traceOrientedBoundaryCircuits edgeOrigin edgeDestination obstruction outgoing edges =+  descend edges []+ where+  descend remaining cycles =+    case Set.lookupMin remaining of+      Nothing -> Right (reverse cycles)+      Just seed ->+        let (untraced, circuitEdges) =+              eulerCircuit remaining (edgeOrigin seed)+         in case NonEmpty.nonEmpty circuitEdges of+              Nothing -> Left (obstruction seed seed)+              Just circuit ->+                case splitCircuit circuit of+                  Left failedEdge -> Left (obstruction seed failedEdge)+                  Right splitCycles ->+                    descend+                      untraced+                      (reverse (NonEmpty.toList splitCycles) <> cycles)++  -- Hierholzer descent: delete each chosen edge, then prepend it while+  -- backtracking. No graph-state stream or branch search is materialized.+  eulerCircuit remaining start = walk remaining start [] []+   where+    walk untraced current incomingEdges circuit =+      case+          List.find+            (`Set.member` untraced)+            (Map.findWithDefault [] current outgoing) of+        Just edge ->+          walk+            (Set.delete edge untraced)+            (edgeDestination edge)+            (edge : incomingEdges)+            circuit+        Nothing ->+          case incomingEdges of+            edge : previousEdges ->+              walk+                untraced+                (edgeOrigin edge)+                previousEdges+                (edge : circuit)+            [] -> (untraced, circuit)++  -- The resident path stays simple. Closing at a resident vertex emits and+  -- removes exactly that suffix, partitioning the Euler circuit into cycles.+  splitCircuit circuit =+    walk+      start+      0+      (Map.singleton start 0)+      []+      []+      (NonEmpty.toList circuit)+   where+    start = edgeOrigin (NonEmpty.head circuit)++    walk current depth depths reversedEdges cycles remaining =+      case remaining of+        [] ->+          case+              ( depth+              , reversedEdges+              , NonEmpty.nonEmpty (reverse cycles)+              ) of+            (0, [], Just simpleCycles) -> Right simpleCycles+            _ -> Left (NonEmpty.last circuit)+        edge : rest+          | edgeOrigin edge /= current -> Left edge+          | otherwise ->+              let target = edgeDestination edge+               in case Map.lookup target depths of+                    Nothing ->+                      walk+                        target+                        (depth + 1)+                        (Map.insert target (depth + 1) depths)+                        (edge : reversedEdges)+                        cycles+                        rest+                    Just repeatedDepth ->+                      let suffixLength = depth - repeatedDepth+                          suffixEdges = take suffixLength reversedEdges+                          simpleCycle =+                            fmap edgeOrigin+                              ( NonEmpty.reverse+                                  (edge :| suffixEdges)+                              )+                       in walk+                            target+                            repeatedDepth+                            ( foldr+                                (Map.delete . edgeDestination)+                                depths+                                suffixEdges+                            )+                            (drop suffixLength reversedEdges)+                            (simpleCycle : cycles)+                            rest+{-# INLINABLE traceOrientedBoundaryCircuits #-}++-- | 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) =+              List.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 =+    List.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 = List.foldl' (\_ current -> current) initial (second : remaining)+       in zip3+            (final : values)+            values+            (second : remaining <> [initial])+    _ -> []+{-# INLINE cyclicTriples #-}++-- | Locate the first turn that is not strictly counter-clockwise. Convex+-- boundary admissions share this one indexed obstruction descent.+firstNonCounterClockwiseTurn+  :: (value -> value -> value -> Ordering)+  -> NonEmpty value+  -> Maybe (Int, Ordering)+firstNonCounterClockwiseTurn orientation =+  List.find ((/= GT) . snd)+    . zip [0 ..]+    . fmap (\(previousValue, current, nextValue) -> orientation previousValue current nextValue)+    . cyclicTriples+    . NonEmpty.toList+{-# INLINE firstNonCounterClockwiseTurn #-}++-- | Whether one exact relation between two indexed cycle edges is compatible+-- with a simple closed boundary. Only adjacent edges may meet, and then only+-- at their shared endpoint. Producers remain free to obtain relation sections+-- through the sweep plan or direct pairwise descent; this is the single+-- admissibility policy glued over both representations.+admitsSimpleCycleEdgeRelation+  :: Int+  -> Int+  -> Int+  -> SegmentRelation+  -> Bool+admitsSimpleCycleEdgeRelation segmentCount leftIndex rightIndex relation =+  relation == SegmentsDisjoint+    || ( cycleEdgesAreAdjacent+           segmentCount leftIndex rightIndex+           && relation == SegmentsShareEndpoint+       )+{-# INLINE admitsSimpleCycleEdgeRelation #-}++cycleEdgesAreAdjacent :: Int -> Int -> Int -> Bool+cycleEdgesAreAdjacent segmentCount leftIndex rightIndex =+  upperIndex == lowerIndex + 1+    || (lowerIndex == 0 && upperIndex == segmentCount - 1)+ where+  lowerIndex = min leftIndex rightIndex+  upperIndex = max leftIndex rightIndex+{-# INLINE cycleEdgesAreAdjacent #-}
+ src-dcel/Moonlight/Triangulation/Internal/Canonical.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Canonical publication: the same triangulation, renumbered so that its+-- representation is a function of its geometry alone.+module Moonlight.Triangulation.Internal.Canonical+  ( canonicalize+  , canonicalizeKnownAscending+  ) where++import Control.Monad (when)+import Control.Monad.ST (runST)+import qualified Data.Vector.Algorithms.Intro as Intro+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MUV+import Moonlight.Triangulation.Dcel (numFaces, numUndirectedEdges, numVertices, vertexData)+import Moonlight.Triangulation.Internal.HandleDefs (VertexId (..))+import Moonlight.Triangulation.Internal.Mutable+import Moonlight.Triangulation.Internal.Paged (Paged, pagedUnsafeIndex)+import Moonlight.Triangulation.Internal.Representation (Triangulation (..))+import Moonlight.Triangulation.Internal.Types (BuildError)++-- | Whether the caller has already established the authoritative vertex-order+-- section. The canonicalizer still owns every edge, directed-edge, face,+-- anchor, and constraint normalization; this witness affects only its vertex+-- rank entrance.+data VertexOrderAdmission+  = VertexOrderUnknown+  | VertexOrderKnownAscending++-- | Renumber a triangulation into its canonical representation.+--+-- Two triangulations of the same sites are the same triangulation — Delaunay+-- uniqueness says so, and the tie-break on an exactly cocircular quadrilateral+-- is keyed on coordinates rather than on identifiers so that it stays true.+-- What differs between two builds of one site set is only /numbering/: which+-- vertex got index 0, which half-edge got the even slot, where a face's cycle+-- was anchored. All of that records the schedule the value was constructed by,+-- and none of it is geometry.+--+-- This is what removes it. Every identifier is assigned from the geometry:+--+--     * vertices in lexicographic coordinate rank;+--     * undirected edges in lexicographic rank of their endpoint pair, each+--       taken low first, so the pair is an unordered pair by construction;+--     * of a pair's two half-edges, the even slot is the one leaving the+--       lower-ranked endpoint, which keeps twinning an @xor@ with one;+--     * inner faces in order of the least half-edge on their boundary, which+--       is a single index rather than a vertex tuple and so needs no special+--       case for a cycle that is not a triangle;+--     * every anchor — each vertex's outgoing edge, each face's edge — set to+--       the least admissible half-edge.+--+-- Construction therefore need not run in canonical order. Local insertion and+-- seam fusion may preserve their cheaper schedule-specific numbering; callers+-- invoke this operation only when they require the construction-independent+-- physical representative used to observe the finite-set laws.+--+-- Element payloads are @()@ because a renumbering is a bijection and could+-- carry them, but nothing that wants that exists; the writers a general form+-- would need were retired when their last caller went. Vertex payloads travel+-- with their vertices, and constraint flags with their edges, so a constrained+-- triangulation canonicalizes as readily as an unconstrained one.+canonicalize+  :: Triangulation mode vertex () () ()+  -> Either BuildError (Triangulation mode vertex () () ())+canonicalize = canonicalizeWithVertexOrder VertexOrderUnknown++-- | Canonicalize a triangulation whose vertices were appended in strict+-- lexicographic coordinate order by the admitted SiteSet bulk entrance.+-- This is an execution witness, not a second numbering implementation.+canonicalizeKnownAscending+  :: Triangulation mode vertex () () ()+  -> Either BuildError (Triangulation mode vertex () () ())+canonicalizeKnownAscending = canonicalizeWithVertexOrder VertexOrderKnownAscending++canonicalizeWithVertexOrder+  :: VertexOrderAdmission+  -> Triangulation mode vertex () () ()+  -> Either BuildError (Triangulation mode vertex () () ())+canonicalizeWithVertexOrder vertexOrderAdmission source = runST $ do+  mutable <-+    newMutableDcel+      (triElementDefaults source)+      (exactDcelCapacity vertexTotal directedTotal faceTotal)+  forRange 0 vertexTotal $ \canonical -> do+    let !old = vertexOrder `U.unsafeIndex` canonical+    _ <-+      appendVertexCoordinates+        mutable+        (coordinateX `pagedUnsafeIndex` old)+        (coordinateY `pagedUnsafeIndex` old)+        (vertexData source (VertexId (fromIntegral old)))+    pure ()+  _ <- addEdgeBlock mutable edgeTotal+  _ <- addFaceBlock mutable (faceTotal - 1)+  forRange 0 directedTotal $ \canonical -> do+    let !old = directedFromCanonical `U.unsafeIndex` canonical+    writeOrigin mutable canonical (vertexRank `U.unsafeIndex` originOf old)+    writeNext mutable canonical (directedToCanonical `U.unsafeIndex` topology (4 * old + 1))+    writePrevious mutable canonical (directedToCanonical `U.unsafeIndex` topology (4 * old + 2))+    writeFace mutable canonical (faceRank `U.unsafeIndex` topology (4 * old + 3))+  forRange 0 vertexTotal $ \canonical -> do+    let !least = leastOutgoing `U.unsafeIndex` canonical+    if least == absent+      then writeVertexOut mutable canonical (-1)+      else markConnected mutable canonical least+  forRange 0 faceTotal $ \canonical -> do+    let !least = leastOnFace `U.unsafeIndex` oldFaceOf canonical+    writeFaceEdge mutable canonical (if least == absent then -1 else least)+  forRange 0 edgeTotal $ \canonicalUndirected ->+    when (constraintFlag `pagedUnsafeIndex` (edgeOrder `U.unsafeIndex` canonicalUndirected) /= 0) $+      () <$ setConstraint mutable (2 * canonicalUndirected)+  freezeTriangulation mutable+ where+  !vertexTotal = numVertices source+  !edgeTotal = numUndirectedEdges source+  !faceTotal = numFaces source+  !directedTotal = 2 * edgeTotal++  -- Read the arenas rather than the handle accessors. Every one of these is+  -- indexed a few times per element, and the accessors would box a t'Point' or+  -- an identifier newtype at each of them.+  !coordinateX = triPointX source+  !coordinateY = triPointY source+  !topologyArena = triHalfTopology source+  !constraintFlag = triConstraint source+  topology slot = fromIntegral (topologyArena `pagedUnsafeIndex` slot) :: Int+  originOf directed = topology (4 * directed)++  -- Vertices, in lexicographic coordinate rank. Sorting a vector of keys with+  -- the type's own ordering rather than an index vector under a closure: the+  -- comparison then specializes instead of being an unknown call per step.+  --+  -- Sortedness is checked first, because a great many of the meshes handed to+  -- this function already have it and the check costs one linear scan against a+  -- sort's @n log n@. A seam merge is the reason: it copies two canonically+  -- numbered operands into one arena, lower abscissa first, and the sites of+  -- the result are then already in rank order by construction. Nothing about+  -- the schedule is assumed here — the coordinates are simply read and+  -- believed, so a mesh that arrives sorted for any other reason is served just+  -- as well.+  !alreadyRanked =+    case vertexOrderAdmission of+      VertexOrderUnknown -> coordinatesAscend vertexTotal coordinateX coordinateY+      VertexOrderKnownAscending -> True+  !vertexOrder+    | alreadyRanked = U.enumFromN 0 vertexTotal+    | otherwise =+        thirdColumn $+          sortedVector+            ( U.generate+                vertexTotal+                ( \index ->+                    ( coordinateX `pagedUnsafeIndex` index+                    , coordinateY `pagedUnsafeIndex` index+                    , index+                    )+                )+            )+  !vertexRank+    | alreadyRanked = vertexOrder+    | otherwise = invertPermutation vertexTotal vertexOrder++  -- Undirected edges, in lexicographic rank of their endpoint pair.+  --+  -- Both components of the key are vertex ranks, so they are already dense+  -- indices into a range this function knows: comparing them is a counting+  -- sort's job, not a comparison sort's. Two stable passes — the high endpoint+  -- first, then the low one — leave the pairs in lexicographic order, in time+  -- linear in the edges and the vertices rather than @E log E@.+  !edgeLow =+    U.generate edgeTotal $ \index ->+      min+        (vertexRank `U.unsafeIndex` originOf (2 * index))+        (vertexRank `U.unsafeIndex` originOf (2 * index + 1))+  !edgeHigh =+    U.generate edgeTotal $ \index ->+      max+        (vertexRank `U.unsafeIndex` originOf (2 * index))+        (vertexRank `U.unsafeIndex` originOf (2 * index + 1))+  !edgeOrder =+    countingSortOn vertexTotal edgeLow $+      countingSortOn vertexTotal edgeHigh (U.enumFromN 0 edgeTotal)++  -- The even half of each canonical pair leaves the lower-ranked endpoint.+  !directedFromCanonical =+    U.generate directedTotal $ \canonical ->+      let !oldEdge = edgeOrder `U.unsafeIndex` (canonical `quot` 2)+          !evenHalf = 2 * oldEdge+          !leavesLower =+            vertexRank `U.unsafeIndex` originOf evenHalf+              <= vertexRank `U.unsafeIndex` originOf (evenHalf + 1)+       in if even canonical == leavesLower then evenHalf else evenHalf + 1+  !directedToCanonical = invertPermutation directedTotal directedFromCanonical++  -- The least canonical half-edge on each old face and leaving each canonical+  -- vertex, in one pass. Anchors have to be a function of the geometry too, or+  -- two builds of one site set would publish the same cycles anchored in+  -- different places.+  (!leastOnFace, !leastOutgoing) = runST $ do+    faces <- MUV.replicate (max 1 faceTotal) absent+    vertices <- MUV.replicate (max 1 vertexTotal) absent+    forRange 0 directedTotal $ \canonical -> do+      let !old = directedFromCanonical `U.unsafeIndex` canonical+          !face = topology (4 * old + 3)+          !rank = vertexRank `U.unsafeIndex` originOf old+      onFace <- MUV.unsafeRead faces face+      when (canonical < onFace) (MUV.unsafeWrite faces face canonical)+      leaving <- MUV.unsafeRead vertices rank+      when (canonical < leaving) (MUV.unsafeWrite vertices rank canonical)+    (,) <$> U.unsafeFreeze faces <*> U.unsafeFreeze vertices++  -- Inner faces, in order of the least canonical half-edge on their boundary.+  -- The outer face keeps index zero, which the arena reserves for it anyway.+  --+  -- No two faces share a least half-edge, so this key is injective and the+  -- ordering can be read off by inverting it: mark each face at its own least+  -- half-edge, then scan the half-edges in order. That is one linear pass and+  -- no comparisons at all. A face the scan never reaches has no boundary — only+  -- reachable in a mesh with no edges — and follows in old index order so that+  -- the result stays a permutation whatever it is handed.+  !innerFaceOrder = U.create $ do+    owner <- MUV.replicate (max 1 directedTotal) absent+    forRange 1 faceTotal $ \face -> do+      let !least = leastOnFace `U.unsafeIndex` face+      when (least /= absent) (MUV.unsafeWrite owner least face)+    emitted <- MUV.replicate (max 1 faceTotal) False+    out <- MUV.new (max 0 (faceTotal - 1))+    let scan !slot !filled+          | slot >= directedTotal = pure filled+          | otherwise = do+              !face <- MUV.unsafeRead owner slot+              if face == absent+                then scan (slot + 1) filled+                else do+                  MUV.unsafeWrite out filled face+                  MUV.unsafeWrite emitted face True+                  scan (slot + 1) (filled + 1)+        sweep !face !filled+          | face >= faceTotal = pure ()+          | otherwise = do+              !done <- MUV.unsafeRead emitted face+              if done+                then sweep (face + 1) filled+                else do+                  MUV.unsafeWrite out filled face+                  sweep (face + 1) (filled + 1)+    scan 0 0 >>= sweep 1+    pure out+  !faceRank = U.create $ do+    ranks <- MUV.replicate (max 1 faceTotal) 0+    U.iforM_ innerFaceOrder $ \rank old -> MUV.unsafeWrite ranks old (rank + 1)+    pure ranks+  oldFaceOf canonical+    | canonical == 0 = 0+    | otherwise = innerFaceOrder `U.unsafeIndex` (canonical - 1)+++-- | No half-edge reaches this face or vertex. A one-site mesh has such a+-- vertex and an edgeless outer face; the arena spells the same absence as a+-- packed sentinel, which is not a value an index may take.+absent :: Int+absent = maxBound++-- | @[from, to)@, without materializing the range as a list.+forRange :: Monad m => Int -> Int -> (Int -> m ()) -> m ()+forRange from to action = go from+ where+  go !index+    | index >= to = pure ()+    | otherwise = action index >> go (index + 1)+{-# INLINE forRange #-}++sortedVector :: (U.Unbox key, Ord key) => U.Vector key -> U.Vector key+sortedVector = U.modify Intro.sort+{-# INLINE sortedVector #-}++-- | Stably reorder @items@ by a key that is already a dense index below+-- @range@, in time linear in both.+--+-- Applied least-significant key first, repeated application leaves the items in+-- lexicographic order of the whole key — which is what makes a two-component+-- ordering over vertex ranks cost @O(V + E)@ instead of @O(E log E)@.+countingSortOn :: Int -> U.Vector Int -> U.Vector Int -> U.Vector Int+countingSortOn range keys items = U.create $ do+  counts <- MUV.replicate (range + 1) 0+  U.forM_ items $ \item ->+    MUV.unsafeModify counts (+ 1) (keys `U.unsafeIndex` item)+  let prefix !key !running+        | key > range = pure ()+        | otherwise = do+            !count <- MUV.unsafeRead counts key+            MUV.unsafeWrite counts key running+            prefix (key + 1) (running + count)+  prefix 0 0+  out <- MUV.new (max 1 (U.length items))+  U.forM_ items $ \item -> do+    let !key = keys `U.unsafeIndex` item+    !slot <- MUV.unsafeRead counts key+    MUV.unsafeWrite counts key (slot + 1)+    MUV.unsafeWrite out slot item+  pure (MUV.slice 0 (U.length items) out)++thirdColumn :: (U.Unbox a, U.Unbox b) => U.Vector (a, b, Int) -> U.Vector Int+thirdColumn = U.map (\(_, _, index) -> index)+{-# INLINE thirdColumn #-}++-- | Whether the stored sites are already in strict lexicographic order, in+-- which case ranking them is the identity and both permutations are free.+--+-- Strict rather than non-strict: a triangulation stores each site once, so+-- equal adjacent coordinates would mean a mesh this function has no ordering+-- for, and it is the sort's business to say so rather than this predicate's.+coordinatesAscend :: Int -> Paged Double -> Paged Double -> Bool+coordinatesAscend total x y = go 1+ where+  go !index+    | index >= total = True+    | otherwise =+        let !previousX = x `pagedUnsafeIndex` (index - 1)+            !currentX = x `pagedUnsafeIndex` index+         in case compare previousX currentX of+              LT -> go (index + 1)+              GT -> False+              EQ ->+                y `pagedUnsafeIndex` (index - 1) < y `pagedUnsafeIndex` index+                  && go (index + 1)++-- | @inverse ! (order ! i) == i@: the rank each element was given.+invertPermutation :: Int -> U.Vector Int -> U.Vector Int+invertPermutation count order = U.create $ do+  inverse <- MUV.replicate (max 1 count) 0+  U.iforM_ order $ \rank element -> MUV.unsafeWrite inverse element rank+  pure inverse
+ src-dcel/Moonlight/Triangulation/Internal/CellSet.hs view
@@ -0,0 +1,330 @@+{-# 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+  , residentExactCellSet+  , 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.Internal.HandleDefs+  ( FaceId (..)+  , UndirectedEdgeId (..)+  , VertexId (..)+  , asUndirected+  , faceIdIndex+  , undirectedEdgeIdIndex+  , vertexIdIndex+  )+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)++-- | Seal the complete resident DCEL without rechecking ranges or closure+-- already established by its dense handle families. Exact coordinates are+-- still admitted at this representation boundary; only impossible handle+-- refusals and repeated incidence walks disappear.+residentExactCellSet+  :: Triangulation mode vertex directed undirected face+  -> Either CellSelectionError ExactCellSet+residentExactCellSet triangulation = do+  let vertexIndices = [0 .. numVertices triangulation - 1]+      edgeIndices = [0 .. numUndirectedEdges triangulation - 1]+      faceIndices = [1 .. numFaces triangulation - 1]+  exactPoints <-+    IntMap.fromDistinctAscList+      <$> traverse+        ( \residentIndex -> do+            point <- ordinaryExactPoint triangulation (VertexId (fromIntegral residentIndex))+            pure (residentIndex, point)+        )+        vertexIndices+  pure+    ( ExactCellSet+        triangulation+        exactPoints+        (IntSet.fromDistinctAscList edgeIndices)+        (IntSet.fromDistinctAscList faceIndices)+    )++-- | 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+    | vertexIdIndex vertex < numVertices triangulation = Right ()+    | otherwise = Left (CellVertexOutOfRange vertex (numVertices triangulation))+  validateEdge edge+    | undirectedEdgeIdIndex edge < numUndirectedEdges triangulation = Right ()+    | otherwise = Left (CellEdgeOutOfRange edge (numUndirectedEdges triangulation))+  validateFace face+    | faceIdIndex face == 0 = Left CellOuterFaceSelected+    | faceIdIndex face < 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+    | IntSet.member (vertexIdIndex vertex) 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+    | IntSet.member (undirectedEdgeIdIndex edge) selectedEdges = Right ()+    | otherwise = Left (CellFaceEdgeMissing face edge)++vertexSet :: [VertexId] -> IntSet.IntSet+vertexSet = IntSet.fromList . map vertexIdIndex++edgeSet :: [UndirectedEdgeId] -> IntSet.IntSet+edgeSet = IntSet.fromList . map undirectedEdgeIdIndex++faceSet :: [FaceId] -> IntSet.IntSet+faceSet = IntSet.fromList . map faceIdIndex++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/CandidateArena.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | The legalization candidate stack: discipline, growth, and seeding.+module Moonlight.Triangulation.Internal.DcelOperations.CandidateArena+  ( CandidateDiscipline (..)+  , growLegalizationArena+  , seedStarScratch+  , seedGenericPairInArena+  , seedGenericEdges+  ) where++import Control.Monad (forM_, when)+import Control.Monad.ST (ST)+import qualified Data.Vector.Unboxed.Mutable as MUV+import Moonlight.Triangulation.Internal.OperationState+  ( LegalizationArena (..)+  , OperationState+  , legalizationArena+  , legalizationArenaLength+  , readScratch+  , storeLegalizationArena+  )+import Moonlight.Triangulation.Internal.PackedIndex (packIndex)++-- | 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+-- overflow grows the operation-owned vector without changing LIFO order.+seedStarScratch :: OperationState s -> Int -> Int -> ST s Int+seedStarScratch operation top candidateCount = do+  initialArena <- legalizationArena operation+  arena <- growLegalizationArena initialArena (top + candidateCount)+  when (legalizationArenaLength arena /= legalizationArenaLength initialArena) (storeLegalizationArena operation arena)+  let LegalizationArena values = arena+  forM_ [0 .. candidateCount - 1] $ \index -> do+    edge <- readScratch operation index+    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 (legalizationArenaLength arena /= legalizationArenaLength initialArena) (storeLegalizationArena operation arena)+  let LegalizationArena values = arena+  forM_ (zip [0 ..] edges) $ \(!index, !edge) ->+    MUV.unsafeWrite values (top + index) (packIndex edge)+  pure (top + count)++growLegalizationArena :: LegalizationArena s -> Int -> ST s (LegalizationArena s)+growLegalizationArena arena@(LegalizationArena values) required+  | required <= current = pure arena+  | otherwise = LegalizationArena <$> MUV.grow values (max (required - current) (max 1 current))+ where+  !current = MUV.length values+{-# INLINE growLegalizationArena #-}
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Chain.hs view
@@ -0,0 +1,422 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | The degenerate dimensions: a point, a segment chain, and its promotion.+module Moonlight.Triangulation.Internal.DcelOperations.Chain+  ( setupFirstVertex+  , setupSecondVertex+  , splitLineEdge+  , extendLine+  , prepareAscendingLineArena+  , connectAscendingLineArena+  , collectLineChain+  , lineToArea+  ) where++import Control.Monad (forM_, when)+import Control.Monad.ST (ST)+import Data.STRef (writeSTRef)+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32)+import Moonlight.Triangulation.Internal.HandleDefs (VertexId (..))+import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeScratch)+import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex)+import Moonlight.Triangulation.Internal.PackedIndex (unpackIndex)+import Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel (..)+  , DenseMutableDcel+  , addEdge+  , addEdgeBlock+  , addFaceBlock+  , denseAddEdgeBlock+  , denseCommitFreshConnections+  , denseMarkFreshConnected+  , denseMutableOwner+  , denseReadPointX+  , denseReadPointY+  , denseWriteFace+  , denseWriteFaceEdge+  , denseLinkEdges+  , denseWriteOrigin+  , directedEdgeCount+  , edgeOriginPoint+  , ensureCellCapacity+  , isConnected+  , linkEdges+  , markConnected+  , pointAt+  , pointCount+  , readConstraint+  , readNext+  , readOrigin+  , readPrevious+  , readVertexOut+  , resetEdgeData+  , setConstraint+  , setCycle3+  , writeFace+  , writeFaceEdge+  , writeOrigin+  , writeVertexOut+  )+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , readScratch+  , writeScratch+  )+import Moonlight.Triangulation.Internal.Probe (KnownProbe)+import Moonlight.Triangulation.Internal.Types (BuildError (..))+import Moonlight.Triangulation.Internal.Predicates (orient2d, orient2dCoordinates)++setupFirstVertex :: MutableDcel s vertex directed undirected face -> Int -> ST s ()+setupFirstVertex mutable vertex = markConnected mutable vertex (-1)++setupSecondVertex :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError ())+setupSecondVertex mutable vertex = do+  vertices <- pointCount mutable+  connected <- findConnected mutable vertices 0+  case connected of+    Left obstruction -> pure (Left obstruction)+    Right first -> do+      capacity <- ensureCellCapacity mutable 1 0+      case capacity of+        Left obstruction -> pure (Left obstruction)+        Right () -> do+          (edge, reverseEdgeEdge) <- addEdge mutable first vertex+          linkEdges mutable edge reverseEdgeEdge+          linkEdges mutable reverseEdgeEdge edge+          writeFace mutable edge 0+          writeFace mutable reverseEdgeEdge 0+          writeFaceEdge mutable 0 edge+          writeVertexOut mutable first edge+          markConnected mutable vertex reverseEdgeEdge+          pure (Right ())++splitLineEdge :: MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())+splitLineEdge mutable operation edge vertex = do+  capacity <- ensureCellCapacity mutable 1 0+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> do+      protected <- readConstraint mutable edge+      let !reverseEdgeEdge = reverseIndex edge+      destinationVertex <- readOrigin mutable reverseEdgeEdge+      oldNextEdge <- readNext mutable edge+      oldPreviousTwin <- readPrevious mutable reverseEdgeEdge+      oldNextTwin <- readNext mutable reverseEdgeEdge+      writeOrigin mutable reverseEdgeEdge vertex+      (newEdge, newTwin) <- addEdge mutable vertex destinationVertex+      writeFace mutable newEdge 0+      writeFace mutable newTwin 0+      if oldNextEdge == reverseEdgeEdge+        then do+          -- The split segment reaches a line endpoint. Its forward edge and twin+          -- are adjacent, so the replacement is one contiguous four-edge run.+          -- This also covers the initial two-vertex topology.+          linkEdges mutable edge newEdge+          linkEdges mutable newEdge newTwin+          linkEdges mutable newTwin reverseEdgeEdge+          linkEdges mutable reverseEdgeEdge oldNextTwin+        else do+          -- Replace the two occurrences independently: [edge] becomes+          -- [edge,newEdge], while [twin] becomes [newTwin,twin].+          linkEdges mutable edge newEdge+          linkEdges mutable newEdge oldNextEdge+          linkEdges mutable oldPreviousTwin newTwin+          linkEdges mutable newTwin reverseEdgeEdge+      writeVertexOut mutable destinationVertex newTwin+      markConnected mutable vertex newEdge+      -- AB became AV. The new half is a fresh slot and already carries the+      -- default; the truncated half is a different edge in an old slot.+      resetEdgeData mutable (edge `quot` 2)+      when protected $ do+        _ <- setConstraint mutable newEdge+        pure ()+      addCounter operation CounterLineSplits 1+      pure (Right ())++extendLine :: MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())+extendLine mutable operation endpoint vertex = do+  outgoing <- readVertexOut mutable endpoint+  if outgoing < 0+    then pure (Left (DegenerateLineEndpointMissingOutgoing (VertexId (fromIntegral endpoint))))+    else do+      capacity <- ensureCellCapacity mutable 1 0+      case capacity of+        Left obstruction -> pure (Left obstruction)+        Right () -> do+          let !incoming = reverseIndex outgoing+          (newEdge, newTwin) <- addEdge mutable endpoint vertex+          writeFace mutable newEdge 0+          writeFace mutable newTwin 0+          linkEdges mutable incoming newEdge+          linkEdges mutable newEdge newTwin+          linkEdges mutable newTwin outgoing+          writeVertexOut mutable endpoint newEdge+          markConnected mutable vertex newTwin+          addCounter operation CounterLineExtensions 1+          pure (Right ())++-- | A consumed radial arena whose sites have been proved collinear and placed+-- in ascending coordinate order. The constructor stays here with the chain+-- topology it licenses; the sweep can only obtain the witness through+-- 'prepareAscendingLineArena'.+newtype AscendingLineArena s = AscendingLineArena (MUV.MVector s Word32)++-- | Recognize a one-dimensional fresh section and derive its chain order from+-- the radial order already paid for by bulk admission. The nearest radial site+-- is a lawful pivot: distances increase monotonically on each side of it, so+-- reversing the lower fibre and retaining the upper fibre yields total line+-- order without another sort.+--+-- The third point is inspected before the remaining fold. General-position+-- input therefore pays one exact orientation, not a speculative linear scan.+prepareAscendingLineArena+  :: forall s vertex directed undirected face+   . DenseMutableDcel s vertex directed undirected face+  -> MUV.MVector s Word32+  -> ST s (Maybe (AscendingLineArena s))+prepareAscendingLineArena dense radial+  | MUV.length radial < 3 = pure Nothing+  | otherwise = do+      first <- MUV.unsafeRead radial 0+      second <- MUV.unsafeRead radial 1+      third <- MUV.unsafeRead radial 2+      firstX <- coordinateX first+      firstY <- coordinateY first+      secondX <- coordinateX second+      secondY <- coordinateY second+      thirdX <- coordinateX third+      thirdY <- coordinateY third+      let !useX = firstX /= secondX+          pointCoordinate :: Double -> Double -> Double+          pointCoordinate x y = if useX then x else y+          coordinateAt :: Word32 -> ST s Double+          coordinateAt = if useX then coordinateX else coordinateY+          !pivotCoordinate = pointCoordinate firstX firstY+          !initialLowerCount =+            fromEnum (pointCoordinate secondX secondY < pivotCoordinate)+              + fromEnum (pointCoordinate thirdX thirdY < pivotCoordinate)+      if orient2dCoordinates firstX firstY secondX secondY thirdX thirdY /= EQ+        then pure Nothing+        else do+          (!collinear, !lowerCount) <-+            MUV.foldM'+              (\(!admitted, !count) raw ->+                 if admitted+                   then do+                     x <- coordinateX raw+                     y <- coordinateY raw+                     pure+                       ( orient2dCoordinates firstX firstY secondX secondY x y == EQ+                       , count + fromEnum (pointCoordinate x y < pivotCoordinate)+                       )+                   else pure (False, count)+              )+              (True, initialLowerCount)+              (MUV.unsafeSlice 3 (MUV.length radial - 3) radial)+          if collinear+            then Just <$> orderAlongLine coordinateAt pivotCoordinate lowerCount+            else pure Nothing+ where+  coordinateX :: Word32 -> ST s Double+  coordinateX = denseReadPointX dense . fromIntegral+  coordinateY :: Word32 -> ST s Double+  coordinateY = denseReadPointY dense . fromIntegral++  orderAlongLine+    :: (Word32 -> ST s Double)+    -> Double+    -> Int+    -> ST s (AscendingLineArena s)+  orderAlongLine coordinateAt pivotCoordinate lowerCount = do+    ascending <- MUV.new (MUV.length radial)+    _ <-+      MUV.foldM'+        (\(!lowerSeen, !upperSeen) raw -> do+           coordinate <- coordinateAt raw+           if coordinate < pivotCoordinate+             then do+               MUV.unsafeWrite ascending (lowerCount - lowerSeen - 1) raw+               pure (lowerSeen + 1, upperSeen)+             else do+               MUV.unsafeWrite ascending (lowerCount + upperSeen) raw+               pure (lowerSeen, upperSeen + 1)+        )+        (0, 0)+        radial+    pure (AscendingLineArena ascending)++-- | Glue a proved ascending line as one outer-face cycle. Every site and cell+-- is fresh, so the dense section initializes each topology slot exactly once+-- and commits connectivity once after the local pieces agree on their shared+-- endpoints.+connectAscendingLineArena+  :: DenseMutableDcel s vertex directed undirected face+  -> OperationState s+  -> AscendingLineArena s+  -> ST s (Either BuildError Int)+connectAscendingLineArena dense operation (AscendingLineArena vertices) = do+  let !vertexCount = MUV.length vertices+      !segmentCount = vertexCount - 1+      mutable = denseMutableOwner dense+  capacity <- ensureCellCapacity mutable segmentCount 0+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> do+      edgeBase <- denseAddEdgeBlock dense segmentCount+      MUV.imapM_+        (\index fromRaw -> do+           toRaw <- MUV.unsafeRead vertices (index + 1)+           let !forward = edgeBase + 2 * index+               !backward = forward + 1+               !nextForward = if index == segmentCount - 1 then backward else forward + 2+               !nextBackward = if index == 0 then edgeBase else backward - 2+           denseWriteOrigin dense forward (unpackIndex fromRaw)+           denseWriteOrigin dense backward (unpackIndex toRaw)+           denseLinkEdges dense forward nextForward+           denseLinkEdges dense backward nextBackward+           denseWriteFace dense forward 0+           denseWriteFace dense backward 0+        )+        (MUV.unsafeSlice 0 segmentCount vertices)+      MUV.imapM_+        (\index raw ->+           denseMarkFreshConnected+             dense+             (unpackIndex raw)+             ( if index < segmentCount+                 then edgeBase + 2 * index+                 else edgeBase + 2 * segmentCount - 1+             )+        )+        vertices+      denseCommitFreshConnections dense vertexCount+      denseWriteFaceEdge dense 0 edgeBase+      addCounter operation CounterLineExtensions (max 0 (vertexCount - 2))+      pure (Right vertexCount)++collectLineChain :: MutableDcel s vertex directed undirected face -> OperationState s -> ST s (Either BuildError Int)+collectLineChain mutable operation = do+  halfEdges <- directedEdgeCount mutable+  turn <- findTurn halfEdges 0+  case turn of+    Left obstruction -> pure (Left obstruction)+    Right incoming -> do+      let !first = reverseIndex incoming+          go !count !edge = do+            writeScratch operation count edge+            edgeNext <- readNext mutable edge+            if edgeNext == reverseIndex edge+              then pure (Right (count + 1))+              else go (count + 1) edgeNext+      go 0 first+ where+  findTurn halfEdges !edge+    | edge >= halfEdges = pure (Left (DegenerateLineEndpointTurnMissing halfEdges))+    | otherwise = do+        edgeNext <- readNext mutable edge+        if edgeNext == reverseIndex edge then pure (Right edge) else findTurn halfEdges (edge + 1)++lineToArea :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> ST s (Either BuildError ())+lineToArea mutable operation vertex = do+  collected <- collectLineChain mutable operation+  case collected of+    Left obstruction -> pure (Left obstruction)+    Right segmentCount -> lineToAreaCollected @p mutable operation vertex segmentCount++lineToAreaCollected :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())+lineToAreaCollected mutable@MutableDcel{mdLastFace} operation vertex segmentCount = do+  capacity <- ensureCellCapacity mutable (segmentCount + 1) segmentCount+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> lineToAreaWithCapacity+ where+  lineToAreaWithCapacity = do+   firstSegment <- readScratch operation 0+   lastSegment <- readScratch operation (segmentCount - 1)+   firstPoint <- edgeOriginPoint mutable firstSegment+   lastPoint <- edgeOriginPoint mutable (reverseIndex lastSegment)+   insertedPoint <- pointAt mutable vertex+   when (orient2d firstPoint lastPoint insertedPoint == LT) $ reverseScratchDirections operation segmentCount+   spokeBase <- addEdgeBlock mutable (segmentCount + 1)+   faceBase <- addFaceBlock mutable segmentCount+   forM_ [0 .. segmentCount] $ \index -> do+    chainVertex <-+      if index < segmentCount+        then readScratch operation index >>= readOrigin mutable+        else readScratch operation (segmentCount - 1) >>= readOrigin mutable . reverseIndex+    let !forward = spokeBase + 2 * index+        !backward = forward + 1+    writeOrigin mutable forward chainVertex+    writeOrigin mutable backward vertex+   forM_ [0 .. segmentCount - 1] $ \index -> do+    segment <- readScratch operation index+    let !face = faceBase + index+        !nextSpoke = spokeBase + 2 * (index + 1)+        !previousSpoke = spokeBase + 2 * index + 1+    setCycle3 mutable face segment nextSpoke previousSpoke+   lastInnerSegment <- readScratch operation (segmentCount - 1)+   let !outerStart = reverseIndex lastInnerSegment+       !firstOuterSpoke = spokeBase+       !lastOuterSpoke = spokeBase + 2 * segmentCount + 1+   linkOuterTwins mutable operation segmentCount+   firstInnerSegment <- readScratch operation 0+   linkEdges mutable (reverseIndex firstInnerSegment) firstOuterSpoke+   linkEdges mutable firstOuterSpoke lastOuterSpoke+   linkEdges mutable lastOuterSpoke outerStart+   writeFace mutable firstOuterSpoke 0+   writeFace mutable lastOuterSpoke 0+   writeFaceEdge mutable 0 outerStart+   forM_ [0 .. segmentCount - 1] $ \index -> do+    segment <- readScratch operation index+    chainVertex <- readOrigin mutable segment+    writeVertexOut mutable chainVertex segment+   finalVertex <- readOrigin mutable (reverseIndex lastInnerSegment)+   writeVertexOut mutable finalVertex (spokeBase + 2 * segmentCount)+   markConnected mutable vertex (spokeBase + 1)+   writeSTRef mdLastFace faceBase+   addCounter operation CounterLineToAreaTransitions 1+   legalizeScratch @p mutable operation vertex segmentCount+   pure (Right ())++  linkOuterTwins :: MutableDcel s vertex directed undirected face -> OperationState s -> Int -> ST s ()+  linkOuterTwins target ops count =+    let go !index+          | index <= 0 = pure ()+          | otherwise = do+              right <- readScratch ops index+              left <- readScratch ops (index - 1)+              linkEdges target (reverseIndex right) (reverseIndex left)+              writeFace target (reverseIndex right) 0+              go (index - 1)+     in do+          go (count - 1)+          first <- readScratch ops 0+          writeFace target (reverseIndex first) 0++reverseScratchDirections :: OperationState s -> Int -> ST s ()+reverseScratchDirections operation count = do+  forM_ [0 .. count `quot` 2 - 1] $ \left -> do+    let !right = count - 1 - left+    leftEdge <- readScratch operation left+    rightEdge <- readScratch operation right+    writeScratch operation left (reverseIndex rightEdge)+    writeScratch operation right (reverseIndex leftEdge)+  when (odd count) $ do+    let !middle = count `quot` 2+    edge <- readScratch operation middle+    writeScratch operation middle (reverseIndex edge)++findConnected :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s (Either BuildError Int)+findConnected mutable limit !vertex+  | vertex >= limit = pure (Left (DegenerateLineConnectedVertexMissing limit))+  | otherwise = do+      connected <- isConnected mutable vertex+      if connected then pure (Right vertex) else findConnected mutable limit (vertex + 1)
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRewrite.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | The flip rewrite itself, on a quadrilateral.+module Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite+  ( flipEdge+  , applyFlip+  ) where++import Control.Monad (unless)+import Control.Monad.ST (ST)+import Moonlight.Triangulation.Internal.HandleDefs (UndirectedEdgeId (..))+import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex)+import Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel+  , MutableTopology (..)+  , payloadsPristine+  , readConstraint+  , readFace+  , readNext+  , readOrigin+  , readPrevious+  , resetEdgeData+  , resetFaceData+  )+import Moonlight.Triangulation.Internal.Types (BuildError (ConstrainedEdgeFlipRefused))++flipEdge :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError ())+flipEdge mutable edge = do+  protected <- readConstraint mutable edge+  if protected+    then pure (Left (ConstrainedEdgeFlipRefused (UndirectedEdgeId (fromIntegral (edge `quot` 2)))))+    else do+      let !twin = reverseIndex edge+      edgeNext <- readNext mutable edge+      edgePrevious <- readPrevious mutable edge+      twinNext <- readNext mutable twin+      twinPrevious <- readPrevious mutable twin+      leftFace <- readFace mutable edge+      rightFace <- readFace mutable twin+      a <- readOrigin mutable edge+      b <- readOrigin mutable twin+      c <- readOrigin mutable edgePrevious+      d <- readOrigin mutable twinPrevious+      applyFlip mutable edge twin edgeNext edgePrevious twinNext twinPrevious leftFace rightFace a b c d+      pure (Right ())++-- | The rewrite itself, from a quadrilateral the caller already holds. The+-- decision that licenses a flip reads the same two half-edge records the+-- rewrite consumes, so the drain hands its neighbourhood straight here rather+-- than making 'flipEdge' fetch it a second time; 'flipEdge' is that fetch, for+-- callers arriving with nothing but an index.+applyFlip+  :: MutableTopology mutable+  => mutable s vertex directed undirected face+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> Int+  -> ST s ()+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.+  unless (payloadsPristine mutable) $ do+    resetEdgeData mutable (edge `quot` 2)+    resetFaceData mutable leftFace+    resetFaceData mutable rightFace+  topologyWriteVertexOut topology a twinNext+  topologyWriteVertexOut topology b edgeNext+{-# INLINE applyFlip #-}
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRule.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | The firing condition of the flip rule, and the laws restricting it.+module Moonlight.Triangulation.Internal.DcelOperations.FlipRule+  ( LegalizationLaw (..)+  , diagonalFires+  , illegalDiagonal+  , isFlippableEdge+  ) where++import Control.Monad.ST (ST)+import Moonlight.Triangulation.Internal.BoundaryCycle (orderedPair)+import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex)+import Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel+  , readConstraint+  , readFace+  , readOrigin+  , readPointX+  , readPointY+  , readPrevious+  )+import Moonlight.Triangulation.Internal.Predicates+  ( inCircleCoordinates+  , orient2dCoordinates+  )++-- | Whether the flip rule may fire on a quadrilateral @a b c d@ under a law,+-- where @ab@ is the diagonal and @c@, @d@ the apexes opposite it. The+-- coordinates arrive raw, in the order the mutable accessors carry.+--+-- 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+  -> Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double+  -> Bool+diagonalFires law ax ay bx by cx cy dx dy =+  case law of+    -- 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+    SeamPreserving _ -> illegalDiagonal ax ay bx by cx cy dx dy+{-# INLINE diagonalFires #-}++-- | Whether a diagonal is locally illegal — the firing condition of the flip+-- rule @drainLegalization@ normalizes under, and the step at which its+-- potential strictly decreases.+--+-- Lift the quadrilateral to @z = x² + y²@ and the in-circle sign is the+-- orientation of the lifted tetrahedron: 'GT' says the fourth point is below+-- the plane of the other three, so the current diagonal spans a fold the flip+-- pushes downward. 'EQ' says the four lifted points are coplanar and the flip+-- changes nothing about the surface — so the ordering on diagonal keys stands+-- in as the potential, and the rule fires only downward in it. That tie-break+-- is not a convention for picking among equals; it is what stops a cocircular+-- quadrilateral from flipping forever.+illegalDiagonal+  :: Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double -> Bool+illegalDiagonal ax ay bx by cx cy dx dy =+  case inCircleCoordinates ax ay bx by cx cy dx dy of+    GT -> True+    LT -> False+    EQ -> orderedPair (cx, cy) (dx, dy) < orderedPair (ax, ay) (bx, by)+{-# INLINE illegalDiagonal #-}++isFlippableEdge :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool+isFlippableEdge mutable edge = do+  protected <- readConstraint mutable edge+  if protected+    then pure False+    else do+      let !reverseEdgeEdge = reverseIndex edge+      leftFace <- readFace mutable edge+      rightFace <- readFace mutable reverseEdgeEdge+      if leftFace == 0 || rightFace == 0+        then pure False+        else do+          edgePrevious <- readPrevious mutable edge+          reverseEdgePrevious <- readPrevious mutable reverseEdgeEdge+          a <- readOrigin mutable edge+          b <- readOrigin mutable reverseEdgeEdge+          c <- readOrigin mutable edgePrevious+          d <- readOrigin mutable reverseEdgePrevious+          ax <- readPointX mutable a+          ay <- readPointY mutable a+          bx <- readPointX mutable b+          by <- readPointY mutable b+          cx <- readPointX mutable c+          cy <- readPointY mutable c+          dx <- readPointX mutable d+          dy <- readPointY mutable d+          pure+            ( orient2dCoordinates cx cy dx dy bx by == GT+                && orient2dCoordinates dx dy cx cy ax ay == GT+            )+{-# INLINE isFlippableEdge #-}++-- | The rewrite strategy: which candidates the flip rule is allowed to fire+-- on. All laws leave the normal form alone — they restrict where the rule may+-- be applied, never what a legal diagonal is.+--+-- 'ValidMesh' legalizes a mesh that is already a triangulation. There a+-- non-convex quadrilateral's diagonal is necessarily locally Delaunay, so 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,+-- and the inverted one is exactly the one that must flip, so the short-circuit+-- becomes a refusal to perform the repair. The carried index is the undirected+-- edge count taken before the fan was built: every edge at or above it was+-- appended by the fan, and only those may flip, so a transiently inverted+-- neighbourhood cannot flip the cavity's border away.+--+-- 'SeamPreserving' admits a candidate exactly when neither incident target+-- face handle is selected by the caller. Face handles survive a flip, so this+-- protection is inductive while legalization propagates through the complete+-- unselected seam cavity.+data LegalizationLaw+  = ValidMesh+  | CavityRepair {-# UNPACK #-} !Int+  | SeamPreserving !(Int -> Bool)
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Hull.hs view
@@ -0,0 +1,551 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -O3 -fllvm -optlo-O3 -optlc-O3 #-}++-- | Growth outside the hull: visible ranges, turn closure, and convexity repair.+module Moonlight.Triangulation.Internal.DcelOperations.Hull+  ( ReservedSweepCells+  , SweepCellCursor+  , SweepInsertion (..)+  , reserveSweepCells+  , initialSweepCellCursor+  , commitReservedSweepConnections+  , insertOutsideHull+  , insertOutsideHullAtEdge+  , closeOuterTurn+  , closeOuterTurnReserved+  , fixHullConvexity+  ) where++import Control.Monad (forM_, when)+import Control.Monad.ST (ST)+import Data.STRef (writeSTRef)+import Moonlight.Triangulation.Internal.HandleDefs (DirectedEdgeId (..), FaceId (..))+import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena+  ( seedGenericPairInArena+  )+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+  ( 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+  , readNext+  , readOrigin+  , readPointX+  , readPointY+  , readPrevious+  , setCycle3+  , writeFace+  , writeFaceEdge+  , writeNext+  , writeOrigin+  , writePrevious+  , writeVertexOut+  )+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , LegalizationArena+  , OperationState+  , addCounter+  , readScratch+  , writeScratch+  )+import Moonlight.Triangulation.Internal.Probe (KnownProbe)+import Moonlight.Triangulation.Types (BuildError (..), Point (..))+import Moonlight.Triangulation.Internal.Predicates (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+  visibleStart <- visibleOuter mutable start query+  if not visibleStart+    then pure (Left (HullStartNotVisible (DirectedEdgeId (fromIntegral start))))+    else do+      halfEdges <- directedEdgeCount mutable+      left <- expandPrevious halfEdges start start query+      right <- expandNext halfEdges start left query+      collected <- collectOuterChain mutable operation left right+      case collected of+        Left obstruction -> pure (Left obstruction)+        Right chainCount -> do+          inserted <- insertOutsideHullCollected @p mutable operation vertex chainCount+          case inserted of+            Left obstruction -> pure (Left obstruction)+            Right _ -> do+              -- The regular insertion path owns its own hull-insertion count; the sweep+              -- path through 'insertOutsideHullBetween' counts its own instead.+              addCounter operation CounterHullInsertions 1+              pure (Right ())+ where+  expandPrevious !bound !stopAt !current !query+    | bound <= 0 = pure current+    | otherwise = do+        candidate <- readPrevious mutable current+        if candidate == stopAt+          then pure current+          else do+            visible <- visibleOuter mutable candidate query+            if visible then expandPrevious (bound - 1) stopAt candidate query else pure current++  expandNext !bound !current !left !query+    | bound <= 0 = pure current+    | otherwise = do+        candidate <- readNext mutable current+        if candidate == left+          then pure current+          else do+            visible <- visibleOuter mutable candidate query+            if visible then expandNext (bound - 1) candidate left query else pure current++-- | 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+  -> 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+  -> OperationState s+  -> Int+  -> Int+  -> ST s (Either BuildError Int)+collectOuterChain mutable operation left right = do+  halfEdges <- directedEdgeCount mutable+  go (halfEdges + 1) left 0+ where+  go !remaining !current !count+    | remaining <= 0 =+        pure+          ( Left+              ( OuterRangeDidNotTerminate+                  (DirectedEdgeId (fromIntegral left))+                  (DirectedEdgeId (fromIntegral right))+                  count+              )+          )+    | otherwise = do+        incident <- readFace mutable current+        if incident /= 0+          then+            pure+              ( Left+                  ( OuterRangeContainsInnerEdge+                      (DirectedEdgeId (fromIntegral current))+                      (FaceId (fromIntegral incident))+                  )+              )+          else do+            writeScratch operation count current+            if current == right+              then pure (Right (count + 1))+              else readNext mutable current >>= \following -> go (remaining - 1) following (count + 1)++insertOutsideHullCollected+  :: forall p s vertex directed undirected face+   . KnownProbe p+  => MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> ST s (Either BuildError (Int, Int))+insertOutsideHullCollected mutable@MutableDcel{mdLastFace} operation vertex chainCount = do+  capacity <- ensureCellCapacity mutable (chainCount + 1) chainCount+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> Right <$> insertOutsideHullWithCapacity+ where+  insertOutsideHullWithCapacity = do+    left <- readScratch operation 0+    right <- readScratch operation (chainCount - 1)+    oldPrevious <- readPrevious mutable left+    oldNext <- readNext mutable right+    edgeBase <- addEdgeBlock mutable (chainCount + 1)+    faceBase <- addFaceBlock mutable chainCount+    forM_ [0 .. chainCount] $ \index -> do+      chainVertex <-+        if index == 0+          then readScratch operation 0 >>= readOrigin mutable+          else readScratch operation (index - 1) >>= readOrigin mutable . reverseIndex+      let !forward = edgeBase + 2 * index+          !backward = forward + 1+      writeOrigin mutable forward chainVertex+      writeOrigin mutable backward vertex+    forM_ [0 .. chainCount - 1] $ \index -> do+      outerEdge <- readScratch operation index+      let !face = faceBase + index+          !nextSpoke = edgeBase + 2 * (index + 1)+          !previousSpoke = edgeBase + 2 * index + 1+      setCycle3 mutable face outerEdge nextSpoke previousSpoke+    let !firstOuterSpoke = edgeBase+        !lastOuterSpoke = edgeBase + 2 * chainCount + 1+    writeFace mutable firstOuterSpoke 0+    writeFace mutable lastOuterSpoke 0+    linkEdges mutable oldPrevious firstOuterSpoke+    linkEdges mutable firstOuterSpoke lastOuterSpoke+    linkEdges mutable lastOuterSpoke oldNext+    writeFaceEdge mutable 0 firstOuterSpoke+    forM_ [0 .. chainCount - 1] $ \index -> do+      chainEdge <- readScratch operation index+      chainVertex <- readOrigin mutable chainEdge+      writeVertexOut mutable chainVertex chainEdge+    lastChain <- readScratch operation (chainCount - 1)+    lastVertex <- readOrigin mutable (reverseIndex lastChain)+    writeVertexOut mutable lastVertex (edgeBase + 2 * chainCount)+    markConnected mutable vertex lastOuterSpoke+    writeSTRef mdLastFace faceBase+    legalizeScratch @p mutable operation vertex chainCount+    pure (firstOuterSpoke, lastOuterSpoke)++-- | Replace two consecutive outer edges @a->b, b->c@ by @a->c@ and+-- materialize the triangle they bound. The returned edge is the new outer+-- diagonal. This is the sole turn-closing primitive used both by deferred+-- circle sweep and the final Graham repair. Topology mutation only: the+-- caller owns the legalization epoch, and seeds the two closed edges itself+-- once the replacement's links are in place.+closeOuterTurn+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> ST s (Either BuildError Int)+closeOuterTurn mutable first = do+  capacity <- ensureCellCapacity mutable 1 1+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> 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+-- work it causes. Turn closures are seeded into one shared epoch as they+-- happen and drained once at the end: closure never deletes an edge and never+-- touches the outer cycle's legality, so which turns close does not depend on+-- when the interior is repaired. The pass counts its own closures and returns+-- the drain's tallies; nothing is reported behind its back.+fixHullConvexity+  :: ReservedSweepCells s vertex directed undirected face+  -> SweepCellCursor+  -> OperationState s+  -> 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, initialArena, initialCursor))+    else do+      walked <- walk start start 0 0 0 0 initialArena initialCursor+      case walked of+        Left obstruction -> pure (Left obstruction)+        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 !arena cursor@(SweepCellCursor halfEdges _) = do+    if steps > halfEdges + 2+      then+        pure+          ( Left+              ( OuterCycleDidNotTerminate+                  (DirectedEdgeId (fromIntegral start))+                  (DirectedEdgeId (fromIntegral current))+                  steps+              )+          )+      else do+        following <- denseReadNext dense current+        writeScratch operation stackSize current+        reduction <- reduce (stackSize + 1) top closures arena cursor+        case reduction of+          Left obstruction -> pure (Left obstruction)+          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, nextArena, nextCursor))+              else walk start following reduced (steps + 1) nextTop nextClosures nextArena nextCursor++  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 <- 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+            (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+  fromVertex <- readOrigin mutable edge+  toVertex <- readOrigin mutable (reverseIndex edge)+  case query of+    Point queryX queryY -> do+      fromX <- readPointX mutable fromVertex+      fromY <- readPointY mutable fromVertex+      toX <- readPointX mutable toVertex+      toY <- readPointY mutable toVertex+      pure (orient2dCoordinates fromX fromY toX toY queryX queryY == GT)+{-# INLINE visibleOuter #-}
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Legalize.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -O3 -fllvm -optlo-O3 -optlc-O3 #-}++-- | The seeding entry points that drive one legalization epoch.+module Moonlight.Triangulation.Internal.DcelOperations.Legalize+  ( legalizeScratch+  , legalizeStarEdge+  , legalizeDenseStarEdgeInArena+  , legalizeEdges+  , legalizeEdgesPinned+  , legalizeCavityFanScratch+  ) where++import Control.Monad (when)+import Control.Monad.ST (ST)+import Data.Foldable (traverse_)+import qualified Data.Vector.Unboxed.Mutable as MUV+import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena+  ( CandidateDiscipline (..)+  , growLegalizationArena+  , seedGenericEdges+  , seedStarScratch+  )+import Moonlight.Triangulation.Internal.DcelOperations.FlipRule+  ( LegalizationLaw (..)+  )+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+  , legalizationArenaLength+  , maxCounter+  , readScratch+  , storeLegalizationArena+  )+import Moonlight.Triangulation.Internal.PackedIndex (packIndex)+import Moonlight.Triangulation.Internal.Probe (KnownProbe, Probe (..))++legalizeEdges :: MutableDcel s vertex directed undirected face -> OperationState s -> [Int] -> ST s ()+legalizeEdges mutable operation initial = do+  top <- seedGenericEdges operation 0 initial+  (flips, maxDepth) <- drainLegalization @'ProbeOff mutable operation top GenericCandidates ValidMesh+  addCounter operation CounterEdgeFlips flips+  maxCounter operation CounterLegalizationMaxStack maxDepth++-- | Legalize the new seam and the source-prefix cavity whose current incident+-- face handles are both unprotected. The selector is evaluated dynamically as+-- flips propagate; it therefore admits the complete local exterior cavity+-- rather than only the zipper's first seeds. The seam owner certifies the+-- resulting cavity boundary after immutable publication.+legalizeEdgesPinned+  :: forall s vertex directed undirected face.+     (Int -> Bool)+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> [Int]+  -> ST s ()+legalizeEdgesPinned targetFaceProtected mutable operation initial = do+  top <- seedGenericEdges operation 0 initial+  (flips, maxDepth) <-+    drainLegalization+      @'ProbeOff+      mutable+      operation+      top+      GenericCandidates+      (SeamPreserving targetFaceProtected)+  addCounter operation CounterEdgeFlips flips+  maxCounter operation CounterLegalizationMaxStack maxDepth++-- | Repair the fan that fills a removed vertex's hole, draining cavity+-- candidates already written into the operation-owned scratch section. The+-- fan is a valid combinatorial filling but not yet a triangulation — a link+-- polygon that is non-convex at the fan origin yields an inverted triangle —+-- so this drain carries 'CavityRepair' rather than the insertion law: it+-- flips on the incircle determinant alone, and only the fan's own edges may+-- flip. Removal discovers and constructs the cavity inside that same+-- transaction; materializing a list merely to seed the legalization arena+-- would duplicate the local program.+legalizeCavityFanScratch+  :: MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> Int+  -> ST s ()+legalizeCavityFanScratch mutable operation cavityFloor scratchOffset candidateCount = do+  initialArena <- legalizationArena operation+  arena <- growLegalizationArena initialArena candidateCount+  when (legalizationArenaLength arena /= legalizationArenaLength initialArena) (storeLegalizationArena operation arena)+  let LegalizationArena values = arena+  traverse_+    (\index -> do+       edge <- readScratch operation (scratchOffset + index)+       MUV.unsafeWrite values index (packIndex edge)+    )+    [0 .. candidateCount - 1]+  (flips, maxDepth) <-+    drainLegalization+      @'ProbeOff+      mutable+      operation+      candidateCount+      GenericCandidates+      (CavityRepair cavityFloor)+  addCounter operation CounterEdgeFlips flips+  maxCounter operation CounterLegalizationMaxStack maxDepth++legalizeScratch :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s ()+legalizeScratch mutable operation vertex candidateCount = do+  top <- seedStarScratch operation 0 candidateCount+  (flips, maxDepth) <- drainLegalization @p mutable operation top (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 #-}
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Normalize.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -O3 -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.STRef (readSTRef)+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32)+import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena+  ( CandidateDiscipline (..)+  , growLegalizationArena+  )+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+  ( DenseMutableDcel+  , MutableDcel (..)+  , MutableTopology (..)+  )+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , LegalizationArena (..)+  , OperationState+  , legalizationArena+  , legalizationArenaLength+  , storeLegalizationArena+  )+import Moonlight.Triangulation.Internal.PackedIndex (packIndex)+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.+--+-- The objects are the triangulations of a fixed point set. The single rule is+-- the Lawson flip: a locally illegal diagonal is replaced by the other+-- diagonal of its quadrilateral. A normal form is a mesh with no illegal+-- diagonal left to fire on.+--+-- /Termination/ is by the lifted-paraboloid potential. Send each point to+-- @(x, y, x² + y²)@ and read a triangulation as a piecewise-linear surface+-- over the point set; @illegalDiagonal@ is exactly the test that the flip+-- lowers that surface, so every rewrite strictly decreases it, and a finite+-- point set has finitely many triangulations. Exact cocircularity is the one+-- case where the surface does not move — the four lifted points are coplanar+-- and both diagonals give the same surface — so there the potential is the+-- diagonal's own key order, and the rule fires only downward in it. Without+-- that tie-break a cocircular quadrilateral flips forever.+--+-- /Confluence/ is Delaunay's theorem, in its strong form: a triangulation with+-- no locally illegal diagonal is globally Delaunay. Local normality is thus+-- global normality, the normal form is unique, and every rewrite order reaches+-- it. That is what licenses the arena below to be a LIFO stack rather than a+-- priority queue, and it is why callers may seed it in whatever order is+-- cheapest to produce — the fan first, or the hull turns first, or both+-- interleaved — without any of them changing the mesh that comes out.+--+-- All callers differ only in how they seed the arena; topology mutation and+-- propagation have exactly one owner.+-- The stack top, the maximum top, and the flip count are strict loop+-- variables, returned once when the drain finishes — the mesh reports nothing+-- per candidate, and 'applyFlip' reports nothing at all. The phantom+-- 'KnownProbe' parameter counts popped candidates for the instrumented lane+-- and is erased everywhere else.+--+-- A popped candidate is read once. Turning it against the star vertex, judging+-- it, and rewriting it are three questions about the same two half-edge+-- records, and the apex the turn looks for is the apex the judgement needs, so+-- one pass over the quadrilateral answers all three.+drainLegalization+  :: forall p mutable s vertex directed undirected face+   . (KnownProbe p, MutableTopology mutable)+  => mutable s vertex directed undirected face+  -> OperationState s+  -> Int+  -> CandidateDiscipline+  -> LegalizationLaw+  -> ST s (Int, Int)+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+  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 -- The cavity-repair floor pins the fan border. Ordinary legalization+      -- pins nothing; seam legalization instead uses its incident-face+      -- selector below, so both copied and appended pairs obey the same+      -- protection law.+      !floorPair = case law of+        ValidMesh -> 0+        CavityRepair floorEdge -> floorEdge+        SeamPreserving _ -> 0++      eligible rawEdge = do+        unconstrained <-+          if guarded+            then not <$> topologyReadConstraint topology rawEdge+            else pure True+        if not unconstrained+          then pure False+          else+            case law of+              SeamPreserving targetFaceProtected -> do+                leftFace <- topologyReadFace topology rawEdge+                rightFace <- topologyReadFace topology (reverseIndex rawEdge)+                pure+                  ( not (targetFaceProtected leftFace)+                      && not (targetFaceProtected rightFace)+                  )+              _ -> pure (rawEdge `shiftR` 1 >= floorPair)++      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 !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 <- topologyReadFace topology rawEdge+                rawTwinFace <- topologyReadFace topology rawTwin+                if rawFace == 0 || rawTwinFace == 0+                  then loopStar starVertex starX starY arena nextTop maxTop flips (probeBump @p candidates)+                  else do+                    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+                        -- 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 #-}
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Subdivide.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Insertion into an existing element: face split and edge split.+module Moonlight.Triangulation.Internal.DcelOperations.Subdivide+  ( insertIntoFace+  , insertOnEdge+  , splitBoundaryEdgeWithLegalization+  ) where++import Control.Monad (unless, void, when)+import Control.Monad.ST (ST)+import Moonlight.Triangulation.Internal.HandleDefs (UndirectedEdgeId (..))+import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeScratch)+import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex)+import Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel+  , addEdgeBlock+  , addFaceBlock+  , ensureCellCapacity+  , faceEdges+  , linkEdges+  , markConnected+  , payloadsPristine+  , readConstraint+  , readFace+  , readNext+  , readOrigin+  , readPrevious+  , resetEdgeData+  , resetFaceData+  , setConstraint+  , setCycle3+  , writeFace+  , writeFaceEdge+  , writeOrigin+  , writeVertexOut+  )+import Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , OperationState+  , addCounter+  , writeScratch+  )+import Moonlight.Triangulation.Internal.Probe (KnownProbe)+import Moonlight.Triangulation.Internal.Types (BuildError (..))++insertIntoFace :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())+insertIntoFace mutable operation face vertex = do+  capacity <- ensureCellCapacity mutable 3 2+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> do+      insertIntoFaceWithCapacity @p mutable operation face vertex+      pure (Right ())++insertIntoFaceWithCapacity :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s ()+insertIntoFaceWithCapacity mutable operation face vertex = do+  (eAB, eBC, eCA) <- faceEdges mutable face+  a <- readOrigin mutable eAB+  b <- readOrigin mutable eBC+  c <- readOrigin mutable eCA+  edgeBase <- addEdgeBlock mutable 3+  let !eAV = edgeBase+      !eVA = edgeBase + 1+      !eBV = edgeBase + 2+      !eVB = edgeBase + 3+      !eCV = edgeBase + 4+      !eVC = edgeBase + 5+  writeOrigin mutable eAV a+  writeOrigin mutable eVA vertex+  writeOrigin mutable eBV b+  writeOrigin mutable eVB vertex+  writeOrigin mutable eCV c+  writeOrigin mutable eVC vertex+  faceBase <- addFaceBlock mutable 2+  setCycle3 mutable face eAB eBV eVA+  setCycle3 mutable faceBase eBC eCV eVB+  setCycle3 mutable (faceBase + 1) eCA eAV eVC+  writeVertexOut mutable a eAB+  writeVertexOut mutable b eBC+  writeVertexOut mutable c eCA+  markConnected mutable vertex eVA+  -- ABC has become ABV; the other two thirds of it are fresh faces. The three+  -- boundary edges keep their endpoints and so keep their labels.+  resetFaceData mutable face+  writeScratch operation 0 eAB+  writeScratch operation 1 eBC+  writeScratch operation 2 eCA+  addCounter operation CounterFaceSplits 1+  legalizeScratch @p mutable operation vertex 3++insertOnEdge :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())+insertOnEdge mutable operation suppliedEdge vertex = do+  suppliedFace <- readFace mutable suppliedEdge+  reverseFace <- readFace mutable (reverseIndex suppliedEdge)+  if suppliedFace == 0 || reverseFace == 0+    then splitBoundaryEdge @p mutable operation suppliedEdge vertex+    else splitInteriorEdge @p mutable operation suppliedEdge vertex++splitInteriorEdge :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())+splitInteriorEdge mutable operation suppliedEdge vertex = do+  capacity <- ensureCellCapacity mutable 3 2+  case capacity of+    Left obstruction -> pure (Left obstruction)+    Right () -> do+      splitInteriorEdgeWithCapacity @p mutable operation suppliedEdge vertex+      pure (Right ())++splitInteriorEdgeWithCapacity :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s ()+splitInteriorEdgeWithCapacity mutable operation suppliedEdge vertex = do+  protected <- readConstraint mutable suppliedEdge+  suppliedFace <- readFace mutable suppliedEdge+  let !edge = if suppliedFace == 0 then reverseIndex suppliedEdge else suppliedEdge+      !reverseEdgeEdge = reverseIndex edge+  leftFace <- readFace mutable edge+  rightFace <- readFace mutable reverseEdgeEdge+  eBC <- readNext mutable edge+  eCA <- readPrevious mutable edge+  eAD <- readNext mutable reverseEdgeEdge+  eDB <- readPrevious mutable reverseEdgeEdge+  a <- readOrigin mutable edge+  b <- readOrigin mutable reverseEdgeEdge+  c <- readOrigin mutable eCA+  d <- readOrigin mutable eDB+  writeOrigin mutable reverseEdgeEdge vertex+  edgeBase <- addEdgeBlock mutable 3+  let !eVB = edgeBase+      !eBV = edgeBase + 1+      !eVC = edgeBase + 2+      !eCV = edgeBase + 3+      !eVD = edgeBase + 4+      !eDV = edgeBase + 5+  writeOrigin mutable eVB vertex+  writeOrigin mutable eBV b+  writeOrigin mutable eVC vertex+  writeOrigin mutable eCV c+  writeOrigin mutable eVD vertex+  writeOrigin mutable eDV d+  faceBase <- addFaceBlock mutable 2+  setCycle3 mutable leftFace edge eVC eCA+  setCycle3 mutable faceBase eVB eBC eCV+  setCycle3 mutable rightFace eBV eVD eDB+  setCycle3 mutable (faceBase + 1) reverseEdgeEdge eAD eDV+  writeVertexOut mutable a edge+  writeVertexOut mutable b eBC+  writeVertexOut mutable c eCA+  writeVertexOut mutable d eDB+  markConnected mutable vertex reverseEdgeEdge+  -- AB became AV, and both incident triangles lost a corner to the new vertex.+  unless (payloadsPristine mutable) $ do+    resetEdgeData mutable (edge `quot` 2)+    resetFaceData mutable leftFace+    resetFaceData mutable rightFace+  when protected $ do+    _ <- setConstraint mutable eVB+    pure ()+  writeScratch operation 0 eCA+  writeScratch operation 1 eBC+  writeScratch operation 2 eDB+  writeScratch operation 3 eAD+  addCounter operation CounterInteriorEdgeSplits 1+  legalizeScratch @p mutable operation vertex 4++splitBoundaryEdge :: forall p s vertex directed undirected face. KnownProbe p => MutableDcel s vertex directed undirected face -> OperationState s -> Int -> Int -> ST s (Either BuildError ())+splitBoundaryEdge mutable operation suppliedEdge vertex = do+  outcome <-+    splitBoundaryEdgeWithLegalization+      (\target targetOperation insertedVertex _ _ ->+         legalizeScratch @p target targetOperation insertedVertex 2+      )+      mutable+      operation+      suppliedEdge+      vertex+  pure (void outcome)++-- | Split one hull edge and return its two replacement outer edges in the+-- original outer-cycle order.  Topology and constraint inheritance have one+-- owner; callers choose only the lawful legalization boundary.  Ordinary+-- insertion drains the new vertex's scratch star, while a source-preserving+-- seam can pin its immutable face section.+splitBoundaryEdgeWithLegalization+  :: ( MutableDcel s vertex directed undirected face+       -> OperationState s+       -> Int+       -> Int+       -> Int+       -> ST s ()+     )+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> ST s (Either BuildError (Int, Int))+splitBoundaryEdgeWithLegalization legalize mutable operation suppliedEdge vertex = do+  suppliedFace <- readFace mutable suppliedEdge+  reverseFace <- readFace mutable (reverseIndex suppliedEdge)+  if suppliedFace /= 0 && reverseFace /= 0+    then+      pure+        ( Left+            ( BoundarySplitRequiresBoundaryEdge+                (UndirectedEdgeId (fromIntegral (suppliedEdge `quot` 2)))+            )+        )+    else do+      capacity <- ensureCellCapacity mutable 2 1+      case capacity of+        Left obstruction -> pure (Left obstruction)+        Right () ->+          Right+            <$> splitBoundaryEdgeWithCapacity+              legalize+              mutable+              operation+              suppliedEdge+              vertex++splitBoundaryEdgeWithCapacity+  :: ( MutableDcel s vertex directed undirected face+       -> OperationState s+       -> Int+       -> Int+       -> Int+       -> ST s ()+     )+  -> MutableDcel s vertex directed undirected face+  -> OperationState s+  -> Int+  -> Int+  -> ST s (Int, Int)+splitBoundaryEdgeWithCapacity legalize mutable operation suppliedEdge vertex = do+  protected <- readConstraint mutable suppliedEdge+  suppliedFace <- readFace mutable suppliedEdge+  let !edge = if suppliedFace == 0 then reverseIndex suppliedEdge else suppliedEdge+      !outerEdge = reverseIndex edge+  innerFace <- readFace mutable edge+  eBC <- readNext mutable edge+  eCA <- readPrevious mutable edge+  a <- readOrigin mutable edge+  b <- readOrigin mutable outerEdge+  c <- readOrigin mutable eCA+  oldOuterPrevious <- readPrevious mutable outerEdge+  oldOuterNext <- readNext mutable outerEdge+  writeOrigin mutable outerEdge vertex+  edgeBase <- addEdgeBlock mutable 2+  let !eVB = edgeBase+      !eBV = edgeBase + 1+      !eVC = edgeBase + 2+      !eCV = edgeBase + 3+  writeOrigin mutable eVB vertex+  writeOrigin mutable eBV b+  writeOrigin mutable eVC vertex+  writeOrigin mutable eCV c+  newFace <- addFaceBlock mutable 1+  setCycle3 mutable innerFace edge eVC eCA+  setCycle3 mutable newFace eVB eBC eCV+  writeFace mutable outerEdge 0+  writeFace mutable eBV 0+  linkEdges mutable oldOuterPrevious eBV+  linkEdges mutable eBV outerEdge+  linkEdges mutable outerEdge oldOuterNext+  writeFaceEdge mutable 0 outerEdge+  writeVertexOut mutable a edge+  writeVertexOut mutable b eBC+  writeVertexOut mutable c eCA+  markConnected mutable vertex eVB+  -- AB became AV and the one interior triangle lost a corner. The outer face+  -- is not an element and keeps nothing to lose.+  unless (payloadsPristine mutable) $ do+    resetEdgeData mutable (edge `quot` 2)+    resetFaceData mutable innerFace+  when protected $ do+    _ <- setConstraint mutable eVB+    pure ()+  writeScratch operation 0 eCA+  writeScratch operation 1 eBC+  addCounter operation CounterBoundaryEdgeSplits 1+  legalize mutable operation vertex eCA eBC+  pure (eBV, outerEdge)
+ src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Twin.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | The pairing involution on half-edge indices.+module Moonlight.Triangulation.Internal.DcelOperations.Twin+  ( reverseIndex+  ) where++import Data.Bits (xor)++reverseIndex :: Int -> Int+reverseIndex edge = edge `xor` 1+{-# INLINE reverseIndex #-}
+ src-dcel/Moonlight/Triangulation/Internal/ExactSegmentEvents.hs view
@@ -0,0 +1,890 @@+{-# 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.List as List+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 = List.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 = List.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/FaceProbe.hs view
@@ -0,0 +1,38 @@+module Moonlight.Triangulation.Internal.FaceProbe+  ( BoundaryProbe (..)+  , probeBoundary+  ) where++import Moonlight.Triangulation.Internal.Predicates (onClosedSegment, orient2d)+import Moonlight.Triangulation.Types (Point)++-- | Classification of one oriented boundary of a triangular face. A+-- 'BoundaryCrossing' carries the half-edge whose incident face is the+-- destination of the walk; consumers must not reverse it again.+data BoundaryProbe edge vertex+  = BoundaryClear+  | BoundaryOnVertex !vertex+  | BoundaryOnEdge !edge+  | BoundaryCrossing !edge+  deriving stock (Eq, Ord, Show)++probeBoundary+  :: (edge -> edge)+  -> Point+  -> edge+  -> vertex+  -> Point+  -> vertex+  -> Point+  -> BoundaryProbe edge vertex+probeBoundary reverseBoundary query edge fromVertex from toVertex to+  | query == from = BoundaryOnVertex fromVertex+  | query == to = BoundaryOnVertex toVertex+  | otherwise =+      case orient2d from to query of+        EQ+          | onClosedSegment from to query -> BoundaryOnEdge edge+          | otherwise -> BoundaryClear+        LT -> BoundaryCrossing (reverseBoundary edge)+        GT -> BoundaryClear+{-# INLINE probeBoundary #-}
+ src-dcel/Moonlight/Triangulation/Internal/FloodFillIterator.hs view
@@ -0,0 +1,743 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}++-- | Shape queries and face flood fills over immutable triangulations.+module Moonlight.Triangulation.Internal.FloodFillIterator+  ( DistanceMetric (..)+  , CircleMetric+  , CircleMetricError (..)+  , RectangleMetric+  , RectangleMetricError (..)+  , circleMetric+  , rectangleMetric+  , edgesInShape+  , verticesInShape+  , edgesInCircle+  , verticesInCircle+  , edgesInRectangle+  , verticesInRectangle+  , floodFillFaces+  , floodFillFacesWithRejectedEdges+  , outerFaceFloodFill+  , facesAtEvenBarrierDepth+  , FaceComponent+  , faceComponentFaces+  , BoundaryOrientation (..)+  , BoundaryLoop+  , boundaryLoopOrientation+  , boundaryLoopResidentVertices+  , boundaryLoopVertices+  , RegionBoundary+  , regionBoundaryOuterLoop+  , regionBoundaryHoleLoops+  , BoundaryObstruction (..)+  , faceComponents+  , faceComponentsBy+  , labelledRegionBoundaries+  , componentBoundaryLoops+  , componentBoundary+  , componentBoundaryForFaces+  ) 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 qualified Data.List as List+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Vector as V+import GHC.Generics (Generic)+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (undirectedEdges)+import Moonlight.Triangulation.Internal.BoundaryCycle+  ( simplifyBoundaryCycle+  , traceOrientedBoundaryCircuits+  )+import Moonlight.Triangulation.Internal.Predicates+import Moonlight.Triangulation.Math+  ( mkQueryPoint+  , segmentDistanceSquaredWide+  , squaredDistanceWide+  )+import Moonlight.Triangulation.PointLocation+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)++-- | Winding carried explicitly by a simple boundary loop.+data BoundaryOrientation+  = BoundaryCounterClockwise+  | BoundaryClockwise+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | One non-empty simple boundary loop. Counter-clockwise loops contribute+-- filled area under nonzero winding; clockwise loops subtract holes.+data BoundaryLoop = BoundaryLoop+  { boundaryLoopOrientation :: !BoundaryOrientation+  -- | Exact resident DCEL boundary chain. Consecutive vertices, including+  -- the closing pair, are endpoints of one boundary half-edge.+  , boundaryLoopResidentVertices :: !(NonEmpty VertexId)+  -- | Collinearity-reduced polygon observation of the same resident chain.+  , 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 or project their oriented+-- loops into one strict polygon component.+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)++-- | Complete boundary edges refined by whether each vertex has one successor.+data BoundaryGraph+  = SimpleBoundaryGraph !IntSet.IntSet !(IntMap.IntMap DirectedEdgeId)+  | PinchedBoundaryGraph+      !IntSet.IntSet+      !VertexId+      !DirectedEdgeId+      !DirectedEdgeId++-- | A query shape that can admit points, test edges, and supply a location+-- seed.+class DistanceMetric metric where+  metricContainsPoint :: metric -> Point -> Bool+  metricIntersectsEdge :: metric -> Point -> Point -> Bool+  metricStartPoint :: metric -> QueryPoint++-- | An admitted center and squared radius.+data CircleMetric = CircleMetric !QueryPoint !RadiusSquared+  deriving stock (Eq, Ord, Show)++-- | Typed refusal for an invalid circle query.+data CircleMetricError+  = InvalidCircleCenter !PointValidationError+  | InvalidCircleRadius !RadiusSquaredError+  deriving stock (Eq, Ord, Show)++-- | Admitted lower corner, upper corner, and center of an axis-aligned box.+data RectangleMetric = RectangleMetric !(QueryPoint) !(QueryPoint) !(QueryPoint)+  deriving stock (Eq, Ord, Show)++-- | Typed refusal for an invalid rectangle query.+data RectangleMetricError+  = InvalidRectangleLower !PointValidationError+  | InvalidRectangleUpper !PointValidationError+  | InvalidRectangleCenter !PointValidationError+  deriving stock (Eq, Ord, Show)++-- | A circle metric, or why the radius is unusable.+circleMetric :: Point -> Double -> Either CircleMetricError CircleMetric+circleMetric center radiusSquared =+  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+rectangleMetric lower@(Point lowerX lowerY) upper@(Point upperX upperY) = do+  queryLower <- either (Left . InvalidRectangleLower) Right (mkQueryPoint lower)+  queryUpper <- either (Left . InvalidRectangleUpper) Right (mkQueryPoint upper)+  queryCenter <-+    either+      (Left . InvalidRectangleCenter)+      Right+      (mkQueryPoint (Point ((lowerX + upperX) * 0.5) ((lowerY + upperY) * 0.5)))+  Right (RectangleMetric queryLower queryUpper queryCenter)++instance DistanceMetric CircleMetric where+  metricContainsPoint (CircleMetric center radius) point =+    squaredDistanceWide (queryPointValue center) point <= radiusSquaredValue radius+  metricIntersectsEdge (CircleMetric center radius) from to =+    segmentDistanceSquaredWide from to (queryPointValue center) <= radiusSquaredValue radius+  metricStartPoint (CircleMetric center _) = center++instance DistanceMetric RectangleMetric where+  metricContainsPoint (RectangleMetric lower upper _) (Point x y) =+    lowerX <= upperX && lowerY <= upperY && x >= lowerX && x <= upperX && y >= lowerY && y <= upperY+   where+    Point lowerX lowerY = queryPointValue lower+    Point upperX upperY = queryPointValue upper+  metricIntersectsEdge rectangle from to =+    metricContainsPoint rectangle from+      || metricContainsPoint rectangle to+      || segmentRectangleIntersection rectangle from to+  metricStartPoint (RectangleMetric _ _ center) = center++-- | Edges meeting a circle.+edgesInCircle :: Triangulation mode vertex directed undirected face -> Point -> Double -> Either CircleMetricError [UndirectedEdgeId]+edgesInCircle triangulation center radiusSquared =+  edgesInShape triangulation <$> circleMetric center radiusSquared++-- | Vertices inside a circle.+verticesInCircle :: Triangulation mode vertex directed undirected face -> Point -> Double -> Either CircleMetricError [VertexId]+verticesInCircle triangulation center radiusSquared =+  verticesInShape triangulation <$> circleMetric center radiusSquared++-- | Edges meeting an axis-aligned rectangle.+edgesInRectangle :: Triangulation mode vertex directed undirected face -> Point -> Point -> Either RectangleMetricError [UndirectedEdgeId]+edgesInRectangle triangulation lower upper = edgesInShape triangulation <$> rectangleMetric lower upper++-- | Vertices inside an axis-aligned rectangle.+verticesInRectangle :: Triangulation mode vertex directed undirected face -> Point -> Point -> Either RectangleMetricError [VertexId]+verticesInRectangle triangulation lower upper = verticesInShape triangulation <$> rectangleMetric lower upper++-- | Edges meeting any metric shape.+edgesInShape :: DistanceMetric metric => Triangulation mode vertex directed undirected face -> metric -> [UndirectedEdgeId]+edgesInShape triangulation metric+  | numVertices triangulation <= 1 = []+  | numInnerFaces triangulation == 0 =+      [edge | edge <- undirectedEdges triangulation, edgeInside edge]+  | otherwise =+      let starts = shapeStartFaces triangulation metric+          (_, accepted, _) = floodFillFacesWithEdges triangulation starts edgeInside+       in map (UndirectedEdgeId . fromIntegral) (IntSet.toAscList accepted)+ where+  edgeInside edge =+    let (fromVertex, toVertex) = undirectedEndpoints triangulation edge+     in metricIntersectsEdge metric (vertexPoint triangulation fromVertex) (vertexPoint triangulation toVertex)++-- | Vertices inside any metric shape.+verticesInShape :: DistanceMetric metric => Triangulation mode vertex directed undirected face -> metric -> [VertexId]+verticesInShape triangulation metric =+  [ vertex+  | vertex <- candidateVertices+  , metricContainsPoint metric (vertexPoint triangulation vertex)+  ]+ where+  edges = edgesInShape triangulation metric+  set = List.foldl' addEndpoints IntSet.empty edges+  addEndpoints acc edge =+    let (from, to) = undirectedEndpoints triangulation edge+     in IntSet.insert (vertexIdIndex from) (IntSet.insert (vertexIdIndex to) acc)+  candidateVertices+    | numVertices triangulation == 1 = [VertexId 0]+    | otherwise = map (VertexId . fromIntegral) (IntSet.toAscList set)++-- | Reach inner faces from the supplied seeds by crossing only admitted edges.+floodFillFaces+  :: Triangulation mode vertex directed undirected face -> [FaceId]+  -> (UndirectedEdgeId -> Bool)+  -> [FaceId]+floodFillFaces triangulation starts canCross =+  let (faces, _, _) = floodFillFacesWithEdges triangulation starts canCross+   in faces++-- | The reached section and the edge pairs whose crossing was rejected while+-- descending it. This package-internal observation retains the boundary+-- witness instead of requiring a later face-wide rediscovery.+floodFillFacesWithRejectedEdges+  :: Triangulation mode vertex directed undirected face -> [FaceId]+  -> (UndirectedEdgeId -> Bool)+  -> ([FaceId], [UndirectedEdgeId])+floodFillFacesWithRejectedEdges triangulation starts canCross =+  let (faces, _, rejected) = floodFillFacesWithEdges triangulation starts canCross+   in (faces, fmap (UndirectedEdgeId . fromIntegral) (IntSet.toAscList rejected))++floodFillFacesWithEdges+  :: Triangulation mode vertex directed undirected face -> [FaceId]+  -> (UndirectedEdgeId -> Bool)+  -> ([FaceId], IntSet.IntSet, IntSet.IntSet)+floodFillFacesWithEdges triangulation starts canCross =+  let (faces, accepted, rejected) = go initialStack initialVisited IntSet.empty IntSet.empty []+   in (reverse faces, accepted, rejected)+ where+  valid face = face /= outerFace && faceIdIndex face < numFaces triangulation+  (initialStack, initialVisited) = List.foldl' enqueueStart ([], IntSet.empty) starts++  enqueueStart state face+    | valid face = enqueue face state+    | otherwise = state++  go [] _ accepted rejected result = (result, accepted, rejected)+  go (face : stack) visited accepted rejected result =+    let (stack', visited', accepted', rejected') =+          foldFaceDirectedEdges'+            triangulation+            face+            expand+            (stack, visited, accepted, rejected)+     in go stack' visited' accepted' rejected' (face : result)++  expand (stack, visited, accepted, rejected) edge =+    let undirected = asUndirected edge+        edgeIndex = undirectedEdgeIdIndex undirected+        adjacent = incidentFace triangulation (reverseEdge edge)+        edgeAdmission+          | IntSet.member edgeIndex accepted = (True, accepted, rejected)+          | IntSet.member edgeIndex rejected = (False, accepted, rejected)+          | canCross undirected = (True, IntSet.insert edgeIndex accepted, rejected)+          | otherwise = (False, accepted, IntSet.insert edgeIndex rejected)+        (crosses, accepted', rejected') = edgeAdmission+        (stack', visited') =+          if crosses && valid adjacent+            then enqueue adjacent (stack, visited)+            else (stack, visited)+     in (stack', visited', accepted', rejected')++  enqueue face (stack, visited)+    | IntSet.member index visited = (stack, visited)+    | otherwise = (face : stack, IntSet.insert index visited)+   where+    index = faceIdIndex face++-- | 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 =+  faceComponentsFromLabels triangulation labelAt (const True)+ where+  labels =+    V.generate+      (numInnerFaces triangulation)+      (\index -> labelFace (FaceId (fromIntegral (index + 1))))+  labelAt faceIndex = labels V.!? (faceIndex - 1)++-- | Connected components over a selected face section and admitted adjacency.+-- A missing label removes a face from the section; the edge predicate states+-- which overlaps glue. This is the common descent used by ordinary labelled+-- regions and exact-overlay charts whose representation diagonals alone may+-- connect collapsed resident faces.+faceComponentsBy+  :: Eq label+  => Triangulation mode vertex directed undirected face+  -> (FaceId -> Maybe label)+  -> (UndirectedEdgeId -> Bool)+  -> [(label, FaceComponent)]+faceComponentsBy triangulation labelFace =+  faceComponentsFromLabels triangulation labelAt+ where+  labels =+    V.generate+      (numInnerFaces triangulation)+      (\index -> labelFace (FaceId (fromIntegral (index + 1))))+  labelAt faceIndex = labels V.!? (faceIndex - 1) >>= id++faceComponentsFromLabels+  :: Eq label+  => Triangulation mode vertex directed undirected face+  -> (Int -> Maybe label)+  -> (UndirectedEdgeId -> Bool)+  -> [(label, FaceComponent)]+faceComponentsFromLabels triangulation labelAt canCross =+  unfoldr descend initialUnvisited+ where+  initialUnvisited =+    IntSet.fromRange (1, numFaces triangulation - 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+      canCross (asUndirected edge)+        && adjacent /= outerFace+        && IntSet.member adjacentIndex unvisited+        && labelAt adjacentIndex == Just componentLabel+      then+        ( queued Seq.|> adjacentIndex+        , IntSet.delete adjacentIndex unvisited+        )+      else (queued, unvisited)+   where+    adjacent = incidentFace triangulation (reverseEdge edge)+    adjacentIndex = faceIdIndex adjacent+{-# INLINE faceComponentsFromLabels #-}++-- | 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 the non-empty oriented boundary chain of one component. Boundary+-- half-edges retain their incident component face on the left. If several+-- boundary arms meet at one vertex, Euler descent consumes every half-edge+-- once and repeated-vertex splitting publishes finitely many simple loops.+componentBoundaryLoops+  :: Triangulation mode vertex directed undirected face+  -> FaceComponent+  -> Either BoundaryObstruction (NonEmpty BoundaryLoop)+componentBoundaryLoops triangulation component = do+  graph <- componentBoundaryGraph triangulation component+  loops <-+    case graph of+      SimpleBoundaryGraph edges outgoing ->+        traceBoundaryLoops triangulation outgoing edges+      PinchedBoundaryGraph edges _ _ _ ->+        tracePinchedBoundaryLoops triangulation edges+  case NonEmpty.nonEmpty loops of+    Just nonEmptyLoops -> Right nonEmptyLoops+    Nothing -> Left (BoundaryOuterLoopCardinality 0)++-- | Project one component into a strict polygon boundary. A pinched oriented+-- chain remains available through 'componentBoundaryLoops', but it is not one+-- lawful 'RegionBoundary' and is refused here with its first pinch witness.+componentBoundary+  :: Triangulation mode vertex directed undirected face+  -> FaceComponent+  -> Either BoundaryObstruction RegionBoundary+componentBoundary triangulation component = do+  graph <- componentBoundaryGraph triangulation component+  case graph of+    PinchedBoundaryGraph _ vertex firstEdge secondEdge ->+      Left (BoundaryPinch vertex firstEdge secondEdge)+    SimpleBoundaryGraph edges outgoing ->+      traceBoundaryLoops triangulation outgoing edges+        >>= regionBoundaryFromLoops++-- | Project exactly the supplied face section into one boundary. This is the+-- selected-section descent used by local extension: it does not label or+-- flood the complement, and therefore its work is proportional to the faces+-- named by the caller plus their constant-degree boundary edges.+componentBoundaryForFaces+  :: Triangulation mode vertex directed undirected face+  -> Set.Set FaceId+  -> Either BoundaryObstruction RegionBoundary+componentBoundaryForFaces triangulation selectedFaces = do+  component <- selectedFaceComponent triangulation selectedFaces+  componentBoundary triangulation component++selectedFaceComponent+  :: Triangulation mode vertex directed undirected face+  -> Set.Set FaceId+  -> Either BoundaryObstruction FaceComponent+selectedFaceComponent triangulation selectedFaces =+  case IntSet.lookupMin indices of+    Just 0 -> Left (BoundaryComponentFaceOutOfRange (FaceId 0) (numFaces triangulation))+    _ ->+      case IntSet.lookupGE (numFaces triangulation) indices of+        Just invalid ->+          Left+            ( BoundaryComponentFaceOutOfRange+                (FaceId (fromIntegral invalid))+                (numFaces triangulation)+            )+        Nothing -> Right (FaceComponent indices)+ where+  indices = IntSet.fromList (fmap faceIdIndex (Set.toAscList selectedFaces))++componentBoundaryGraph+  :: Triangulation mode vertex directed undirected face+  -> FaceComponent+  -> Either BoundaryObstruction BoundaryGraph+componentBoundaryGraph triangulation (FaceComponent componentFaces) =+  case IntSet.lookupGE (numFaces triangulation) componentFaces of+    Just invalid ->+      Left+        ( BoundaryComponentFaceOutOfRange+            (FaceId (fromIntegral invalid))+            (numFaces triangulation)+        )+    Nothing ->+      Right+        ( IntSet.foldl'+            collectFace+            (SimpleBoundaryGraph IntSet.empty IntMap.empty)+            componentFaces+        )+ where+  collectFace graph (face :: Int) =+    foldFaceDirectedEdges'+      triangulation+      (FaceId (fromIntegral face))+      insertBoundaryEdge+      graph++  insertBoundaryEdge graph edge+    | IntSet.member adjacentIndex componentFaces = graph+    | otherwise =+        case graph of+          PinchedBoundaryGraph edges pinchVertex firstEdge secondEdge ->+            PinchedBoundaryGraph+              (insertEdge edges)+              pinchVertex+              firstEdge+              secondEdge+          SimpleBoundaryGraph edges outgoing ->+            case IntMap.lookup residentIndex outgoing of+              Nothing ->+                SimpleBoundaryGraph+                  (insertEdge edges)+                  (IntMap.insert residentIndex edge outgoing)+              Just previousEdge ->+                PinchedBoundaryGraph+                  (insertEdge edges)+                  vertex+                  previousEdge+                  edge+   where+    adjacentIndex = faceIdIndex (incidentFace triangulation (reverseEdge edge))+    vertex = origin triangulation edge+    residentIndex = vertexIdIndex vertex+    insertEdge = IntSet.insert (directedEdgeIdIndex edge)++regionBoundaryFromLoops+  :: [BoundaryLoop]+  -> Either BoundaryObstruction RegionBoundary+regionBoundaryFromLoops loops =+  case outerLoops of+    [outerLoop] ->+      Right+        RegionBoundary+          { regionBoundaryOuterLoop = outerLoop+          , regionBoundaryHoleLoops = holeLoops+          }+    _ -> Left (BoundaryOuterLoopCardinality (length outerLoops))+ where+  (outerLoops, holeLoops) =+    partition+      ((== BoundaryCounterClockwise) . boundaryLoopOrientation)+      loops++tracePinchedBoundaryLoops+  :: Triangulation mode vertex directed undirected face+  -> IntSet.IntSet+  -> Either BoundaryObstruction [BoundaryLoop]+tracePinchedBoundaryLoops triangulation boundaryEdges = do+  cycles <-+    traceOrientedBoundaryCircuits+      (origin triangulation)+      (destination triangulation)+      BoundaryCycleDidNotClose+      outgoingByVertex+      orientedEdges+  traverse+    (simplifyBoundaryLoop triangulation . NonEmpty.toList)+    cycles+ where+  orientedEdges =+    Set.fromDistinctAscList+      ( fmap+          (DirectedEdgeId . fromIntegral)+          (IntSet.toAscList boundaryEdges)+      )+  outgoingByVertex =+    Set.foldr+      (\edge -> Map.insertWith (<>) (origin triangulation edge) [edge])+      Map.empty+      orientedEdges++traceBoundaryLoops+  :: Triangulation mode vertex directed undirected face+  -> IntMap.IntMap DirectedEdgeId+  -> IntSet.IntSet+  -> Either BoundaryObstruction [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 []+        loop <- simplifyBoundaryLoop triangulation vertices+        descend (loop : loops) remaining++  traceCycle start current unvisited reversedVertices =+    let remaining = IntSet.delete (directedEdgeIdIndex current) unvisited+        accumulated = origin triangulation current : reversedVertices+        target = destination triangulation current+     in case IntMap.lookup (vertexIdIndex target) outgoingByVertex of+          Just successor+            | successor == start -> Right (reverse accumulated, remaining)+            | IntSet.member (directedEdgeIdIndex successor) 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 BoundaryLoop+simplifyBoundaryLoop triangulation vertices = do+  (windingOrder, simplifiedVertices) <-+    simplifyBoundaryCycle+      BoundaryLoopDegenerate+      redundant+      winding+      key+      vertices+  residentVertices <-+    maybe+      (Left (BoundaryLoopDegenerate vertices))+      Right+      (NonEmpty.nonEmpty vertices)+  case windingOrder of+    GT -> Right (BoundaryLoop BoundaryCounterClockwise residentVertices simplifiedVertices)+    LT -> Right (BoundaryLoop BoundaryClockwise residentVertices simplifiedVertices)+    EQ -> Left (BoundaryLoopDegenerate (NonEmpty.toList simplifiedVertices))+ 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)++-- | Inner faces separated from the outer face by an even minimum number of+-- barriers. A 0–1 BFS floods freely within one depth before crossing a barrier,+-- so a free-ended barrier can be walked around at depth zero while nested+-- closed barriers alternate outside and inside.+facesAtEvenBarrierDepth+  :: Triangulation mode vertex directed undirected face+  -> (UndirectedEdgeId -> Bool)+  -> [FaceId]+facesAtEvenBarrierDepth triangulation isBarrier =+  concat (evenLayers (barrierDepthLayers triangulation isBarrier))+ where+  evenLayers :: [[FaceId]] -> [[FaceId]]+  evenLayers (outsideLayer : _insideLayer : deeper) =+    outsideLayer : evenLayers deeper+  evenLayers shallow = shallow++barrierDepthLayers+  :: Triangulation mode vertex directed undirected face+  -> (UndirectedEdgeId -> Bool)+  -> [[FaceId]]+barrierDepthLayers triangulation isBarrier =+  map (filter (/= outerFace)) (layers IntSet.empty [outerFace])+ where+  known face = faceIdIndex face < numFaces triangulation++  layers visited frontier = case flood visited [] frontier of+    ([], _) -> []+    (layer, visited') -> layer : layers visited' (concatMap (neighbours isBarrier) layer)++  flood visited acc [] = (reverse acc, visited)+  flood visited acc (face : rest)+    | not (known face) || IntSet.member (faceIdIndex face) visited = flood visited acc rest+    | otherwise =+        flood+          (IntSet.insert (faceIdIndex face) visited)+          (face : acc)+          (neighbours (not . isBarrier) face <> rest)++  neighbours admit face =+    [ incidentFace triangulation (reverseEdge edge)+    | edge <- faceDirectedEdges triangulation face+    , admit (asUndirected edge)+    ]++-- | Faces reachable from the outer face without crossing a barrier edge.+outerFaceFloodFill :: Triangulation mode vertex directed undirected face -> (UndirectedEdgeId -> Bool) -> [FaceId]+outerFaceFloodFill triangulation canCross = floodFillFaces triangulation starts canCross+ where+  starts =+    [ face+    | outerEdge <- faceDirectedEdges triangulation outerFace+    , let edge = asUndirected outerEdge+    , canCross edge+    , let face = incidentFace triangulation (reverseEdge outerEdge)+    , face /= outerFace+    ]++-- | The faces a shape's start point lands in.+shapeStartFaces :: DistanceMetric metric => Triangulation mode vertex directed undirected face -> metric -> [FaceId]+shapeStartFaces triangulation metric =+  case locatePoint triangulation (metricStartPoint metric) of+    InFace face -> [face]+    OnEdge edge -> filter (/= outerFace) [incidentFace triangulation edge, incidentFace triangulation (reverseEdge edge)]+    OnVertex vertex ->+      intSetToFaces+        ( List.foldl'+            (\set edge ->+              let face = incidentFace triangulation edge+               in if face == outerFace then set else IntSet.insert (faceIdIndex face) set+            )+            IntSet.empty+            (vertexOutgoingEdges triangulation vertex)+        )+    OutsideConvexHull _ ->+      [ incidentFace triangulation (reverseEdge edge)+      | edge <- faceDirectedEdges triangulation outerFace+      , let from = vertexPoint triangulation (origin triangulation edge)+      , let to = vertexPoint triangulation (destination triangulation edge)+      , metricIntersectsEdge metric from to+      , incidentFace triangulation (reverseEdge edge) /= outerFace+      ]+    EmptyTriangulation -> []+ where+  intSetToFaces = map (FaceId . fromIntegral) . IntSet.toAscList++segmentRectangleIntersection :: RectangleMetric -> Point -> Point -> Bool+segmentRectangleIntersection (RectangleMetric lowerQuery upperQuery _) from to+  | lx > ux || ly > uy = False+  | lower == upper = onClosedSegment from to lower+  | otherwise = any (uncurry (segmentsIntersect from to)) boundaries+ where+  lower@(Point lx ly) = queryPointValue lowerQuery+  upper@(Point ux uy) = queryPointValue upperQuery+  boundaries =+    [ (Point lx ly, Point lx uy)+    , (Point lx uy, Point ux uy)+    , (Point ux uy, Point ux ly)+    , (Point ux ly, Point lx ly)+    ]
+ src-dcel/Moonlight/Triangulation/Internal/HandleDefs.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | The identifier family and the arithmetic on it: a directed edge's twin is+-- its index complement, so orientation is a bit rather than a lookup.+module Moonlight.Triangulation.Internal.HandleDefs+  ( VertexId (..)+  , vertexIdIndex+  , FaceId (..)+  , faceIdIndex+  , DirectedEdgeId (..)+  , directedEdgeIdIndex+  , UndirectedEdgeId (..)+  , undirectedEdgeIdIndex+  , reverseEdge+  , asUndirected+  , normalizedDirected+  , reversedDirected+  , directedPair+  , isNormalized+  ) where++import Control.DeepSeq (NFData)+import Data.Bits (shiftL, shiftR, xor, (.&.))+import Data.Word (Word32)+import Moonlight.Triangulation.Internal.PackedIndex (unpackIndex)++-- | Index of a vertex in the immutable DCEL.+newtype VertexId = VertexId { unVertexId :: Word32 }+  deriving stock (Show)+  deriving newtype (Eq, Ord, NFData)++-- | Index of a face in the immutable DCEL; zero denotes the outer face.+newtype FaceId = FaceId { unFaceId :: Word32 }+  deriving stock (Show)+  deriving newtype (Eq, Ord, NFData)++-- | Oriented half-edge index. Twin orientations differ only in the low bit.+newtype DirectedEdgeId = DirectedEdgeId { unDirectedEdgeId :: Word32 }+  deriving stock (Show)+  deriving newtype (Eq, Ord, NFData)++-- | Index of a twin pair, with orientation forgotten.+newtype UndirectedEdgeId = UndirectedEdgeId { unUndirectedEdgeId :: Word32 }+  deriving stock (Show)+  deriving newtype (Eq, Ord, NFData)++-- | Project compact identifiers into resident vector indices.+vertexIdIndex :: VertexId -> Int+vertexIdIndex = unpackIndex . unVertexId+{-# INLINE vertexIdIndex #-}+faceIdIndex :: FaceId -> Int+faceIdIndex = unpackIndex . unFaceId+{-# INLINE faceIdIndex #-}+directedEdgeIdIndex :: DirectedEdgeId -> Int+directedEdgeIdIndex = unpackIndex . unDirectedEdgeId+{-# INLINE directedEdgeIdIndex #-}+undirectedEdgeIdIndex :: UndirectedEdgeId -> Int+undirectedEdgeIdIndex = unpackIndex . unUndirectedEdgeId+{-# INLINE undirectedEdgeIdIndex #-}++-- | Select the opposite orientation of the same undirected edge.+reverseEdge :: DirectedEdgeId -> DirectedEdgeId+reverseEdge (DirectedEdgeId edge) = DirectedEdgeId (edge `xor` 1)+{-# INLINE reverseEdge #-}++-- | Forget a directed edge's orientation.+asUndirected :: DirectedEdgeId -> UndirectedEdgeId+asUndirected (DirectedEdgeId edge) = UndirectedEdgeId (edge `shiftR` 1)+{-# INLINE asUndirected #-}++-- | Select the even-indexed orientation of an undirected edge.+normalizedDirected :: UndirectedEdgeId -> DirectedEdgeId+normalizedDirected (UndirectedEdgeId edge) = DirectedEdgeId (edge `shiftL` 1)+{-# INLINE normalizedDirected #-}++-- | Select the odd-indexed orientation of an undirected edge.+reversedDirected :: UndirectedEdgeId -> DirectedEdgeId+reversedDirected edge = reverseEdge (normalizedDirected edge)+{-# INLINE reversedDirected #-}++-- | Both orientations, normalized first and reversed second.+directedPair :: UndirectedEdgeId -> (DirectedEdgeId, DirectedEdgeId)+directedPair edge = (normalizedDirected edge, reversedDirected edge)+{-# INLINE directedPair #-}++-- | Whether a directed edge is the normalized orientation of its pair.+isNormalized :: DirectedEdgeId -> Bool+isNormalized (DirectedEdgeId edge) = edge .&. 1 == 0+{-# INLINE isNormalized #-}
+ src-dcel/Moonlight/Triangulation/Internal/Mutable.hs view
@@ -0,0 +1,1574 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++module Moonlight.Triangulation.Internal.Mutable+  ( MutableDcel (..)+  , DenseMutableDcel+  , MutableTopology (..)+  , denseMutableDcel+  , denseMutableOwner+  , DcelCapacity+  , generalDcelCapacity+  , planarDcelCapacity+  , exactDcelCapacity+  , newMutableDcel+  , DefaultedVertexDcel+  , newMutableDcelWithVertexDefault+  , defaultedVertexDcel+  , defaultedDenseVertexDcel+  , thawTriangulation+  , thawTriangulationDense+  , freezeTriangulation+  , freezeTriangulationWithStats+  , pointCapacity+  , halfEdgeCapacity+  , pointCount+  , connectedCount+  , directedEdgeCount+  , faceCount+  , pointAt+  , lookupPointVertex+  , activatePointIndex+  , activateBatchPointIndex+  , discardBatchPointIndex+  , identityIndexActive+  , readPointX+  , readPointY+  , writePoint+  , vertexDataAt+  , writeVertexData+  , payloadsPristine+  , resetEdgeData+  , resetFaceData+  , edgeOriginPoint+  , appendVertex+  , appendVertexCoordinates+  , appendDefaultVertexCoordinates+  , NextVertexSlot+  , nextVertexSlot+  , nextVertexSlotIndex+  , appendVertexCoordinatesAtSlot+  , ensurePointCapacity+  , markConnected+  , isConnected+  , addEdge+  , addEdgeBlock+  , addFace+  , addFaceBlock+  , denseAddEdgeBlock+  , denseAddFaceBlock+  , denseInitializeUnconstrainedEdgeBlock+  , ensureCellCapacity+  , truncatePoints+  , truncateDirectedEdges+  , truncateFaces+  , swapRemoveUndirectedEdge+  , swapRemoveFace+  , swapRemoveVertex+  , linkEdges+  , setCycle3+  , faceEdges+  , readOrigin+  , writeOrigin+  , readNext+  , writeNext+  , readPrevious+  , writePrevious+  , readFace+  , writeFace+  , readVertexOut+  , writeVertexOut+  , readFaceEdge+  , writeFaceEdge+  , readConstraint+  , denseReadPointX+  , denseReadPointY+  , denseWriteFreshDefaultPoint+  , denseCommitFreshDefaultPoints+  , denseReadOrigin+  , denseWriteOrigin+  , denseReadNext+  , denseWriteNext+  , denseReadPrevious+  , denseWritePrevious+  , denseReadFace+  , denseWriteFace+  , denseWriteVertexOut+  , denseMarkFreshConnected+  , denseCommitFreshConnections+  , denseReadFaceEdge+  , denseWriteFaceEdge+  , denseReadConstraint+  , denseLinkEdges+  , denseSetCycle3+  , denseFaceEdges+  , setConstraint+  , clearConstraint+  ) where++import Control.Monad (foldM, forM_, unless, when)+import Data.Bits (xor)+import Control.Monad.ST (ST)+import qualified Data.IntSet as IntSet+import Data.STRef+  ( STRef+  , modifySTRef'+  , newSTRef+  , readSTRef+  , writeSTRef+  )+import Data.Word (Word8, Word32)+import Moonlight.Triangulation.Internal.HandleDefs+  ( DirectedEdgeId (..)+  , FaceId (..)+  , UndirectedEdgeId (..)+  , VertexId (..)+  )+import Moonlight.Triangulation.Internal.BoxedPaged+import Moonlight.Triangulation.Internal.PackedIndex (noIndex, packIndex, unpackIndex)+import Moonlight.Triangulation.Internal.Paged+import Moonlight.Triangulation.Internal.PointIndex+  ( MutablePointIndex+  , MutablePointIndexUpdate (..)+  , PointIndex+  , buildPointIndex+  , emptyPointIndex+  , insertPointIndex+  , lookupMutablePoint+  , newMutablePointIndex+  , pointIndexCandidates+  , relocateMutablePoint+  , relocatePointIndex+  , removeMutablePoint+  , removePointIndex+  , seedMutablePointIndex+  )+import Moonlight.Triangulation.Math (canonicalPoint)+import Moonlight.Triangulation.Internal.Representation (Triangulation (..))+import Moonlight.Triangulation.Internal.Types (BuildError (..), ElementDefaults (..), Point (..))+-- | Dormant carries the inherited index through mutations as unforced pure+-- updates; persistent Active is the same index forced and kept strict because+-- a singleton lookup already proved someone is asking. Batch Active is the+-- existing open-addressed owner scoped to one dense identity program. Missing+-- means publication owes a lazy whole-mesh rebuild to any eventual asker.+data MutablePointIndexState s+  = DormantPointIndex PointIndex+  | ActivePersistentPointIndex !PointIndex+  | ActiveBatchPointIndex !(MutablePointIndex s)+  | MissingPointIndex++data MutableDcel s vertex directed undirected face = MutableDcel+  { mdPointX :: !(MutablePaged s Double)+  , mdPointY :: !(MutablePaged s Double)+  , mdPointIndex :: !(STRef s (MutablePointIndexState s))+  , mdVertexOut :: !(MutablePaged s Word32)+  , mdVertexData :: !(MutableBoxedPaged s vertex)+  , mdNewConnected :: !(MutablePaged s Word8)+  , mdRecycledNew :: !(STRef s IntSet.IntSet)+  , mdHalfTopology :: !(MutablePaged s Word32)+  , mdDirectedData :: !(MutableBoxedPaged s directed)+  , mdUndirectedData :: !(MutableBoxedPaged s undirected)+  , mdConstraint :: !(MutablePaged s Word8)+  , mdFaceEdge :: !(MutablePaged s Word32)+  , mdFaceData :: !(MutableBoxedPaged s face)+  , mdPointCount :: !(STRef s Int)+  , mdConnectedCount :: !(STRef s Int)+  , mdHalfCount :: !(STRef s Int)+  , mdFaceCount :: !(STRef s Int)+  , mdConstraintCount :: !(STRef s Int)+  , mdConstraintEdges :: !(STRef s IntSet.IntSet)+  , mdLastFace :: !(STRef s Int)+  , mdInitialPointCount :: {-# UNPACK #-} !Int+  , mdPointCapacity :: {-# UNPACK #-} !Int+  , mdHalfCapacity :: {-# UNPACK #-} !Int+  , mdFaceCapacity :: {-# UNPACK #-} !Int+  , -- | No element payload plane held a materialized page at thaw. Nothing+    -- inside a transaction can write one: the three planes are written only+    -- through the persistent setters, which run outside one, and both the+    -- rewrite reset and the swap-compaction relocation below are no-ops while+    -- this holds. So it is constant for the transaction's whole life, and a+    -- rewrite decides in a predictable branch that it has no label to move.+    mdPayloadsPristine :: !Bool+  , mdElementDefaults :: !(ElementDefaults directed undirected face)+  }++-- | 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.+--+-- The separated seam merge is the second lawful caller. It copies two planar+-- sources and then only adds: stitching creates seam cells, legalization+-- rewires without allocating, and nothing is abandoned. Its peak is therefore+-- its published result, a planar triangulation on the summed vertex count.+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 dense mutable DCEL whose vertex payload plane is uniformly filled.+-- The witness keeps the flat section tied to its canonical owner and permits+-- geometry-only ingress to extend the payload plane without materializing one+-- boxed value per site.+data DefaultedVertexDcel s vertex directed undirected face = DefaultedVertexDcel+  { defaultedVertexDcel :: !(MutableDcel s vertex directed undirected face)+  , defaultedDenseVertexDcel :: !(DenseMutableDcel s vertex directed undirected face)+  }++newMutableDcelWithVertexDefault+  :: vertex+  -> ElementDefaults directed undirected face+  -> DcelCapacity+  -> ST s (Either BuildError (DefaultedVertexDcel s vertex directed undirected face))+newMutableDcelWithVertexDefault vertexDefault defaults capacity = do+  mutable <-+    newMutableDcelFrom+      DenseTransaction+      (Just vertexDefault)+      defaults+      capacity+      Nothing+  pure $+    case denseMutableDcel mutable of+      Nothing -> Left CircleSweepRequiresDenseStorage+      Just dense -> Right (DefaultedVertexDcel mutable dense)++-- | Open a local-edit transaction: copy-on-write pages, publication+-- proportional to dirtied pages. The section for singleton persistent verbs.+thawTriangulation+  :: Int+  -> Triangulation mode vertex directed undirected face+  -> ST s (MutableDcel s vertex directed undirected face)+thawTriangulation maximumVertices triangulation =+  newMutableDcelFrom+    LocalTransaction+    Nothing+    (triElementDefaults triangulation)+    (generalDcelCapacity maximumVertices)+    (Just triangulation)++-- | Open a batch transaction: one dense copy up front, flat reads and writes+-- thereafter. The section for sessions and every other many-edit operation.+thawTriangulationDense+  :: Int+  -> Triangulation mode vertex directed undirected face+  -> ST s (MutableDcel s vertex directed undirected face)+thawTriangulationDense maximumVertices triangulation =+  newMutableDcelFrom+    DenseTransaction+    Nothing+    (triElementDefaults triangulation)+    (generalDcelCapacity maximumVertices)+    (Just triangulation)++newMutableDcelFrom+  :: TransactionShape+  -> Maybe vertex+  -> ElementDefaults directed undirected face+  -> DcelCapacity+  -> Maybe (Triangulation mode vertex directed undirected face)+  -> ST s (MutableDcel s vertex directed undirected face)+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+      !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+      constraintBaseCount = maybe 0 triConstraintCount source+      constraintBaseEdges = maybe IntSet.empty triConstraintEdges source+      pointIndexBase = maybe MissingPointIndex (DormantPointIndex . triPointIndex) source+  mdPointX <- maybe (newLocalMutablePaged vertexCapacity) (thawPagedShaped shape vertexCapacity . triPointX) source+  mdPointY <- maybe (newLocalMutablePaged vertexCapacity) (thawPagedShaped shape vertexCapacity . triPointY) source+  mdVertexOut <- maybe (newLocalMutablePaged vertexCapacity) (thawPagedShaped shape vertexCapacity . triVertexOut) source+  mdVertexData <- thawBoxedPaged shape vertexDataBase+  mdNewConnected <- newLocalMutablePaged (vertexCapacity - existingVertices)+  mdRecycledNew <- newSTRef IntSet.empty+  mdHalfTopology <- maybe (newMutablePaged (4 * halfCapacity)) (thawPagedShaped shape (4 * halfCapacity) . triHalfTopology) source+  mdDirectedData <- thawBoxedPaged shape directedDataBase+  mdUndirectedData <- thawBoxedPaged shape undirectedDataBase+  mdConstraint <- maybe (newMutablePaged (halfCapacity `quot` 2)) (thawPagedShaped shape (halfCapacity `quot` 2) . triConstraint) source+  mdFaceEdge <-+    case source of+      Just triangulation -> thawPagedShaped shape faceCapacity (triFaceEdge triangulation)+      Nothing -> do+        freshFaceEdges <- newLocalMutablePaged faceCapacity+        writePaged freshFaceEdges 0 noIndex+        pure freshFaceEdges+  mdFaceData <- thawBoxedPaged shape faceDataBase+  mdPointCount <- newSTRef existingVertices+  mdPointIndex <- newSTRef pointIndexBase+  mdConnectedCount <- newSTRef existingVertices+  mdHalfCount <- newSTRef existingHalfEdges+  mdFaceCount <- newSTRef existingFaces+  mdConstraintCount <- newSTRef constraintBaseCount+  mdConstraintEdges <- newSTRef constraintBaseEdges+  mdLastFace <- newSTRef (if existingFaces > 1 then 1 else 0)+  let !mdPayloadsPristine =+        boxedThawPristine mdDirectedData+          && boxedThawPristine mdUndirectedData+          && boxedThawPristine mdFaceData+  pure+    MutableDcel+      { mdInitialPointCount = existingVertices+      , mdPointCapacity = vertexCapacity+      , mdHalfCapacity = halfCapacity+      , mdFaceCapacity = faceCapacity+      , ..+      }++freezeTriangulation :: MutableDcel s vertex directed undirected face -> ST s (Either BuildError (Triangulation mode vertex directed undirected face))+freezeTriangulation mutable =+  fmap (fmap fst) (freezeTriangulationCore (const (pure emptyPublicationStats)) mutable)++freezeTriangulationWithStats+  :: MutableDcel s vertex directed undirected face+  -> ST s (Either BuildError (Triangulation mode vertex directed undirected face, PublicationStats))+freezeTriangulationWithStats = freezeTriangulationCore readMutableDcelPublicationStats++freezeTriangulationCore+  :: (MutableDcel s vertex directed undirected face -> ST s PublicationStats)+  -> MutableDcel s vertex directed undirected face+  -> ST s (Either BuildError (Triangulation mode vertex directed undirected face, PublicationStats))+freezeTriangulationCore readPublicationStats mutable@MutableDcel+  { mdPointX+  , mdPointY+  , mdPointIndex+  , mdVertexOut+  , mdVertexData+  , mdHalfTopology+  , mdDirectedData+  , mdUndirectedData+  , mdConstraint+  , mdFaceEdge+  , mdFaceData+  , mdPointCount+  , mdHalfCount+  , mdFaceCount+  , mdConstraintCount+  , mdConstraintEdges+  , mdElementDefaults+  } = do+    vertices <- readSTRef mdPointCount+    halfEdges <- readSTRef mdHalfCount+    faces <- readSTRef mdFaceCount+    triConstraintCount <- readSTRef mdConstraintCount+    triConstraintEdges <- readSTRef mdConstraintEdges+    vertexDataOutcome <- freezeBoxedPaged vertices mdVertexData+    directedDataOutcome <- freezeBoxedPaged halfEdges mdDirectedData+    undirectedDataOutcome <- freezeBoxedPaged (halfEdges `quot` 2) mdUndirectedData+    faceDataOutcome <- freezeBoxedPaged faces mdFaceData+    case+        (,,,)+          <$> vertexDataOutcome+          <*> directedDataOutcome+          <*> undirectedDataOutcome+          <*> faceDataOutcome+      of+        Left obstruction -> pure (Left (PayloadStorageFailure obstruction))+        Right (triVertexData, triDirectedData, triUndirectedData, triFaceData) -> do+          triPointX <- freezePaged vertices mdPointX+          triPointY <- freezePaged vertices mdPointY+          pointIndexState <- readSTRef mdPointIndex+          let triPointIndex =+                case pointIndexState of+                  DormantPointIndex residentIndex -> residentIndex+                  ActivePersistentPointIndex residentIndex -> residentIndex+                  ActiveBatchPointIndex _ -> buildPointIndex triPointX triPointY+                  MissingPointIndex -> buildPointIndex triPointX triPointY+          triVertexOut <- freezePaged vertices mdVertexOut+          triHalfTopology <- freezePaged (4 * halfEdges) mdHalfTopology+          triConstraint <- freezePaged (halfEdges `quot` 2) mdConstraint+          triFaceEdge <- freezePaged faces mdFaceEdge+          publicationStats <- readPublicationStats mutable+          let triElementDefaults = mdElementDefaults+          pure (Right (Triangulation{triSeamFrontier = Nothing, ..}, publicationStats))++readMutableDcelPublicationStats+  :: MutableDcel s vertex directed undirected face+  -> ST s PublicationStats+readMutableDcelPublicationStats MutableDcel+  { mdPointX+  , mdPointY+  , mdVertexOut+  , mdHalfTopology+  , mdConstraint+  , mdFaceEdge+  , mdVertexData+  , mdDirectedData+  , mdUndirectedData+  , mdFaceData+  } =+  foldl'+    addPublicationStats+    emptyPublicationStats+    <$> sequence+      [ readMutablePagedPublicationStats mdPointX+      , readMutablePagedPublicationStats mdPointY+      , readMutablePagedPublicationStats mdVertexOut+      , readMutablePagedPublicationStats mdHalfTopology+      , readMutablePagedPublicationStats mdConstraint+      , readMutablePagedPublicationStats mdFaceEdge+      , readMutableBoxedPublicationStats mdVertexData+      , readMutableBoxedPublicationStats mdDirectedData+      , readMutableBoxedPublicationStats mdUndirectedData+      , readMutableBoxedPublicationStats mdFaceData+      ]++pointCapacity :: MutableDcel s vertex directed undirected face -> Int+pointCapacity = mdPointCapacity+{-# INLINE pointCapacity #-}++halfEdgeCapacity :: MutableDcel s vertex directed undirected face -> Int+halfEdgeCapacity = mdHalfCapacity+{-# INLINE halfEdgeCapacity #-}++pointCount :: MutableDcel s vertex directed undirected face -> ST s Int+pointCount = readSTRef . mdPointCount+{-# INLINE pointCount #-}++connectedCount :: MutableDcel s vertex directed undirected face -> ST s Int+connectedCount = readSTRef . mdConnectedCount+{-# INLINE connectedCount #-}++directedEdgeCount :: MutableDcel s vertex directed undirected face -> ST s Int+directedEdgeCount = readSTRef . mdHalfCount+{-# INLINE directedEdgeCount #-}++faceCount :: MutableDcel s vertex directed undirected face -> ST s Int+faceCount = readSTRef . mdFaceCount+{-# INLINE faceCount #-}++pointAt :: MutableDcel s vertex directed undirected face -> Int -> ST s (Point)+pointAt MutableDcel{mdPointX, mdPointY} index =+  Point <$> readPaged mdPointX index <*> readPaged mdPointY index+{-# INLINE pointAt #-}++-- | Resolve a canonical site through the derived handle index, confirming+-- every hash candidate against the authoritative coordinate planes. A mesh+-- created from scratch derives the index only if a caller actually asks; a+-- thawed published mesh inherits its structurally shared index.+lookupPointVertex+  :: MutableDcel s vertex directed undirected face+  -> Point+  -> ST s (Maybe Int)+lookupPointVertex mutable@MutableDcel{mdPointIndex} rawPoint = do+  indexState <- readSTRef mdPointIndex+  case canonicalPoint rawPoint of+    Point x y ->+      case indexState of+        ActiveBatchPointIndex table ->+          lookupMutablePoint table (readPointX mutable) (readPointY mutable) x y+        ActivePersistentPointIndex residentIndex ->+          resolvePersistent x y residentIndex+        DormantPointIndex residentIndex -> do+          writeSTRef mdPointIndex (ActivePersistentPointIndex residentIndex)+          resolvePersistent x y residentIndex+        MissingPointIndex -> do+          derived <- deriveMutablePointIndex mutable+          writeSTRef mdPointIndex (ActivePersistentPointIndex derived)+          resolvePersistent x y derived+ where+  resolvePersistent x y pointIndex =+    foldM+      (confirmCandidate mutable x y)+      Nothing+      (pointIndexCandidates x y pointIndex)++-- | Whether the transaction has already committed to incremental identity+-- transport. Answering does not force a dormant index's lazy rebuild, which+-- is the point: a per-question caller must not buy a whole-mesh build.+identityIndexActive :: MutableDcel s vertex directed undirected face -> ST s Bool+identityIndexActive MutableDcel{mdPointIndex} = do+  indexState <- readSTRef mdPointIndex+  pure $ case indexState of+    ActivePersistentPointIndex _ -> True+    ActiveBatchPointIndex _ -> True+    _ -> False+{-# INLINE identityIndexActive #-}++-- | Declare that a singleton handle-keyed rewrite must transport the resident+-- immutable identity section strictly. Dense point-keyed removal uses+-- 'activateBatchPointIndex' instead, so it neither forces nor incrementally+-- allocates the published 'PointIndex'.+activatePointIndex+  :: MutableDcel s vertex directed undirected face+  -> ST s ()+activatePointIndex mutable@MutableDcel{mdPointIndex} = do+  indexState <- readSTRef mdPointIndex+  case indexState of+    ActivePersistentPointIndex _ -> pure ()+    ActiveBatchPointIndex _ -> pure ()+    DormantPointIndex residentIndex ->+      writeSTRef mdPointIndex (ActivePersistentPointIndex residentIndex)+    MissingPointIndex -> do+      derived <- deriveMutablePointIndex mutable+      writeSTRef mdPointIndex (ActivePersistentPointIndex derived)++-- | Open an identity section for one dense removal program. The table derives+-- only from coordinate authority, and its extent is deliberately narrower+-- than the surrounding session: publication returns to the lazy immutable+-- derivation instead of retaining a second mutable identity owner.+activateBatchPointIndex+  :: MutableDcel s vertex directed undirected face+  -> ST s (Either BuildError ())+activateBatchPointIndex mutable@MutableDcel{mdPointIndex} = do+  vertices <- pointCount mutable+  table <- newMutablePointIndex vertices+  seeded <-+    seedMutablePointIndex+      table+      vertices+      (readPointX mutable)+      (readPointY mutable)+  case seeded of+    Left failure -> pure (Left failure)+    Right () -> do+      writeSTRef mdPointIndex (ActiveBatchPointIndex table)+      pure (Right ())+-- | Close the batch-local identity section after its removal program. Its+-- contents cannot escape @ST@; marking the cache missing makes freeze glue a+-- lazy immutable derivation from the final coordinate arenas.+discardBatchPointIndex+  :: MutableDcel s vertex directed undirected face+  -> ST s ()+discardBatchPointIndex MutableDcel{mdPointIndex} =+  modifySTRef'+    mdPointIndex+    (\indexState ->+       case indexState of+         ActiveBatchPointIndex _ -> MissingPointIndex+         retained -> retained+    )++deriveMutablePointIndex+  :: MutableDcel s vertex directed undirected face+  -> ST s PointIndex+deriveMutablePointIndex mutable = do+  vertices <- pointCount mutable+  foldM insertResident emptyPointIndex [0 .. vertices - 1]+ where+  insertResident pointIndex vertex = do+    x <- readPointX mutable vertex+    y <- readPointY mutable vertex+    pure (insertPointIndex x y vertex pointIndex)++confirmCandidate+  :: MutableDcel s vertex directed undirected face+  -> Double+  -> Double+  -> Maybe Int+  -> Int+  -> ST s (Maybe Int)+confirmCandidate _ _ _ resident@(Just _) _ = pure resident+confirmCandidate mutable x y Nothing candidate = do+  heldX <- readPointX mutable candidate+  heldY <- readPointY mutable candidate+  pure (if heldX == x && heldY == y then Just candidate else Nothing)+{-# INLINE confirmCandidate #-}++-- | Read one stored coordinate without building a t'Point'. Coordinates are+-- the authoritative state owned by 'mdPointX'/'mdPointY'; the t'Point'+-- constructor is the cold accessor's packaging, and the construction kernel+-- reads these arenas directly so a specialized sweep never boxes one.+readPointX :: MutableDcel s vertex directed undirected face -> Int -> ST s Double+readPointX MutableDcel{mdPointX} index = readPaged mdPointX index+{-# INLINE readPointX #-}++readPointY :: MutableDcel s vertex directed undirected face -> Int -> ST s Double+readPointY MutableDcel{mdPointY} index = readPaged mdPointY index+{-# INLINE readPointY #-}++writePoint :: MutableDcel s vertex directed undirected face -> Int -> Point -> ST s ()+writePoint MutableDcel{mdPointX, mdPointY} index rawPoint =+  case canonicalPoint rawPoint of+    Point x y -> do+      writePaged mdPointX index x+      writePaged mdPointY index y+{-# INLINE writePoint #-}++vertexDataAt :: MutableDcel s vertex directed undirected face -> Int -> ST s vertex+vertexDataAt MutableDcel{mdVertexData} = readBoxedPaged mdVertexData+{-# INLINE vertexDataAt #-}++writeVertexData :: MutableDcel s vertex directed undirected face -> Int -> vertex -> ST s ()+writeVertexData MutableDcel{mdVertexData} = writeBoxedPaged mdVertexData+{-# INLINE writeVertexData #-}++-- | Whether no element payload plane can be holding anything. Constant for the+-- transaction: see 'mdPayloadsPristine'. A rewrite site that performs several+-- resets together tests this once rather than paying the test inside each.+payloadsPristine :: MutableDcel s vertex directed undirected face -> Bool+payloadsPristine = mdPayloadsPristine+{-# INLINE payloadsPristine #-}++-- | Return one undirected edge and both its half-edges to the element+-- defaults. A payload labels the element occupying a slot, and an element is+-- its geometry: a rewrite that gives a slot new endpoints has put a different+-- edge there, and the label the old one carried does not describe it. Leaving+-- it would also make the payload plane depend on the flip order that reached+-- the normal form, while the topology does not.+--+-- The constraint flag is deliberately not reset with it. A flag states that a+-- segment of the input is present, and a segment that gets split is still+-- present as its two halves; a payload states what an element is.+resetEdgeData :: MutableDcel s vertex directed undirected face -> Int -> ST s ()+resetEdgeData MutableDcel{mdDirectedData, mdUndirectedData, mdPayloadsPristine, mdElementDefaults} pair =+  unless mdPayloadsPristine $ do+    resetBoxedRange mdDirectedData (defaultDirectedEdgeData mdElementDefaults) (2 * pair) 2+    resetBoxedRange mdUndirectedData (defaultUndirectedEdgeData mdElementDefaults) pair 1+{-# INLINE resetEdgeData #-}++-- | Return one face to the element default. See 'resetEdgeData'.+resetFaceData :: MutableDcel s vertex directed undirected face -> Int -> ST s ()+resetFaceData MutableDcel{mdFaceData, mdPayloadsPristine, mdElementDefaults} face =+  unless mdPayloadsPristine (resetBoxedRange mdFaceData (defaultFaceData mdElementDefaults) face 1)+{-# INLINE resetFaceData #-}++edgeOriginPoint :: MutableDcel s vertex directed undirected face -> Int -> ST s (Point)+edgeOriginPoint mutable edge = readOrigin mutable edge >>= pointAt mutable+{-# INLINE edgeOriginPoint #-}++appendVertex+  :: MutableDcel s vertex directed undirected face+  -> Point+  -> vertex+  -> ST s Int+appendVertex mutable rawPoint vertexData =+  case canonicalPoint rawPoint of+    Point x y -> appendVertexCoordinates mutable x y vertexData+{-# INLINE appendVertex #-}++-- | 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+-- appender initializes every field of the record it exposes.+appendVertexCoordinates+  :: MutableDcel s vertex directed undirected face+  -> Double+  -> Double+  -> vertex+  -> ST s Int+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{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+  writeVertexOut mutable vertex (-1)+  if vertex >= mdInitialPointCount mutable+    then writePaged mdNewConnected (vertex - mdInitialPointCount mutable) 0+    else modifySTRef' mdRecycledNew (IntSet.insert vertex)+  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.+ensurePointCapacity+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> ST s (Either BuildError ())+ensurePointCapacity MutableDcel{mdPointCount, mdPointCapacity} additional+  | additional < 0 = pure (Left (CapacityExceeded additional))+  | otherwise = do+      current <- readSTRef mdPointCount+      let !required = current + additional+      pure $+        if required > mdPointCapacity+          then Left (CapacityExceeded required)+          else Right ()+{-# INLINE ensurePointCapacity #-}++markConnected :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+markConnected mutable@MutableDcel{mdInitialPointCount, mdNewConnected, mdRecycledNew, mdConnectedCount} vertex outgoing = do+  if vertex >= mdInitialPointCount+    then do+      let !newVertex = vertex - mdInitialPointCount+      connected <- readPaged mdNewConnected newVertex+      unless (connected /= 0) $ do+        writePaged mdNewConnected newVertex 1+        modifySTRef' mdConnectedCount (+ 1)+    else do+      recycled <- readSTRef mdRecycledNew+      when (IntSet.member vertex recycled) $ do+        writeSTRef mdRecycledNew (IntSet.delete vertex recycled)+        modifySTRef' mdConnectedCount (+ 1)+  writeVertexOut mutable vertex outgoing+{-# INLINE markConnected #-}++isConnected :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool+isConnected MutableDcel{mdInitialPointCount, mdNewConnected, mdRecycledNew} vertex+  | vertex < mdInitialPointCount = IntSet.notMember vertex <$> readSTRef mdRecycledNew+  | otherwise = (/= 0) <$> readPaged mdNewConnected (vertex - mdInitialPointCount)+{-# INLINE isConnected #-}++addEdge :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s (Int, Int)+addEdge mutable from to = do+  base <- addEdgeBlock mutable 1+  writeOrigin mutable base from+  writeOrigin mutable (base + 1) to+  pure (base, base + 1)+{-# INLINE addEdge #-}++-- Each appended pair owns the initialization of its exposed topology and+-- constraint records; reserved capacity remains untouched.+addEdgeBlock :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+addEdgeBlock mutable@MutableDcel{mdHalfCount, mdConstraint} pairs = do+  base <- readSTRef mdHalfCount+  let !required = base + 2 * pairs+      !firstUndirected = base `quot` 2+      !lastUndirected = firstUndirected + pairs - 1+  forM_ [4 * base .. 4 * required - 1] $ \slot ->+    writePaged (mdHalfTopology mutable) slot noIndex+  forM_ [firstUndirected .. lastUndirected] $ \edge -> writePaged mdConstraint edge 0+  writeSTRef mdHalfCount required+  pure base+{-# INLINE addEdgeBlock #-}++-- | 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+  writeFaceEdge mutable base anchor+  pure base+{-# INLINE addFace #-}++addFaceBlock :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+addFaceBlock mutable@MutableDcel{mdFaceCount} count = do+  base <- readSTRef mdFaceCount+  let !required = base + count+  mapM_ (\face -> writeFaceEdge mutable face (-1)) [base .. required - 1]+  writeSTRef mdFaceCount required+  pure base+{-# INLINE addFaceBlock #-}++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.+ensureCellCapacity+  :: MutableDcel s vertex directed undirected face+  -> Int+  -> Int+  -> ST s (Either BuildError ())+ensureCellCapacity MutableDcel{mdHalfCount, mdHalfCapacity, mdFaceCount, mdFaceCapacity} additionalPairs additionalFaces+  | additionalPairs < 0 = pure (Left (HalfEdgeCapacityExceeded additionalPairs mdHalfCapacity))+  | additionalFaces < 0 = pure (Left (FaceCapacityExceeded additionalFaces mdFaceCapacity))+  | otherwise = do+      currentHalfEdges <- readSTRef mdHalfCount+      currentFaces <- readSTRef mdFaceCount+      let !requiredHalfEdges = currentHalfEdges + 2 * additionalPairs+          !requiredFaces = currentFaces + additionalFaces+      if requiredHalfEdges > mdHalfCapacity+        then pure (Left (HalfEdgeCapacityExceeded requiredHalfEdges mdHalfCapacity))+        else+          if requiredFaces > mdFaceCapacity+            then pure (Left (FaceCapacityExceeded requiredFaces mdFaceCapacity))+            else pure (Right ())+{-# INLINE ensureCellCapacity #-}++truncatePoints :: MutableDcel s vertex directed undirected face -> Int -> ST s ()+truncatePoints MutableDcel{mdPointCount, mdConnectedCount} count = do+  writeSTRef mdPointCount count+  connected <- readSTRef mdConnectedCount+  when (connected > count) (writeSTRef mdConnectedCount count)++truncateDirectedEdges :: MutableDcel s vertex directed undirected face -> Int -> ST s ()+truncateDirectedEdges MutableDcel{mdHalfCount} = writeSTRef mdHalfCount++truncateFaces :: MutableDcel s vertex directed undirected face -> Int -> ST s ()+truncateFaces MutableDcel{mdFaceCount, mdLastFace} count = do+  writeSTRef mdFaceCount count+  lastFace <- readSTRef mdLastFace+  when (lastFace >= count) (writeSTRef mdLastFace (if count > 1 then 1 else 0))++-- | Remove one undirected edge by moving the last pair into its slot. Only the+-- two neighboring links, one vertex representative, and one face+-- representative per moved half-edge can reference the old handles.+--+-- The slot the tail vacates is returned to the defaults here rather than when+-- the allocator hands it back out. That keeps one invariant — every slot at or+-- above the live count holds the fill — which the thaw establishes, this+-- preserves, and 'addEdgeBlock' may therefore assume without testing anything.+-- The cost lands on removal, which is where the element was retired, instead of+-- on every allocation a pure insertion makes.+swapRemoveUndirectedEdge :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError ())+swapRemoveUndirectedEdge mutable@MutableDcel{mdConstraint, mdConstraintCount, mdConstraintEdges} pair = do+  halfEdges <- directedEdgeCount mutable+  let !pairs = halfEdges `quot` 2+      !lastPair = pairs - 1+  if pair < 0 || pair > lastPair+    then+      pure+        ( Left+            ( RemovalEdgeOutOfRange+                (UndirectedEdgeId (fromIntegral pair))+                pairs+            )+        )+    else do+      swapRemoveUndirectedEdgeInRange lastPair+      pure (Right ())+ where+  swapRemoveUndirectedEdgeInRange lastPair = do+    removedFlag <- readPaged mdConstraint pair+    lastFlag <- readPaged mdConstraint lastPair+    when (removedFlag /= 0) (modifySTRef' mdConstraintCount (subtract 1))+    when (pair /= lastPair) $ do+      let !oldBase = 2 * lastPair+          !newBase = 2 * pair+          remap !handle+            | handle == oldBase = newBase+            | handle == oldBase + 1 = newBase + 1+            | otherwise = handle+      -- Both records are taken before either is republished: the pair's two+      -- half-edges can name each other, so a read after the first write would+      -- see the new handle where the old one belongs.+      !forwardOrigin <- readOrigin mutable oldBase+      !forwardNext <- remap <$> readNext mutable oldBase+      !forwardPrevious <- remap <$> readPrevious mutable oldBase+      !forwardFace <- readFace mutable oldBase+      !backwardOrigin <- readOrigin mutable (oldBase + 1)+      !backwardNext <- remap <$> readNext mutable (oldBase + 1)+      !backwardPrevious <- remap <$> readPrevious mutable (oldBase + 1)+      !backwardFace <- readFace mutable (oldBase + 1)+      writePaged mdConstraint pair lastFlag+      unless (mdPayloadsPristine mutable) $ do+        readBoxedPaged (mdUndirectedData mutable) lastPair >>= writeBoxedPaged (mdUndirectedData mutable) pair+        readBoxedPaged (mdDirectedData mutable) oldBase >>= writeBoxedPaged (mdDirectedData mutable) newBase+        readBoxedPaged (mdDirectedData mutable) (oldBase + 1) >>= writeBoxedPaged (mdDirectedData mutable) (newBase + 1)+      writeOrigin mutable newBase forwardOrigin+      writeNext mutable newBase forwardNext+      writePrevious mutable newBase forwardPrevious+      writeFace mutable newBase forwardFace+      writeOrigin mutable (newBase + 1) backwardOrigin+      writeNext mutable (newBase + 1) backwardNext+      writePrevious mutable (newBase + 1) backwardPrevious+      writeFace mutable (newBase + 1) backwardFace+      writeNext mutable forwardPrevious newBase+      writePrevious mutable forwardNext newBase+      writeVertexOut mutable forwardOrigin newBase+      writeFaceEdge mutable forwardFace newBase+      writeNext mutable backwardPrevious (newBase + 1)+      writePrevious mutable backwardNext (newBase + 1)+      writeVertexOut mutable backwardOrigin (newBase + 1)+      writeFaceEdge mutable backwardFace (newBase + 1)+    modifySTRef'+      mdConstraintEdges+      (\edges ->+         let withoutRetired = IntSet.delete pair (IntSet.delete lastPair edges)+          in if pair /= lastPair && lastFlag /= 0+               then IntSet.insert pair withoutRetired+               else withoutRetired+      )+    resetEdgeData mutable lastPair+    truncateDirectedEdges mutable (2 * lastPair)++swapRemoveFace :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError ())+swapRemoveFace mutable face = do+  faces <- faceCount mutable+  let !lastFace = faces - 1+  if face <= 0 || face > lastFace+    then+      pure+        ( Left+            (RemovalFaceOutOfRange (FaceId (fromIntegral face)) faces)+        )+    else do+      relocated <-+        if face == lastFace+          then pure (Right ())+          else relocateLastFace lastFace+      case relocated of+        Left obstruction -> pure (Left obstruction)+        Right () -> do+          resetFaceData mutable lastFace+          truncateFaces mutable lastFace+          pure (Right ())+ where+  relocateLastFace lastFace = do+    start <- readFaceEdge mutable lastFace+    writeFaceEdge mutable face start+    -- Swap-compaction moves the last face's index, not the face. When the+    -- locator's cached start is that face, following it here is the difference+    -- between a batch of removals resuming where the previous one settled and+    -- 'truncateFaces' finding the cached index out of range and resetting it to+    -- the first inner face. The cache is a start, never an answer.+    cachedFace <- readSTRef (mdLastFace mutable)+    when (cachedFace == lastFace) (writeSTRef (mdLastFace mutable) face)+    unless (mdPayloadsPristine mutable) $+      readBoxedPaged (mdFaceData mutable) lastFace >>= writeBoxedPaged (mdFaceData mutable) face+    halfEdges <- directedEdgeCount mutable+    let go !remaining !current !seen+          | remaining <= 0 =+              pure+                ( Left+                    ( RemovalFaceCycleDidNotTerminate+                        (FaceId (fromIntegral lastFace))+                        (DirectedEdgeId (fromIntegral current))+                        (halfEdges + 1)+                    )+                )+          | seen && current == start = pure (Right ())+          | otherwise = do+              writeFace mutable current face+              nextEdge <- readNext mutable current+              go (remaining - 1) nextEdge True+    go (halfEdges + 1) start False++-- | Retire a vertex by moving the arena's last into its slot. The relocation is+-- reported as the slot together with the position now standing in it: the two+-- are one fact, and a caller told only the slot has to consult the mesh to+-- learn what landed there.+swapRemoveVertex :: MutableDcel s vertex directed undirected face -> Int -> ST s (Either BuildError (Point, vertex, Maybe (Int, Point)))+swapRemoveVertex mutable@MutableDcel{mdConnectedCount, mdPointIndex, mdRecycledNew, mdNewConnected} vertex = do+  vertices <- pointCount mutable+  let !lastVertex = vertices - 1+  if vertex < 0 || vertex > lastVertex+    then+      pure+        ( Left+            (RemovalVertexOutOfRange (VertexId (fromIntegral vertex)) vertices)+        )+    else swapRemoveVertexInRange lastVertex+ where+  swapRemoveVertexInRange lastVertex = do+    removedPoint <- pointAt mutable vertex+    removedPayload <- vertexDataAt mutable vertex+    movedOutcome <-+      if vertex == lastVertex+        then pure (Right Nothing)+        else moveTailVertex lastVertex+    case movedOutcome of+      Left obstruction -> pure (Left obstruction)+      Right moved -> do+        indexState <- readSTRef mdPointIndex+        updatedIndexState <-+          updatePointIndexAfterSwap mutable indexState removedPoint vertex lastVertex moved+        writeSTRef mdPointIndex updatedIndexState+        -- The connectivity companions must agree with the aggregate assertion two+        -- lines down: after a swap removal every surviving vertex is connected. The+        -- retired slot's entry and the relocated occupant's old entry are both+        -- stale, and a relocated occupant landing in the appended region must read+        -- connected through the offset store, not through its predecessor's bit.+        modifySTRef' mdRecycledNew (IntSet.delete vertex . IntSet.delete lastVertex)+        case moved of+          Just _+            | vertex >= mdInitialPointCount mutable ->+                writePaged mdNewConnected (vertex - mdInitialPointCount mutable) 1+          _ -> pure ()+        truncatePoints mutable lastVertex+        writeSTRef mdConnectedCount lastVertex+        pure (Right (removedPoint, removedPayload, moved))++  moveTailVertex lastVertex = do+    movedPoint <- pointAt mutable lastVertex+    movedPayload <- vertexDataAt mutable lastVertex+    movedOut <- readVertexOut mutable lastVertex+    writePoint mutable vertex movedPoint+    writeVertexData mutable vertex movedPayload+    writeVertexOut mutable vertex movedOut+    relocated <-+      if movedOut < 0+        then pure (Right ())+        else relocateOutgoingCycle lastVertex movedOut+    pure (Just (vertex, movedPoint) <$ relocated)++  relocateOutgoingCycle lastVertex movedOut = do+    halfEdges <- directedEdgeCount mutable+    let go !remaining !current !seen+          | remaining <= 0 =+              pure+                ( Left+                    ( RemovalOutgoingCycleDidNotTerminate+                        (VertexId (fromIntegral lastVertex))+                        (DirectedEdgeId (fromIntegral current))+                        (halfEdges + 1)+                    )+                )+          | seen && current == movedOut = pure (Right ())+          | otherwise = do+              writeOrigin mutable current vertex+              previousEdge <- readPrevious mutable current+              go (remaining - 1) (previousEdge `xor` 1) True+    go (halfEdges + 1) movedOut False++-- | Transport the identity view across one vertex swap. Persistent sections+-- retain their existing pure update law. A batch table mutates in place, then+-- deliberately falls back to @MissingPointIndex@ if either local proof cannot+-- be completed; geometry remains authoritative and subsequent operations walk+-- rather than observe a stale cache.+updatePointIndexAfterSwap+  :: MutableDcel s vertex directed undirected face+  -> MutablePointIndexState s+  -> Point+  -> Int+  -> Int+  -> Maybe (Int, Point)+  -> ST s (MutablePointIndexState s)+updatePointIndexAfterSwap mutable indexState removedPoint vertex lastVertex moved =+  case indexState of+    DormantPointIndex pointIndex ->+      pure (DormantPointIndex (updatePersistentPointIndex pointIndex))+    ActivePersistentPointIndex pointIndex ->+      pure (ActivePersistentPointIndex (updatePersistentPointIndex pointIndex))+    ActiveBatchPointIndex table ->+      transportBatchPointIndex table+    MissingPointIndex -> pure MissingPointIndex+ where+  updatePersistentPointIndex pointIndex =+    case removedPoint of+      Point removedX removedY ->+        let withoutRemoved = removePointIndex removedX removedY vertex pointIndex+         in case moved of+              Nothing -> withoutRemoved+              Just (_, Point movedX movedY) ->+                relocatePointIndex movedX movedY lastVertex vertex withoutRemoved++  transportBatchPointIndex table =+    case removedPoint of+      Point removedX removedY -> do+        removed <-+          removeMutablePoint+            table+            (readPointX mutable)+            (readPointY mutable)+            removedX+            removedY+            vertex+        case (removed, moved) of+          (MutablePointIndexUpdated, Nothing) ->+            pure (ActiveBatchPointIndex table)+          (MutablePointIndexUpdated, Just (_, Point movedX movedY)) -> do+            relocated <- relocateMutablePoint table movedX movedY lastVertex vertex+            pure $+              case relocated of+                MutablePointIndexUpdated -> ActiveBatchPointIndex table+                MutablePointIndexInvalidated -> MissingPointIndex+          (MutablePointIndexInvalidated, _) -> pure MissingPointIndex++  -- 'swapRemoveVertex' calls us before truncation. The tail's coordinate cells+  -- still carry the moved point, so backward-shift repair can derive every+  -- occupant home from the same canonical storage that the table indexes.+linkEdges :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+linkEdges mutable left right = do+  writeNext mutable left right+  writePrevious mutable right left+{-# INLINE linkEdges #-}++setCycle3 :: MutableDcel s vertex directed undirected face -> Int -> Int -> Int -> Int -> ST s ()+setCycle3 mutable face e0 e1 e2 = do+  writeNext mutable e0 e1+  writeNext mutable e1 e2+  writeNext mutable e2 e0+  writePrevious mutable e0 e2+  writePrevious mutable e1 e0+  writePrevious mutable e2 e1+  writeFace mutable e0 face+  writeFace mutable e1 face+  writeFace mutable e2 face+  writeFaceEdge mutable face e0+{-# INLINE setCycle3 #-}++faceEdges :: MutableDcel s vertex directed undirected face -> Int -> ST s (Int, Int, Int)+faceEdges mutable face = do+  e0 <- readFaceEdge mutable face+  e1 <- readNext mutable e0+  e2 <- readNext mutable e1+  pure (e0, e1, e2)+{-# INLINE faceEdges #-}++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 #-}++-- | Materialize one coordinate slot in a fresh dense point section. The+-- caller owns the capacity witness and supplies the final cardinality once;+-- the point index remains the fresh owner's missing derived view until+-- publication rebuilds it from these authoritative coordinate planes.+denseWriteFreshDefaultPoint+  :: DefaultedVertexDcel s vertex directed undirected face+  -> Int+  -> Double+  -> Double+  -> ST s ()+denseWriteFreshDefaultPoint+  DefaultedVertexDcel+    { defaultedDenseVertexDcel =+        dense@DenseMutableDcel+          { dmdOwner = MutableDcel{mdInitialPointCount}+          , dmdPointX+          , dmdPointY+          , dmdNewConnected+          }+    }+  vertex+  x+  y = do+  writeFlatMutable dmdPointX vertex x+  writeFlatMutable dmdPointY vertex y+  denseWriteVertexOut dense vertex (-1)+  writeFlatMutable dmdNewConnected (vertex - mdInitialPointCount) 0+{-# INLINE denseWriteFreshDefaultPoint #-}++-- | Glue a completed fresh point section into the mutable owner's logical+-- extent. Per-site writes remain local; the aggregate cardinality descends+-- once after the section is complete.+denseCommitFreshDefaultPoints+  :: DefaultedVertexDcel s vertex directed undirected face+  -> Int+  -> ST s ()+denseCommitFreshDefaultPoints+  DefaultedVertexDcel+    { defaultedDenseVertexDcel = DenseMutableDcel+      { dmdOwner = MutableDcel{mdPointCount}+      }+    }+  = writeSTRef mdPointCount+{-# INLINE denseCommitFreshDefaultPoints #-}++denseReadOrigin :: DenseMutableDcel s vertex directed undirected face -> Int -> ST s Int+denseReadOrigin DenseMutableDcel{dmdHalfTopology} index = unpackIndex <$> readFlatMutable dmdHalfTopology (4 * index)+denseReadNext :: DenseMutableDcel s vertex directed undirected face -> Int -> ST s Int+denseReadNext DenseMutableDcel{dmdHalfTopology} index = unpackIndex <$> readFlatMutable dmdHalfTopology (4 * index + 1)+denseReadPrevious :: DenseMutableDcel s vertex directed undirected face -> Int -> ST s Int+denseReadPrevious DenseMutableDcel{dmdHalfTopology} index = unpackIndex <$> readFlatMutable dmdHalfTopology (4 * index + 2)+denseReadFace :: DenseMutableDcel s vertex directed undirected face -> Int -> ST s Int+denseReadFace DenseMutableDcel{dmdHalfTopology} index = unpackIndex <$> 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 unpackIndex 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 = unpackIndex <$> readPaged mdHalfTopology (4 * index)+readNext :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+readNext MutableDcel{mdHalfTopology} index = unpackIndex <$> readPaged mdHalfTopology (4 * index + 1)+readPrevious :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+readPrevious MutableDcel{mdHalfTopology} index = unpackIndex <$> readPaged mdHalfTopology (4 * index + 2)+readFace :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+readFace MutableDcel{mdHalfTopology} index = unpackIndex <$> readPaged mdHalfTopology (4 * index + 3)+{-# INLINE readOrigin #-}+{-# INLINE readNext #-}+{-# INLINE readPrevious #-}+{-# INLINE readFace #-}++writeOrigin :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+writeOrigin MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index) (packIndex value)+writeNext :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+writeNext MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index + 1) (packIndex value)+writePrevious :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+writePrevious MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index + 2) (packIndex value)+writeFace :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+writeFace MutableDcel{mdHalfTopology} index value = writePaged mdHalfTopology (4 * index + 3) (packIndex value)+{-# INLINE writeOrigin #-}+{-# INLINE writeNext #-}+{-# INLINE writePrevious #-}+{-# INLINE writeFace #-}++readVertexOut :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+readVertexOut MutableDcel{mdVertexOut} index = do+  value <- readPaged mdVertexOut index+  pure (if value == noIndex then -1 else unpackIndex value)+{-# INLINE readVertexOut #-}++writeVertexOut :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+writeVertexOut MutableDcel{mdVertexOut} index value =+  writePaged mdVertexOut index (if value < 0 then noIndex else packIndex value)+{-# INLINE writeVertexOut #-}++readFaceEdge :: MutableDcel s vertex directed undirected face -> Int -> ST s Int+readFaceEdge MutableDcel{mdFaceEdge} index = do+  value <- readPaged mdFaceEdge index+  pure (if value == noIndex then -1 else unpackIndex value)+{-# INLINE readFaceEdge #-}++writeFaceEdge :: MutableDcel s vertex directed undirected face -> Int -> Int -> ST s ()+writeFaceEdge MutableDcel{mdFaceEdge} index value =+  writePaged mdFaceEdge index (if value < 0 then noIndex else packIndex value)+{-# INLINE writeFaceEdge #-}++readConstraint :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool+readConstraint MutableDcel{mdConstraint} directed = (/= 0) <$> readPaged mdConstraint (directed `quot` 2)+{-# INLINE readConstraint #-}++setConstraint :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool+setConstraint MutableDcel{mdConstraint, mdConstraintCount, mdConstraintEdges} directed = do+  let !index = directed `quot` 2+  current <- readPaged mdConstraint index+  if current /= 0+    then pure False+    else do+      writePaged mdConstraint index 1+      modifySTRef' mdConstraintCount (+ 1)+      modifySTRef' mdConstraintEdges (IntSet.insert index)+      pure True+{-# INLINE setConstraint #-}++clearConstraint :: MutableDcel s vertex directed undirected face -> Int -> ST s Bool+clearConstraint MutableDcel{mdConstraint, mdConstraintCount, mdConstraintEdges} directed = do+  let !index = directed `quot` 2+  current <- readPaged mdConstraint index+  if current == 0+    then pure False+    else do+      writePaged mdConstraint index 0+      modifySTRef' mdConstraintCount (subtract 1)+      modifySTRef' mdConstraintEdges (IntSet.delete index)+      pure True+{-# INLINE clearConstraint #-}
+ src-dcel/Moonlight/Triangulation/Internal/OperationState.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | The state one operation owns while it works: the legalization arena, the+-- shared scratch arena, and the instrumentation cells. None of it is+-- topology, so none of it lives on @MutableDcel@ — a transaction allocates+-- this record when it thaws, hands it down to the operations it runs, and+-- reads the counters back once when it freezes. The hot loops thread their+-- stack top, maximum depth and flip count as strict loop variables and charge+-- these cells once per drain; cold events (one per insertion, one per walk+-- probe) charge them where they happen.+module Moonlight.Triangulation.Internal.OperationState+  ( Counter (..)+  , LegalizationArena (..)+  , OperationState+  , newOperationState+  , legalizationArena+  , legalizationArenaLength+  , storeLegalizationArena+  , writeScratch+  , readScratch+  , addCounter+  , setCounter+  , maxCounter+  , readCounter+  , freezeBuildStats+  ) where++import Control.Monad (when)+import Control.Monad.ST (ST)+import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32, Word64)+import Moonlight.Triangulation.Internal.Growable+  ( GrowableWord32+  , newGrowableWord32+  , readGrowable+  , writeGrowable+  )+import Moonlight.Triangulation.Internal.PackedIndex (packIndex, unpackIndex)+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+-- is read only by instrumented entries, so 'freezeBuildStats' enumerates the+-- leading block and never sees the rest.+data Counter+  = CounterInputPoints+  | CounterUniquePoints+  | CounterExistingPoints+  | CounterDuplicatePoints+  | CounterSpatialSeedPoints+  | CounterFaceSplits+  | CounterInteriorEdgeSplits+  | CounterBoundaryEdgeSplits+  | CounterHullInsertions+  | CounterLineSplits+  | CounterLineExtensions+  | CounterLineToAreaTransitions+  | CounterEdgeFlips+  | CounterLocationWalkSteps+  | CounterLocationFallbacks+  | CounterLocationMaxWalk+  | CounterLegalizationMaxStack+  | CounterSteinerPoints+  | CounterRefinementFaceChecks+  | CounterRefinementQueuePops+  | CounterSweepFastPoints+  | CounterSweepSkippedPoints+  | CounterDiagLegalizationCandidates+  | CounterDiagHullBucketProbeSteps+  | CounterDiagHullKeyRebuilds+  | CounterCount+  deriving stock (Eq, Ord, Enum, Bounded, Show)++-- | One operation's working state. Scratch is fixed and raw: writes always+-- precede reads within an epoch. The legalization vector is held behind one+-- reference solely so an adversarial generic drain can grow it without+-- reintroducing mesh-global work state. A drain reads that reference once,+-- carries the vector and all stack metrics strictly, and stores it once when+-- finished; there is no per-candidate reference traffic.+data OperationState s = OperationState+  { osLegalizationArena :: !(STRef s (LegalizationArena s))+  , osScratchArena :: !(GrowableWord32 s)+  , osCounters :: !(MUV.MVector s Word64)+  }++-- | Allocate transaction-sized working state. The legalization reservation is a+-- starting size, not a semantic limit: a generic flip pops one candidate and may+-- push four, no linear worst-case depth follows from the input size, and+-- overflow grows the operation-owned vector by doubling. So the reservation is+-- capped. A transaction-sized one charges every singleton verb a fresh block+-- group whose tail no drain reaches, and the doublings that reach a real peak+-- copy less in total than reserving that tail costs.+--+-- Scratch retains four disjoint half-edge sections as its semantic limit: the+-- removal kernel locally glues border, retired-edge, retired-face, and new-fan+-- sections there. Its physical storage still grows only with the star or strip+-- actually observed. Reserving the full mesh bound made every singleton+-- persistent edit allocate an arena whose untouched tail was orders of+-- magnitude larger than the edit.+newOperationState :: Int -> ST s (OperationState s)+newOperationState halfEdgeCapacity = do+  initialArena <- LegalizationArena <$> MUV.new (min (2 * halfEdgeCapacity + 64) initialLegalizationReservation)+  arena <- newSTRef initialArena+  scratch <- newGrowableWord32 (min 64 (halfEdgeCapacity + 8))+  counters <- MUV.replicate (fromEnum CounterCount) 0+  pure+    OperationState+      { osLegalizationArena = arena+      , osScratchArena = scratch+      , osCounters = counters+      }++-- | Ordinary cavities are tiny; exceptional stars and recovered strips grow+-- geometrically behind the sealed arena rather than taxing every singleton+-- edit for a pathological frontier it never visits.+initialLegalizationReservation :: Int+initialLegalizationReservation = 64++legalizationArena :: OperationState s -> ST s (LegalizationArena s)+legalizationArena = readSTRef . osLegalizationArena+{-# INLINE legalizationArena #-}++legalizationArenaLength :: LegalizationArena s -> Int+legalizationArenaLength (LegalizationArena values) = MUV.length values+{-# INLINE legalizationArenaLength #-}++storeLegalizationArena :: OperationState s -> LegalizationArena s -> ST s ()+storeLegalizationArena = writeSTRef . osLegalizationArena+{-# INLINE storeLegalizationArena #-}++-- | Write a scratch cell. Collection walks carry their topology-derived+-- termination budgets; the growable arena is physical storage, not a second+-- semantic bound capable of disagreeing with those typed obstructions.+writeScratch :: OperationState s -> Int -> Int -> ST s ()+writeScratch OperationState{osScratchArena} index value =+  writeGrowable osScratchArena index (packIndex value)+{-# INLINE writeScratch #-}++readScratch :: OperationState s -> Int -> ST s Int+readScratch OperationState{osScratchArena} index = unpackIndex <$> readGrowable osScratchArena index+{-# INLINE readScratch #-}++addCounter :: OperationState s -> Counter -> Int -> ST s ()+addCounter OperationState{osCounters} counter amount = do+  let !index = fromEnum counter+  current <- MUV.unsafeRead osCounters index+  MUV.unsafeWrite osCounters index (current + fromIntegral amount)+{-# INLINE addCounter #-}++setCounter :: OperationState s -> Counter -> Int -> ST s ()+setCounter OperationState{osCounters} counter value =+  MUV.unsafeWrite osCounters (fromEnum counter) (fromIntegral value)+{-# INLINE setCounter #-}++maxCounter :: OperationState s -> Counter -> Int -> ST s ()+maxCounter OperationState{osCounters} counter value = do+  let !index = fromEnum counter+  current <- MUV.unsafeRead osCounters index+  when (fromIntegral value > current) (MUV.unsafeWrite osCounters index (fromIntegral value))+{-# INLINE maxCounter #-}++readCounter :: OperationState s -> Counter -> ST s Int+readCounter OperationState{osCounters} counter =+  fromIntegral <$> MUV.unsafeRead osCounters (fromEnum counter)+{-# INLINE readCounter #-}++-- | Materialize the public statistics once, at freeze time, from the cells the+-- operation's subsystems charged while it ran. Diagnostic cells past+-- 'CounterRefinementQueuePops' have no t'BuildStats' field and are not read+-- here.+freezeBuildStats :: OperationState s -> ST s BuildStats+freezeBuildStats operation =+  BuildStats+    <$> readCounter operation CounterInputPoints+    <*> readCounter operation CounterUniquePoints+    <*> readCounter operation CounterExistingPoints+    <*> readCounter operation CounterDuplicatePoints+    <*> readCounter operation CounterSpatialSeedPoints+    <*> readCounter operation CounterFaceSplits+    <*> readCounter operation CounterInteriorEdgeSplits+    <*> readCounter operation CounterBoundaryEdgeSplits+    <*> readCounter operation CounterHullInsertions+    <*> readCounter operation CounterLineSplits+    <*> readCounter operation CounterLineExtensions+    <*> readCounter operation CounterLineToAreaTransitions+    <*> readCounter operation CounterEdgeFlips+    <*> readCounter operation CounterLocationWalkSteps+    <*> readCounter operation CounterLocationFallbacks+    <*> readCounter operation CounterLocationMaxWalk+    <*> readCounter operation CounterLegalizationMaxStack+    <*> readCounter operation CounterSteinerPoints+    <*> readCounter operation CounterRefinementFaceChecks+    <*> readCounter operation CounterRefinementQueuePops+    <*> readCounter operation CounterSweepFastPoints+    <*> readCounter operation CounterSweepSkippedPoints+{-# INLINE freezeBuildStats #-}
+ src-dcel/Moonlight/Triangulation/Internal/PointIndex.hs view
@@ -0,0 +1,351 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | The one derived identity index from canonical position hashes to the+-- vertices holding them. Geometry remains solely in the coordinate arenas:+-- both forms store handles only, and every hit is confirmed against those+-- authoritative coordinates. The persistent form follows a published mesh;+-- the open-addressed form is the denser ingress representation used while a+-- bulk load is still claiming its vertices.+module Moonlight.Triangulation.Internal.PointIndex+  ( PointIndex+  , emptyPointIndex+  , buildPointIndex+  , pointIndexCandidates+  , lookupPointIndex+  , insertPointIndex+  , removePointIndex+  , relocatePointIndex+  , MutablePointIndex+  , MutablePointIndexUpdate (..)+  , newMutablePointIndex+  , seedMutablePointIndex+  , lookupMutablePoint+  , removeMutablePoint+  , relocateMutablePoint+  , resolveMutablePoint+  ) where++import Control.DeepSeq (NFData (..))+import Control.Monad.ST (ST)+import Data.Bits (shiftR, xor, (.&.))+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32, Word64)+import GHC.Float (castDoubleToWord64)+import Moonlight.Triangulation.Internal.Types (BuildError (PointIndexCapacityExhausted), Point (..))+import Moonlight.Triangulation.Internal.Paged+  ( Paged+  , pagedUnsafeIndex+  , toVector+  )+import Moonlight.Triangulation.Scalar (canonicalScalarZero)+import qualified Data.Vector.Unboxed as U++-- | Hash buckets containing only vertex handles. Callers confirm candidates+-- against the authoritative coordinate planes.+newtype PointIndex = PointIndex (IntMap.IntMap [Int])+  deriving stock (Eq, Show)++-- A point index is a memoized derived view. Forcing a triangulation forces the+-- geometry and topology that determine it, not a cache no read has demanded.+-- This is the same semantic boundary as omitting the cache from serialization.+instance NFData PointIndex where+  rnf _ = ()++emptyPointIndex :: PointIndex+emptyPointIndex = PointIndex IntMap.empty++-- | Derive an index from the authoritative structure-of-arrays geometry.+buildPointIndex :: Paged Double -> Paged Double -> PointIndex+buildPointIndex pointXs pointYs =+  U.ifoldl'+    (\index vertex x ->+       insertPointIndex x (pagedUnsafeIndex pointYs vertex) vertex index+    )+    emptyPointIndex+    (toVector pointXs)++-- | Candidate vertices sharing a position hash. Exact coordinate comparison+-- belongs to the caller that owns the coordinate reader.+pointIndexCandidates :: Double -> Double -> PointIndex -> [Int]+pointIndexCandidates x y (PointIndex buckets) =+  IntMap.findWithDefault [] (pointHash x y) buckets+{-# INLINE pointIndexCandidates #-}++-- | Resolve one exact position against the authoritative coordinate planes.+-- Hashes reject; coordinates prove. Keeping this here makes the persistent+-- removal and constraint schedules consume the same identity law as a mutable+-- session instead of paying a topological point-location walk for a key lookup.+lookupPointIndex+  :: Paged Double+  -> Paged Double+  -> PointIndex+  -> Point+  -> Maybe Int+lookupPointIndex pointXs pointYs pointIndex (Point x y) =+  foldr confirm Nothing (pointIndexCandidates x y pointIndex)+ where+  confirm candidate resolved+    | pagedUnsafeIndex pointXs candidate == x+        && pagedUnsafeIndex pointYs candidate == y = Just candidate+    | otherwise = resolved++insertPointIndex :: Double -> Double -> Int -> PointIndex -> PointIndex+insertPointIndex x y vertex (PointIndex buckets) =+  PointIndex (IntMap.insertWith (++) (pointHash x y) [vertex] buckets)+{-# INLINE insertPointIndex #-}++-- | Forget one proved handle without touching geometry. Empty collision+-- buckets disappear, so the index remains a derived finite view rather than a+-- history of retired sites.+removePointIndex :: Double -> Double -> Int -> PointIndex -> PointIndex+removePointIndex x y vertex (PointIndex buckets) =+  PointIndex (IntMap.update retainOthers (pointHash x y) buckets)+ where+  retainOthers candidates = case candidates of+    [candidate]+      | candidate == vertex -> Nothing+    _ ->+      case removeCandidate candidates of+        [] -> Nothing+        remaining -> Just remaining++  removeCandidate [] = []+  removeCandidate (candidate : remaining)+    | candidate == vertex = remaining+    | otherwise = candidate : removeCandidate remaining+{-# INLINE removePointIndex #-}++-- | Transport the tail vertex into the slot vacated by swap compaction.+-- Coordinate storage remains authoritative; this updates handles only.+relocatePointIndex+  :: Double+  -> Double+  -> Int+  -> Int+  -> PointIndex+  -> PointIndex+relocatePointIndex x y previousVertex currentVertex (PointIndex buckets) =+  PointIndex+    (IntMap.alter (Just . relocateCandidate . maybe [] id) (pointHash x y) buckets)+ where+  relocateCandidate [] = [currentVertex]+  relocateCandidate (candidate : remaining)+    | candidate == previousVertex = currentVertex : remaining+    | otherwise = candidate : relocateCandidate remaining+{-# INLINE relocatePointIndex #-}++-- The arena already holds every key, so a slot is the vertex that owns the+-- position and nothing else. Every lookup rechecks coordinates; a failed local+-- transport invalidates the table rather than letting it outlive that proof.+data MutablePointIndex s = MutablePointIndex+  { tableSlots :: !(MUV.MVector s Word32)+  , tableMask :: {-# UNPACK #-} !Int+  }++-- | A local cache transport either preserves the proof that every slot agrees+-- with the coordinate arenas, or explicitly gives that proof up. Callers must+-- fall back to the lazy immutable derivation after 'MutablePointIndexInvalidated';+-- they never publish a table whose handle correspondence was not established.+data MutablePointIndexUpdate+  = MutablePointIndexUpdated+  | MutablePointIndexInvalidated++vacant :: Word32+vacant = maxBound++-- | Size a table for a stated number of distinct positions.+newMutablePointIndex :: Int -> ST s (MutablePointIndex s)+newMutablePointIndex expected = do+  tableSlots <- MUV.replicate capacity vacant+  pure MutablePointIndex{tableSlots, tableMask = capacity - 1}+ where+  -- Two slots per key, rounded up to a power of two: linear probing stays in a+  -- short run and the mask stands in for a division.+  !capacity = grow 16+  !wanted = 2 * max 1 expected+  grow !size+    | size >= wanted = size+    | otherwise = grow (size * 2)++-- | Seed the open-addressed section from authoritative coordinates. This is+-- the shared ingress/batch operation: no point payload or parallel identity+-- store crosses the boundary.+seedMutablePointIndex+  :: MutablePointIndex s+  -> Int+  -> (Int -> ST s Double)+  -> (Int -> ST s Double)+  -> ST s (Either BuildError ())+seedMutablePointIndex table count readX readY = seed 0+ where+  seed !vertex+    | vertex >= count = pure (Right ())+    | otherwise = do+        x <- readX vertex+        y <- readY vertex+        claimed <- resolveMutablePoint table readX readY x y vertex+        case claimed of+          Left failure -> pure (Left failure)+          Right _ -> seed (vertex + 1)++-- | Look up a canonical position in the mutable section. A vacant slot proves+-- absence; all occupied candidates are confirmed against coordinate authority.+lookupMutablePoint+  :: MutablePointIndex s+  -> (Int -> ST s Double)+  -> (Int -> ST s Double)+  -> Double+  -> Double+  -> ST s (Maybe Int)+lookupMutablePoint MutablePointIndex{tableSlots, tableMask} readX readY x y =+  probe (fromIntegral (mixCoordinates x y) .&. tableMask) (tableMask + 1)+ where+  probe !slot !budget+    | budget <= 0 = pure Nothing+    | otherwise = do+        occupant <- MUV.unsafeRead tableSlots slot+        if occupant == vacant+          then pure Nothing+          else do+            heldX <- readX (fromIntegral occupant)+            heldY <- readY (fromIntegral occupant)+            if heldX == x && heldY == y+              then pure (Just (fromIntegral occupant))+              else probe ((slot + 1) .&. tableMask) (budget - 1)+{-# INLINE lookupMutablePoint #-}++-- | Forget a retired handle and repair its linear-probe cluster by backward+-- shifting only entries whose home run crosses the resulting hole. The reader+-- is needed for the surviving entries' homes; the retiring entry itself is+-- identified by handle because swap compaction may already have overwritten+-- its coordinate slot. An exhausted or absent proof invalidates the derived+-- cache instead of manufacturing a lookup result.+removeMutablePoint+  :: MutablePointIndex s+  -> (Int -> ST s Double)+  -> (Int -> ST s Double)+  -> Double+  -> Double+  -> Int+  -> ST s MutablePointIndexUpdate+removeMutablePoint MutablePointIndex{tableSlots, tableMask} readX readY x y retiredVertex =+  findRetired (fromIntegral (mixCoordinates x y) .&. tableMask) (tableMask + 1)+ where+  findRetired !slot !budget+    | budget <= 0 = pure MutablePointIndexInvalidated+    | otherwise = do+        occupant <- MUV.unsafeRead tableSlots slot+        if occupant == vacant+          then pure MutablePointIndexInvalidated+          else+            if fromIntegral occupant == retiredVertex+              then do+                MUV.unsafeWrite tableSlots slot vacant+                closeProbeHole slot ((slot + 1) .&. tableMask) (budget - 1)+              else findRetired ((slot + 1) .&. tableMask) (budget - 1)++  closeProbeHole !hole !slot !budget+    | budget <= 0 =+        MutablePointIndexInvalidated <$ MUV.unsafeWrite tableSlots hole vacant+    | otherwise = do+        occupant <- MUV.unsafeRead tableSlots slot+        if occupant == vacant+          then MutablePointIndexUpdated <$ MUV.unsafeWrite tableSlots hole vacant+          else do+            heldX <- readX (fromIntegral occupant)+            heldY <- readY (fromIntegral occupant)+            let !home = fromIntegral (mixCoordinates heldX heldY) .&. tableMask+                !distanceToHole = (hole - home) .&. tableMask+                !distanceToSlot = (slot - home) .&. tableMask+            if distanceToHole < distanceToSlot+              then do+                MUV.unsafeWrite tableSlots hole occupant+                closeProbeHole slot ((slot + 1) .&. tableMask) (budget - 1)+              else closeProbeHole hole ((slot + 1) .&. tableMask) (budget - 1)+{-# INLINE removeMutablePoint #-}++-- | Rename the tail handle after DCEL swap compaction. Failure remains a+-- typed cache obstruction, so its caller drops the table and later identity+-- questions descend from geometry rather than trusting an unproved cache.+relocateMutablePoint+  :: MutablePointIndex s+  -> Double+  -> Double+  -> Int+  -> Int+  -> ST s MutablePointIndexUpdate+relocateMutablePoint MutablePointIndex{tableSlots, tableMask} x y previousVertex currentVertex =+  findPrevious (fromIntegral (mixCoordinates x y) .&. tableMask) (tableMask + 1)+ where+  findPrevious !slot !budget+    | budget <= 0 = pure MutablePointIndexInvalidated+    | otherwise = do+        occupant <- MUV.unsafeRead tableSlots slot+        if occupant == vacant+          then pure MutablePointIndexInvalidated+          else+            if fromIntegral occupant == previousVertex+              then+                MutablePointIndexUpdated+                  <$ MUV.unsafeWrite tableSlots slot (fromIntegral currentVertex)+              else findPrevious ((slot + 1) .&. tableMask) (budget - 1)+{-# INLINE relocateMutablePoint #-}++-- | Answer the vertex already holding a canonical position, or claim the+-- position for @candidate@ and answer 'Nothing'. The position travels as raw+-- coordinates — the v'Point' constructor is the cold boundary's packaging and+-- has no business on the ingress path. The caller supplies the arena's+-- coordinate reader, so a claim is only sound if @candidate@ is the very next+-- vertex the arena will append.+resolveMutablePoint+  :: MutablePointIndex s+  -> (Int -> ST s Double)+  -> (Int -> ST s Double)+  -> Double+  -> Double+  -> Int+  -> ST s (Either BuildError (Maybe Int))+resolveMutablePoint MutablePointIndex{tableSlots, tableMask} readX readY x y candidate =+  probe (fromIntegral (mixCoordinates x y) .&. tableMask) (tableMask + 1)+ where+  probe !slot !budget+    | budget <= 0 = pure (Left (PointIndexCapacityExhausted (MUV.length tableSlots)))+    | otherwise = do+        occupant <- MUV.unsafeRead tableSlots slot+        if occupant == vacant+          then Right Nothing <$ MUV.unsafeWrite tableSlots slot (fromIntegral candidate)+          else do+            heldX <- readX (fromIntegral occupant)+            heldY <- readY (fromIntegral occupant)+            if heldX == x && heldY == y+              then pure (Right (Just (fromIntegral occupant)))+              else probe ((slot + 1) .&. tableMask) (budget - 1)++-- Inlined rather than merely specialized: the coordinate reader arrives as an+-- argument, so until the probe loop lands at its call site every collision pays+-- an unknown call and a boxed pair for a read the caller could have made+-- directly.+{-# INLINE resolveMutablePoint #-}++mixCoordinates :: Double -> Double -> Word64+mixCoordinates x y =+  mix+    ( castDoubleToWord64 (canonicalScalarZero x)+        `xor` mix (castDoubleToWord64 (canonicalScalarZero y))+    )+{-# INLINE mixCoordinates #-}++mix :: Word64 -> Word64+mix raw =+  let !z0 = raw + 0x9e3779b97f4a7c15+      !z1 = (z0 `xor` (z0 `shiftR` 30)) * 0xbf58476d1ce4e5b9+      !z2 = (z1 `xor` (z1 `shiftR` 27)) * 0x94d049bb133111eb+   in z2 `xor` (z2 `shiftR` 31)+{-# INLINE mix #-}++pointHash :: Double -> Double -> Int+pointHash x y = fromIntegral (mixCoordinates x y)+{-# INLINE pointHash #-}
+ src-dcel/Moonlight/Triangulation/Internal/Predicates.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -O3 -fllvm -optlo-O3 -optlc-O3 #-}++-- | Exact predicates over points already admitted by a construction or query+-- boundary.  This module is package-private: public callers must carry+-- 'QueryPoint' evidence through "Moonlight.Triangulation.Math" instead of+-- presenting arbitrary IEEE-754 payloads to an exact classifier.+module Moonlight.Triangulation.Internal.Predicates+  ( orient2dCoordinates+  , inCircleCoordinates+  , orient2d+  , sideQuery+  , inCircle+  , onClosedSegment+  , segmentRelation+  , segmentsProperlyCross+  , segmentsIntersect+  , inDiametralCircle+  ) where++import Moonlight.Triangulation.Internal.Dyadic+  ( exactDiametralDot+  , exactInCircleDet+  , exactOrientSignDouble+  )+import Moonlight.Triangulation.Internal.SegmentRelation+  ( SegmentRelation (..)+  , segmentRelationWith+  )+import Moonlight.Triangulation.LineSideInfo (LineSideInfo, fromOrdering)+import Moonlight.Triangulation.Scalar+  ( isFinite+  , scalarCcwErrorBound+  , scalarInCircleErrorBound+  )+import Moonlight.Triangulation.Internal.Types (Point (..))++-- The coordinate kernels are package-private because their raw 'Double'+-- arguments carry no finite-range evidence. Every public exact classifier+-- descends through 'QueryPoint'; internal hot paths call these only after their+-- construction boundary has admitted the stored coordinates.+orient2dCoordinates+  :: Double -> Double -> Double -> Double -> Double -> Double+  -> Ordering+orient2dCoordinates ax ay bx by cx cy+  | abs determinant > scalarCcwErrorBound * determinantSum = compare determinant 0+  | otherwise = exactOrientSignDouble ax ay bx by cx cy+ where+  !left = (ax - cx) * (by - cy)+  !right = (ay - cy) * (bx - cx)+  !determinant = left - right+  !determinantSum = abs left + abs right+{-# INLINE orient2dCoordinates #-}++inCircleCoordinates+  :: Double -> Double -> Double -> Double+  -> Double -> Double -> Double -> Double+  -> Ordering+inCircleCoordinates ax ay bx by cx cy dx dy+  | abs determinant > scalarInCircleErrorBound * permanent = compare determinant 0+  | otherwise = compare (exactInCircleDet ax ay bx by cx cy dx dy) 0+ where+  !adx = ax - dx+  !ady = ay - dy+  !bdx = bx - dx+  !bdy = by - dy+  !cdx = cx - dx+  !cdy = cy - dy+  !abdet = adx * bdy - bdx * ady+  !bcdet = bdx * cdy - cdx * bdy+  !cadet = cdx * ady - adx * cdy+  !alift = adx * adx + ady * ady+  !blift = bdx * bdx + bdy * bdy+  !clift = cdx * cdx + cdy * cdy+  !determinant = alift * bcdet + blift * cadet + clift * abdet+  !permanent =+    (abs (bdx * cdy) + abs (cdx * bdy)) * alift+      + (abs (cdx * ady) + abs (adx * cdy)) * blift+      + (abs (adx * bdy) + abs (bdx * ady)) * clift+{-# INLINE inCircleCoordinates #-}++-- | Exact orientation of points whose coordinates have already been admitted.+orient2d :: Point -> Point -> Point -> Ordering+orient2d (Point ax ay) (Point bx by) (Point cx cy) =+  orient2dCoordinates ax ay bx by cx cy+{-# INLINE orient2d #-}++-- | Exact side of an admitted oriented line.+sideQuery :: Point -> Point -> Point -> LineSideInfo+sideQuery from to query = fromOrdering (orient2d from to query)+{-# INLINE sideQuery #-}++-- | Ordering of the admitted oriented incircle determinant.+inCircle :: Point -> Point -> Point -> Point -> Ordering+inCircle+  (Point ax ay)+  (Point bx by)+  (Point cx cy)+  (Point dx dy) =+    inCircleCoordinates ax ay bx by cx cy dx dy+{-# INLINE inCircle #-}++-- | Whether an admitted point lies on an admitted closed segment.+onClosedSegment :: Point -> Point -> Point -> Bool+onClosedSegment from@(Point fromX fromY) to@(Point toX toY) query@(Point queryX queryY) =+  orient2d from to query == EQ+    && queryX >= min fromX toX+    && queryX <= max fromX toX+    && queryY >= min fromY toY+    && queryY <= max fromY toY+{-# INLINE onClosedSegment #-}++-- | Exact relation between admitted closed segments.+segmentRelation :: Point -> Point -> Point -> Point -> SegmentRelation+segmentRelation = segmentRelationWith (==) compare orient2d onClosedSegment++-- | Whether two admitted closed segments share any point.+segmentsIntersect :: Point -> Point -> Point -> Point -> Bool+segmentsIntersect firstFrom firstTo secondFrom secondTo =+  segmentRelation firstFrom firstTo secondFrom secondTo /= SegmentsDisjoint++-- | Whether two admitted segments cross away from their endpoints.+segmentsProperlyCross :: Point -> Point -> Point -> Point -> Bool+segmentsProperlyCross firstFrom firstTo secondFrom secondTo =+  opposite (orient2d firstFrom firstTo secondFrom) (orient2d firstFrom firstTo secondTo)+    && opposite (orient2d secondFrom secondTo firstFrom) (orient2d secondFrom secondTo firstTo)+ where+  opposite LT GT = True+  opposite GT LT = True+  opposite _ _ = False++-- | Whether an admitted point lies in the closed diametral disk of an admitted+-- segment.+inDiametralCircle :: Point -> Point -> Point -> Bool+inDiametralCircle (Point ax ay) (Point bx by) (Point px py)+  | isFinite dot && abs dot > scalarCcwErrorBound * dotSum = dot < 0+  | otherwise = exactDiametralDot ax ay bx by px py <= 0+ where+  !left = (ax - px) * (bx - px)+  !right = (ay - py) * (by - py)+  !dot = left + right+  !dotSum = abs left + abs right+{-# INLINE inDiametralCircle #-}
+ src-dcel/Moonlight/Triangulation/Internal/Probe.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}++-- | Compile-time instrumentation switch. The bulk board is the measuring+-- instrument, so per-candidate probe counters must not exist on its path at+-- all: gating behind a flag the compiler can eliminate is the only honest way+-- to have both one sweep implementation and an undistorted measurement. The+-- flag is a type, not a value: at 'ProbeOff the counter type is @()@, so no+-- arithmetic on it can survive in the worker — erasure is a property of the+-- kind, not of the optimizer's mood. The instrumented entry instantiates the+-- same code at 'ProbeOn and pays the cold counter writes itself.+module Moonlight.Triangulation.Internal.Probe+  ( Probe (..)+  , ProbeCounter+  , KnownProbe (..)+  ) where++import Control.Monad.ST (ST)+import Data.Kind (Type)+import Moonlight.Triangulation.Internal.OperationState+  ( Counter+  , OperationState+  , addCounter+  )++-- | The instrumentation switch, promoted to a kind by @DataKinds@.+data Probe = ProbeOff | ProbeOn++-- | The counter a probe site threads. At 'ProbeOff there is nothing to+-- thread; at 'ProbeOn it is a strict @Int@.+type family ProbeCounter (probe :: Probe) = (counter :: Type) | counter -> probe where+  ProbeCounter 'ProbeOff = ()+  ProbeCounter 'ProbeOn = Int++class KnownProbe probe where+  probeZero :: ProbeCounter probe+  probeBump :: ProbeCounter probe -> ProbeCounter probe+  -- | Charge one finished counter to the operation's diagnostic cell. At+  -- 'ProbeOff this is @pure ()@ and disappears with the dictionary; at+  -- 'ProbeOn it is one cold vector write per drain or probe site, on the+  -- instrumented entry that asked for it.+  probeCharge :: OperationState s -> Counter -> ProbeCounter probe -> ST s ()++instance KnownProbe 'ProbeOff where+  probeZero = ()+  probeBump = id+  probeCharge _ _ _ = pure ()+  {-# INLINE probeZero #-}+  {-# INLINE probeBump #-}+  {-# INLINE probeCharge #-}++instance KnownProbe 'ProbeOn where+  probeZero = 0+  probeBump counter = counter + 1+  probeCharge operation counter value = addCounter operation counter value+  {-# INLINE probeZero #-}+  {-# INLINE probeBump #-}+  {-# INLINE probeCharge #-}
+ src-dcel/Moonlight/Triangulation/Internal/Region/Bounds.hs view
@@ -0,0 +1,206 @@+-- | 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 qualified Data.List as List+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)) =+  List.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+        ( List.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.Internal.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.Internal.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
@@ -0,0 +1,641 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | The stored representation: the structure-of-arrays mesh, the payload+-- traversals that reach its four free parameters, and the records that carry a+-- built mesh beside its telemetry.+module Moonlight.Triangulation.Internal.Representation+  ( Triangulation (..)+  , SeamFrontierIndex (..)+  , prepareSeamFrontierIndex+  , summarizeSeamChart+  , seamQuarterTurn+  , geometryOnlyPublication+  , promoteConstrained+  , PayloadTraversal+  , vertexPayloads+  , directedPayloads+  , undirectedPayloads+  , facePayloads+  , mapVertices+  , mapDirectedEdges+  , mapUndirectedEdges+  , mapFaces+  , imapUndirectedEdges+  , imapFaces+  , DelaunayTriangulation+  , ConstrainedDelaunayTriangulation+  , BuildResult (..)+  , InsertionResult (..)+  , RefinementReceipt (..)+  , RefinementDomainResult (..)+  , RefinementResult (..)+  ) where++import Control.DeepSeq (NFData)+import Data.Foldable (toList)+import qualified Data.IntSet as IntSet+import Data.List (unfoldr)+import qualified Data.List as List+import Data.Primitive.PrimArray (PrimArray)+import qualified Data.Sequence as Seq+import Data.Traversable (foldMapDefault)+import qualified Data.Vector as V+import Data.Word (Word8, Word32)+import Moonlight.Triangulation.Internal.HandleDefs+  ( FaceId (..)+  , UndirectedEdgeId (..)+  , VertexId (..)+  )+import Moonlight.Triangulation.Internal.PackedIndex (unpackIndex, unpackOptionalIndex)+import Moonlight.Triangulation.Internal.BoxedPaged (BoxedPaged, boxedDefaulted, boxedFromVector, boxedToVector)+import Moonlight.Triangulation.Internal.Paged+  ( Paged+  , PublicationStats+  , pagedLength+  , pagedUnsafeIndex+  )+import Moonlight.Triangulation.Internal.PointIndex (PointIndex)+import Moonlight.Triangulation.Internal.Types+  ( BuildStats+  , ConstraintMode (..)+  , ElementDefaults (..)+  , InsertionDisposition+  , ValidationClosureStats+  , unitElementDefaults+  )+import GHC.Generics (Generic)++-- | Immutable finite DCEL. The coordinate pages own the geometry; vertex+-- payloads are free annotations carried alongside it.+-- 'Moonlight.Triangulation.Internal.Types.HasPosition' is how a point is read+-- out of a payload at the moment of+-- ingestion and is not consulted again, so a payload whose instance later+-- disagrees with where its vertex sits is not a corrupt triangulation — it is a+-- payload nobody asks about position. Half-edge topology is one interleaved+-- arena: edge @e@ owns slots @4e..4e+3@ holding origin, next, previous and+-- face, so a twin pair is one contiguous eight-word record.+-- Directed edges are adjacent twin pairs, so reversal is an XOR with one.+-- Face zero is the unique outer face. Constraint flags are stored once per+-- undirected edge and are zero for ordinary Delaunay triangulations.+-- All four payload components are therefore representational: coercing a+-- newtype through any of them is a coercion, not a rebuild.+type role Triangulation nominal representational representational representational representational++data Triangulation (mode :: ConstraintMode) vertex directed undirected face = Triangulation+  { triPointX :: !(Paged Double)+  , triPointY :: !(Paged Double)+  , -- | Derived position-hash buckets containing vertex handles only. This is+    -- deliberately lazy: geometry is authoritative, so a workload that never+    -- asks an identity question owes no cache construction.+    triPointIndex :: PointIndex+  , triVertexOut :: !(Paged Word32)+  , triVertexData :: !(BoxedPaged vertex)+  , triHalfTopology :: !(Paged Word32)+  , triDirectedData :: !(BoxedPaged directed)+  , triUndirectedData :: !(BoxedPaged undirected)+  , triFaceEdge :: !(Paged Word32)+  , triFaceData :: !(BoxedPaged face)+  , triConstraint :: !(Paged Word8)+  , triConstraintCount :: {-# UNPACK #-} !Int+  , -- | Derived exact membership for the sparse constrained edge section.+    -- The flag plane remains authoritative and serializable; this index is+    -- transported with edge rewrites so constraint-only queries need not scan+    -- every ordinary Delaunay edge.+    triConstraintEdges :: !IntSet.IntSet+  , -- | Derived outer-frontier handles for persistent separated joins. The+    -- geometry/topology planes remain authoritative; this cache is omitted+    -- from equality and serialization and is rebuilt only at an explicit+    -- geometry-only preparation boundary.+    triSeamFrontier :: !(Maybe SeamFrontierIndex)+  , triElementDefaults :: !(ElementDefaults directed undirected face)+  }+  deriving stock (Show, Generic)+  deriving anyclass (NFData)++-- | Exact immutable outer cycle plus four deterministic extreme anchors per+-- chart used to seed separated tangents. The sequence is persistent: seam+-- joins compose retained source sections without copying their elements.+data SeamFrontierIndex = SeamFrontierIndex+  { seamFrontierEdges :: !(Seq.Seq Int)+  , seamFrontierXMinimum :: !Double+  , seamFrontierXMaximum :: !Double+  , seamFrontierLowerRightmost :: {-# UNPACK #-} !Int+  , seamFrontierLowerLeftmost :: {-# UNPACK #-} !Int+  , seamFrontierUpperRightmost :: {-# UNPACK #-} !Int+  , seamFrontierUpperLeftmost :: {-# UNPACK #-} !Int+  , -- | The same four extreme anchors in the orientation-preserving+    -- quarter-turn chart @(u,v) = (y,-x)@.  Keeping this alongside the+    -- existing x chart lets a later seam admit a north/south extension+    -- without walking the resident frontier again.+    seamFrontierYMinimum :: !Double+  , seamFrontierYMaximum :: !Double+  , seamFrontierYLowerRightmost :: {-# UNPACK #-} !Int+  , seamFrontierYLowerLeftmost :: {-# UNPACK #-} !Int+  , seamFrontierYUpperRightmost :: {-# UNPACK #-} !Int+  , seamFrontierYUpperLeftmost :: {-# UNPACK #-} !Int+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Derive the exact frontier once from an admitted DCEL. This is intentionally+-- an explicit preparation operation: ordinary mutable publication clears the+-- cache instead of silently paying an outer-cycle traversal.+prepareSeamFrontierIndex+  :: Triangulation mode vertex directed undirected face+  -> Maybe SeamFrontierIndex+prepareSeamFrontierIndex triangulation = do+  start <- frontierStart triangulation+  let !directedCount = numDirectedEdges triangulation+      !edges =+        unfoldr+          (frontierStep start directedCount)+          (start, True, directedCount + 1)+      terminal = List.foldl' (\_ edge -> Just edge) Nothing edges+      closesAtStart = do+        lastEdge <- terminal+        pure+          ( unpackIndex+              (pagedUnsafeIndex (triHalfTopology triangulation) (4 * lastEdge + 1))+              == start+          )+  if closesAtStart == Just True+    then summarizeFrontier triangulation (Seq.fromList edges)+    else Nothing+ where+  numDirectedEdges+    :: Triangulation mode vertex directed undirected face+    -> Int+  numDirectedEdges mesh = pagedLength (triHalfTopology mesh) `quot` 4++  frontierStart+    :: Triangulation mode vertex directed undirected face+    -> Maybe Int+  frontierStart mesh =+    unpackOptionalIndex (pagedUnsafeIndex (triFaceEdge mesh) 0)++  frontierStep+    :: Int+    -> Int+    -> (Int, Bool, Int)+    -> Maybe (Int, (Int, Bool, Int))+  frontierStep start directedCount (edge, first, remaining)+    | remaining <= 0 = Nothing+    | edge == start && not first = Nothing+    | edge < 0 || edge >= directedCount = Nothing+    | otherwise =+        let next =+              fromIntegral+                (pagedUnsafeIndex (triHalfTopology triangulation) (4 * edge + 1))+         in Just (edge, (next, False, remaining - 1))++summarizeFrontier+  :: Triangulation mode vertex directed undirected face+  -> Seq.Seq Int+  -> Maybe SeamFrontierIndex+summarizeFrontier triangulation edges =+  case fmap (frontierPoint triangulation) (toList edges) of+    [] -> Nothing+    points -> do+      (minimumX, maximumX, lowerRightmost, lowerLeftmost, upperRightmost, upperLeftmost) <-+        summarizeSeamChart id (zip [0 ..] points)+      (minimumY, maximumY, yLowerRightmost, yLowerLeftmost, yUpperRightmost, yUpperLeftmost) <-+        summarizeSeamChart seamQuarterTurn (zip [0 ..] points)+      pure+        SeamFrontierIndex+          { seamFrontierEdges = edges+          , seamFrontierXMinimum = minimumX+          , seamFrontierXMaximum = maximumX+          , seamFrontierLowerRightmost = lowerRightmost+          , seamFrontierLowerLeftmost = lowerLeftmost+          , seamFrontierUpperRightmost = upperRightmost+          , seamFrontierUpperLeftmost = upperLeftmost+          , seamFrontierYMinimum = minimumY+          , seamFrontierYMaximum = maximumY+          , seamFrontierYLowerRightmost = yLowerRightmost+          , seamFrontierYLowerLeftmost = yLowerLeftmost+          , seamFrontierYUpperRightmost = yUpperRightmost+          , seamFrontierYUpperLeftmost = yUpperLeftmost+          }+ where+  frontierPoint+    :: Triangulation mode vertex directed undirected face+    -> Int+    -> (Double, Double)+  frontierPoint mesh rawEdge =+    let rawVertex = pagedUnsafeIndex (triHalfTopology mesh) (4 * rawEdge)+        vertex = unpackIndex rawVertex+     in ( pagedUnsafeIndex (triPointX mesh) vertex+        , pagedUnsafeIndex (triPointY mesh) vertex+        )++-- | Summarize one chart from a bounded set of frontier points.  The index is+-- retained beside the transformed point so the seam can carry the witness+-- through a residual interval without re-reading the source frontier.+summarizeSeamChart+  :: ((Double, Double) -> (Double, Double))+  -> [(Int, (Double, Double))]+  -> Maybe (Double, Double, Int, Int, Int, Int)+summarizeSeamChart transform points =+  case fmap (\(index, point) -> (index, transform point)) points of+    [] -> Nothing+    first : remaining ->+      let (!minimumValue, !maximumValue) =+            List.foldl'+              (\(!minimumSoFar, !maximumSoFar) (_, (u, _)) ->+                 (min minimumSoFar u, max maximumSoFar u))+              (chartU (snd first), chartU (snd first))+              remaining+          choose preference =+            snd+              ( List.foldl'+                  (\(!bestPoint, !bestIndex) (index, candidate) ->+                     if preference bestPoint candidate+                       then (candidate, index)+                       else (bestPoint, bestIndex))+                  (snd first, fst first)+                  remaining+              )+       in Just+            ( minimumValue+            , maximumValue+            , choose preferRightmost+            , choose preferLeftmost+            , choose preferRightmostUpper+            , choose preferLeftmostUpper+            )+ where+  chartU :: (Double, Double) -> Double+  preferRightmost :: (Double, Double) -> (Double, Double) -> Bool+  preferLeftmost :: (Double, Double) -> (Double, Double) -> Bool+  preferRightmostUpper :: (Double, Double) -> (Double, Double) -> Bool+  preferLeftmostUpper :: (Double, Double) -> (Double, Double) -> Bool+  chartU (u, _) = u+  preferRightmost (bestU, bestV) (candidateU, candidateV) =+    candidateU > bestU || (candidateU == bestU && candidateV < bestV)+  preferLeftmost (bestU, bestV) (candidateU, candidateV) =+    candidateU < bestU || (candidateU == bestU && candidateV < bestV)+  preferRightmostUpper (bestU, bestV) (candidateU, candidateV) =+    candidateU > bestU || (candidateU == bestU && candidateV > bestV)+  preferLeftmostUpper (bestU, bestV) (candidateU, candidateV) =+    candidateU < bestU || (candidateU == bestU && candidateV > bestV)++-- | Orientation-preserving quarter turn used by the north/south seam chart.+seamQuarterTurn :: (Double, Double) -> (Double, Double)+seamQuarterTurn (x, y) = (y, -x)++-- | Forget every payload while preparing a geometry-only mesh for persistent+-- extension. Each payload plane is replaced directly with a defaulted,+-- zero-page unit store; no source payload is traversed or densely rebuilt.+-- Coordinates, topology, constraints, counts, and derived point identity+-- remain authoritative, while future elements inherit the unit defaults.+geometryOnlyPublication+  :: Triangulation mode vertex directed undirected face+  -> Triangulation mode () () () ()+geometryOnlyPublication triangulation =+  triangulation+    { triVertexData = boxedDefaulted () (pagedLength (triPointX triangulation))+    , triDirectedData = boxedDefaulted () (pagedLength (triHalfTopology triangulation) `quot` 4)+    , triUndirectedData = boxedDefaulted () (pagedLength (triHalfTopology triangulation) `quot` 8)+    , triFaceData = boxedDefaulted () (pagedLength (triFaceEdge triangulation))+    , triElementDefaults = unitElementDefaults+    , triSeamFrontier =+        case triSeamFrontier triangulation of+          Just frontier -> Just frontier+          Nothing -> prepareSeamFrontierIndex triangulation+    }++-- The point index is a derived cache and therefore not an observable part of+-- the mesh value. Structural equality compares every semantic plane and+-- default while deliberately refusing to construct or compare that cache.+instance+  ( Eq vertex+  , Eq directed+  , Eq undirected+  , Eq face+  ) => Eq (Triangulation mode vertex directed undirected face) where+  left == right =+    triPointX left == triPointX right+      && triPointY left == triPointY right+      && triVertexOut left == triVertexOut right+      && triVertexData left == triVertexData right+      && triHalfTopology left == triHalfTopology right+      && triDirectedData left == triDirectedData right+      && triUndirectedData left == triUndirectedData right+      && triFaceEdge left == triFaceEdge right+      && triFaceData left == triFaceData right+      && triConstraint left == triConstraint right+      && triConstraintCount left == triConstraintCount right+      && triElementDefaults left == triElementDefaults right++promoteConstrained+  :: Triangulation 'Unconstrained vertex directed undirected face+  -> Triangulation 'Constrained vertex directed undirected face+promoteConstrained Triangulation{+  triPointX, triPointY, triPointIndex, triVertexOut, triVertexData, triHalfTopology,+  triDirectedData, triUndirectedData, triFaceEdge, triFaceData,+  triConstraint, triConstraintCount, triConstraintEdges, triSeamFrontier,+  triElementDefaults+  } =+  Triangulation{+    triPointX, triPointY, triPointIndex, triVertexOut, triVertexData, triHalfTopology,+    triDirectedData, triUndirectedData, triFaceEdge, triFaceData,+    triConstraint, triConstraintCount, triConstraintEdges, triSeamFrontier,+    triElementDefaults+    }++-- | A traversal of every occurrence of one payload parameter, in the van+-- Laarhoven encoding: an effectful visit that may change the payload's type.+-- The 'Applicative' belongs to the caller, so one traversal per parameter+-- serves relabeling, collection and genuinely effectful annotation alike+-- instead of a separate function for each.+type PayloadTraversal source target payload payload' =+  forall f. Applicative f => (payload -> f payload') -> source -> f target++-- | Every stored vertex payload, in vertex order.+--+-- The vertex store carries no fill — a vertex's payload arrives with the+-- vertex, and no slot is read before it is written — so the visits are exactly+-- the stored payloads and nothing besides.+vertexPayloads+  :: PayloadTraversal+      (Triangulation mode vertex directed undirected face)+      (Triangulation mode vertex' directed undirected face)+      vertex+      vertex'+vertexPayloads visit triangulation =+  (\payloads -> triangulation{triVertexData = boxedFromVector Nothing payloads})+    <$> traverse visit (boxedToVector (triVertexData triangulation))++-- | Every stored directed-edge payload, then the default a later directed edge+-- will inherit.+--+-- The default is visited because it is a payload the structure carries, and it+-- is visited /once/: its single image is written both to t'ElementDefaults' and+-- to the store's fill, which every slot of an unmaterialized page reports.+-- Visiting the two positions separately would let an effect with more than one+-- answer hand them different values, and a triangulation whose future elements+-- disagree with its present ones is not a triangulation anyone asked for.+directedPayloads+  :: PayloadTraversal+      (Triangulation mode vertex directed undirected face)+      (Triangulation mode vertex directed' undirected face)+      directed+      directed'+directedPayloads visit triangulation =+  (\payloads fallback ->+     triangulation+       { triDirectedData = boxedFromVector (Just fallback) payloads+       , triElementDefaults = defaults{defaultDirectedEdgeData = fallback}+       })+    <$> traverse visit (boxedToVector (triDirectedData triangulation))+    <*> visit (defaultDirectedEdgeData defaults)+ where+  defaults = triElementDefaults triangulation++-- | Every stored undirected-edge payload, then the default a later undirected+-- edge will inherit.+undirectedPayloads+  :: PayloadTraversal+      (Triangulation mode vertex directed undirected face)+      (Triangulation mode vertex directed undirected' face)+      undirected+      undirected'+undirectedPayloads visit triangulation =+  (\payloads fallback ->+     triangulation+       { triUndirectedData = boxedFromVector (Just fallback) payloads+       , triElementDefaults = defaults{defaultUndirectedEdgeData = fallback}+       })+    <$> traverse visit (boxedToVector (triUndirectedData triangulation))+    <*> visit (defaultUndirectedEdgeData defaults)+ where+  defaults = triElementDefaults triangulation++-- | Every stored face payload, then the default a later face will inherit.+facePayloads+  :: PayloadTraversal+      (Triangulation mode vertex directed undirected face)+      (Triangulation mode vertex directed undirected face')+      face+      face'+facePayloads visit triangulation =+  (\payloads fallback ->+     triangulation+       { triFaceData = boxedFromVector (Just fallback) payloads+       , triElementDefaults = defaults{defaultFaceData = fallback}+       })+    <$> traverse visit (boxedToVector (triFaceData triangulation))+    <*> visit (defaultFaceData defaults)+ where+  defaults = triElementDefaults triangulation++-- | Ranges over the face payload, which is the last parameter and so the only+-- one a class of this kind can reach. The other three payloads have exactly+-- the same structure under 'vertexPayloads', 'directedPayloads' and+-- 'undirectedPayloads'; they are simply not spellable as instances here.+--+-- 'mapFaces' rather than the traversal, because it leaves an unmaterialized+-- page unmaterialized. The two agree on everything a 'BoxedPaged' lets anyone+-- observe, which is what the coherence law asks and all it asks.+instance Functor (Triangulation mode vertex directed undirected) where+  fmap = mapFaces+  {-# INLINE fmap #-}++-- | Folds the stored face payloads and then the default, so 'length' is one+-- greater than the number of stored faces. A fold that skipped the default+-- would report a triangulation as holding a value it does hold.+instance Foldable (Triangulation mode vertex directed undirected) where+  foldMap = foldMapDefault+  {-# INLINE foldMap #-}++instance Traversable (Triangulation mode vertex directed undirected) where+  traverse = facePayloads+  {-# INLINE traverse #-}++-- | An element payload map carries the element defaults with it. A new+-- insertion hands its new elements the default, so a map that reindexed the+-- stored payloads and left the default behind would produce a triangulation+-- whose future elements disagree with its present ones. The type system very+-- nearly forces this on its own — the image type is inhabited here only+-- through the mapping function — but only a test can insist the argument is+-- the /default/ rather than some other payload of the right type.+mapDirectedEdges+  :: (directed -> directed')+  -> Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex directed' undirected face+mapDirectedEdges f triangulation =+  triangulation+    { triDirectedData = fmap f (triDirectedData triangulation)+    , triElementDefaults = defaults{defaultDirectedEdgeData = f (defaultDirectedEdgeData defaults)}+    }+ where+  defaults = triElementDefaults triangulation++-- | Map every undirected-edge annotation and its future-element default.+mapUndirectedEdges+  :: (undirected -> undirected')+  -> Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex directed undirected' face+mapUndirectedEdges f triangulation =+  triangulation+    { triUndirectedData = fmap f (triUndirectedData triangulation)+    , triElementDefaults = defaults{defaultUndirectedEdgeData = f (defaultUndirectedEdgeData defaults)}+    }+ where+  defaults = triElementDefaults triangulation++-- | Map every face annotation and its future-element default.+mapFaces+  :: (face -> face')+  -> Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex directed undirected face'+mapFaces f triangulation =+  triangulation+    { triFaceData = fmap f (triFaceData triangulation)+    , triElementDefaults = defaults{defaultFaceData = f (defaultFaceData defaults)}+    }+ where+  defaults = triElementDefaults triangulation++-- | The vertex component is free, like the other three. Geometry owns the+-- points, so a payload map cannot move one — the image type need not even have+-- a position to speak of. There is no vertex default to carry: vertices arrive+-- with their payloads.+mapVertices+  :: (vertex -> vertex')+  -> Triangulation mode vertex directed undirected face+  -> Triangulation mode vertex' directed undirected face+mapVertices f triangulation =+  triangulation{triVertexData = fmap f (triVertexData triangulation)}++-- | 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 () () ()++-- | Geometry-only constrained Delaunay triangulation.+type ConstrainedDelaunayTriangulation vertex = Triangulation 'Constrained vertex () () ()++-- | A constructed triangulation and the canonical handle chosen for each input.+--+-- The result is a value, not a history: derived 'Eq'/'Show' would observe+-- 'buildStats' through a facade that hides it, so neither instance exists.+data BuildResult mode vertex directed undirected face = BuildResult+  { -- | The immutable constructed mesh.+    buildTriangulation :: !(Triangulation mode vertex directed undirected face)+  , -- | Canonical vertex handle for each input position, including duplicates.+    buildInputVertices :: !(PrimArray Word32)+  , buildStats :: !BuildStats+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++-- | Published insertion result, selected vertex, disposition, and work receipt.+data InsertionResult mode vertex directed undirected face = InsertionResult+  { insertionTriangulation :: !(Triangulation mode vertex directed undirected face)+  , insertionVertex :: !VertexId+  , insertionDisposition :: !InsertionDisposition+  , insertionStats :: !BuildStats+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++deriving stock instance+  (Eq vertex, Eq directed, Eq undirected, Eq face)+  => Eq (InsertionResult mode vertex directed undirected face)+deriving stock instance+  (Show vertex, Show directed, Show undirected, Show face)+  => Show (InsertionResult mode vertex directed undirected face)++-- | Exact support touched by one refinement publication. Checked local+-- refinement uses this as the positive receipt accompanying its typed+-- obstruction surface; unrestricted refinement deliberately avoids the+-- additional support scan.+data RefinementReceipt = RefinementReceipt+  { refinementVisitedJoinFaces :: !(V.Vector FaceId)+  , refinementVisitedProtectedFaces :: !(V.Vector FaceId)+  , refinementCreatedFaces :: !(V.Vector FaceId)+    -- ^ Face slots whose published triangle changed or was appended.+  , refinementFinalPermittedFaces :: !(V.Vector FaceId)+    -- ^ Exact final face lineage admitted by a checked local domain.+  , refinementFinalInterfaceIncidence :: !(V.Vector (UndirectedEdgeId, FaceId, FaceId))+  , refinementTouchedEdges :: !(V.Vector UndirectedEdgeId)+  , refinementRemovedEdges :: !(V.Vector UndirectedEdgeId)+  , refinementInterfaceBoundaryReads :: {-# UNPACK #-} !Int+  , refinementAttemptedBoundaryCrossings :: {-# UNPACK #-} !Int+  , refinementPublicationStats :: !PublicationStats+    -- ^ Page publication work measured by the transaction owner.+  , refinementValidationClosureStats :: !ValidationClosureStats+    -- ^ Typed support counts emitted by the selected validation descent.+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | A locally refined section paired with the proof of what the checked+-- interpreter observed and rewrote. Ordinary refinement does not pay to+-- construct this proof.+data RefinementDomainResult mode vertex directed undirected face = RefinementDomainResult+  { refinementDomainResult :: !(RefinementResult mode vertex directed undirected face)+  , refinementDomainReceipt :: !RefinementReceipt+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++-- | Refined mesh together with the budget, exclusion, and support outcome.+data RefinementResult mode vertex directed undirected face = RefinementResult+  { -- | The immutable mesh after all admitted refinement steps.+    refinedTriangulation :: !(Triangulation mode vertex directed undirected face)+  , refinementStats :: !BuildStats+  , refinementAddedVertices :: {-# UNPACK #-} !Int+  -- | Whether the quality worklist drained. 'False' means the vertex budget+  -- stopped the run with work outstanding. A drained worklist can still leave+  -- faces the quality bounds condemn but no admissible Steiner point can fix;+  -- auditing the result is the caller's to ask for, not a cost every run pays.+  , refinementComplete :: !Bool+  , -- | Faces deliberately excluded by barrier-depth policy.+    refinementExcludedFaces :: !(V.Vector FaceId)+  }+  deriving stock (Generic)+  deriving anyclass (NFData)
+ src-dcel/Moonlight/Triangulation/Internal/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/Tournament.hs view
@@ -0,0 +1,45 @@+-- | One deterministic balanced binary descent shared by every pure+-- associative schedule in the package.  Leaves retain their source values;+-- interpreters own only their binary operation.+module Moonlight.Triangulation.Internal.Tournament+  ( TournamentPlan (..)+  , planTournament+  , interpretTournament+  ) where++import Data.List.NonEmpty (NonEmpty (..))++data TournamentPlan value+  = TournamentLeaf !value+  | TournamentNode !(TournamentPlan value) !(TournamentPlan value)++planTournament :: NonEmpty value -> TournamentPlan value+planTournament = descendTournament . fmap TournamentLeaf++interpretTournament+  :: (value -> value -> Either failure value)+  -> TournamentPlan value+  -> Either failure value+interpretTournament combine tournament =+  case tournament of+    TournamentLeaf value -> Right value+    TournamentNode left right -> do+      leftValue <- interpretTournament combine left+      rightValue <- interpretTournament combine right+      combine leftValue rightValue++descendTournament :: NonEmpty (TournamentPlan value) -> TournamentPlan value+descendTournament (single :| []) = single+descendTournament plans = descendTournament (pairTournamentRound plans)++pairTournamentRound+  :: NonEmpty (TournamentPlan value)+  -> NonEmpty (TournamentPlan value)+pairTournamentRound (left :| right : rest) =+  TournamentNode left right :| pairTournamentTail rest+pairTournamentRound (single :| []) = single :| []++pairTournamentTail :: [TournamentPlan value] -> [TournamentPlan value]+pairTournamentTail (left : right : rest) =+  TournamentNode left right : pairTournamentTail rest+pairTournamentTail rest = rest
+ src-dcel/Moonlight/Triangulation/Internal/Types.hs view
@@ -0,0 +1,470 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | The vocabulary: the types the surface names, none of which mentions the+-- stored representation.+module Moonlight.Triangulation.Internal.Types+  ( Point (..)+  , SiteRelation (..)+  , QueryPoint (..)+  , PointValidationError (..)+  , HasPosition (..)+  , ElementDefaults (..)+  , unitElementDefaults+  , ConstraintMode (..)+  , KnownConstraintMode (..)+  , InsertionDisposition (..)+  , BuildStats (..)+  , emptyBuildStats+  , ValidationClosureStats (..)+  , CoordinateError (..)+  , NonFiniteValue (..)+  , classifyNonFinite+  , RadiusSquared+  , RadiusSquaredError (..)+  , mkRadiusSquared+  , radiusSquaredValue+  , BuildError (..)+  , Location (..)+  , LocationHint (..)+  , LocationStats (..)+  , emptyLocationStats+  , NearestStats (..)+  , RefinementParameters (..)+  , defaultRefinementParameters+  , InvariantViolation (..)+  ) where++import Control.DeepSeq (NFData)+import Moonlight.Triangulation.Internal.HandleDefs+  ( DirectedEdgeId+  , FaceId+  , UndirectedEdgeId+  , VertexId+  )+import Data.Word (Word8)+import Foreign.Ptr (castPtr)+import Foreign.Storable (Storable (..), peekElemOff, pokeElemOff)+import GHC.Generics (Generic)+import Moonlight.Triangulation.Internal.BoxedPaged (BoxedStorageError)++-- | Type-level witness for whether constraint flags may be present.+data ConstraintMode = Unconstrained | Constrained+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Recover a type-level constraint mode as a value.+class KnownConstraintMode (mode :: ConstraintMode) where+  constraintModeValue :: proxy mode -> ConstraintMode++instance KnownConstraintMode 'Unconstrained where+  constraintModeValue _ = Unconstrained++instance KnownConstraintMode 'Constrained where+  constraintModeValue _ = Constrained++-- | Exact support visited by the selected topology-validation descent.  The+-- validator constructs this from its admitted closure sets; consumers do not+-- reconstruct it from a later receipt or a global mesh census.+data ValidationClosureStats = ValidationClosureStats+  { validationClosureFaces :: {-# UNPACK #-} !Int+  , validationClosureDirectedEdges :: {-# UNPACK #-} !Int+  , validationClosureVertices :: {-# UNPACK #-} !Int+  , validationClosureInterfacePairs :: {-# UNPACK #-} !Int+  , validationClosureConstraintPairs :: {-# UNPACK #-} !Int+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Cartesian binary64 point.+data Point = Point+  { pointX :: !Double+  , pointY :: !Double+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Exact geometric relation between two finite coordinate supports. The+-- overlap count is strictly positive in 'PartialOverlap'; equality, subset and+-- disjointness have already been excluded before that constructor is chosen.+data SiteRelation+  = -- | Both supports contain exactly the same coordinates.+    EqualSites+  | -- | Every left coordinate occurs on the right, which has at least one more.+    LeftProperSubset+  | -- | Every right coordinate occurs on the left, which has at least one more.+    RightProperSubset+  | -- | The supports share no coordinate.+    DisjointSites+  | -- | Neither support contains the other; the field is the positive number+    -- of coordinates they share.+    PartialOverlap {-# UNPACK #-} !Int+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | A coordinate pair admitted to the exact-predicate domain and normalized+-- at its construction boundary. Query algorithms consume this phase rather+-- than each inventing a fallback for invalid floating-point input.+newtype QueryPoint = QueryPoint+  { -- | The admitted, canonically normalized point.+    queryPointValue :: Point+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Coordinate axis and reason that kept a point outside the query domain.+data PointValidationError+  = InvalidPointX !CoordinateError+  | InvalidPointY !CoordinateError+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++instance Storable (Point) where+  sizeOf _ = 2 * sizeOf (0 :: Double)+  alignment _ = alignment (0 :: Double)+  peek pointer = do+    x <- peekElemOff (castPtr pointer) 0+    y <- peekElemOff (castPtr pointer) 1+    pure (Point x y)+  poke pointer (Point x y) = do+    pokeElemOff (castPtr pointer) 0 x+    pokeElemOff (castPtr pointer) 1 y++-- | Extract a vertex's position once, at the construction boundary.+class HasPosition vertex where+  position :: vertex -> Point++instance HasPosition (Point) where+  position = id++-- | Payloads inherited by topology elements created after initial loading.+data ElementDefaults directed undirected face = ElementDefaults+  { defaultDirectedEdgeData :: !directed+  , defaultUndirectedEdgeData :: !undirected+  , defaultFaceData :: !face+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Payload defaults for geometry-only triangulations.+unitElementDefaults :: ElementDefaults () () ()+unitElementDefaults = ElementDefaults () () ()++-- | Construction, location, legalization, and refinement work counters.+data BuildStats = BuildStats+  { statInputPoints :: {-# UNPACK #-} !Int+  , statUniquePoints :: {-# UNPACK #-} !Int+  , statExistingPoints :: {-# UNPACK #-} !Int+  , statDuplicatePoints :: {-# UNPACK #-} !Int+  , statSpatialSeedPoints :: {-# UNPACK #-} !Int+  , statFaceSplits :: {-# UNPACK #-} !Int+  , statInteriorEdgeSplits :: {-# UNPACK #-} !Int+  , statBoundaryEdgeSplits :: {-# UNPACK #-} !Int+  , statHullInsertions :: {-# UNPACK #-} !Int+  , statLineSplits :: {-# UNPACK #-} !Int+  , statLineExtensions :: {-# UNPACK #-} !Int+  , statLineToAreaTransitions :: {-# UNPACK #-} !Int+  , statEdgeFlips :: {-# UNPACK #-} !Int+  , statLocationWalkSteps :: {-# UNPACK #-} !Int+  , statLocationFallbacks :: {-# UNPACK #-} !Int+  , statLocationMaxWalk :: {-# UNPACK #-} !Int+  , statLegalizationMaxStack :: {-# UNPACK #-} !Int+  , statSteinerPoints :: {-# UNPACK #-} !Int+  , statRefinementFaceChecks :: {-# UNPACK #-} !Int+  , statRefinementQueuePops :: {-# UNPACK #-} !Int+  , statSweepFastPoints :: {-# UNPACK #-} !Int+  , statSweepSkippedPoints :: {-# UNPACK #-} !Int+  }+  deriving stock (Eq, Show, Read, Generic)+  deriving anyclass (NFData)++-- | The additive identity for construction telemetry.+emptyBuildStats :: BuildStats+emptyBuildStats =+  BuildStats+    { statInputPoints = 0+    , statUniquePoints = 0+    , statExistingPoints = 0+    , statDuplicatePoints = 0+    , statSpatialSeedPoints = 0+    , statFaceSplits = 0+    , statInteriorEdgeSplits = 0+    , statBoundaryEdgeSplits = 0+    , statHullInsertions = 0+    , statLineSplits = 0+    , statLineExtensions = 0+    , statLineToAreaTransitions = 0+    , statEdgeFlips = 0+    , statLocationWalkSteps = 0+    , statLocationFallbacks = 0+    , statLocationMaxWalk = 0+    , statLegalizationMaxStack = 0+    , statSteinerPoints = 0+    , statRefinementFaceChecks = 0+    , statRefinementQueuePops = 0+    , statSweepFastPoints = 0+    , statSweepSkippedPoints = 0+    }++-- | Whether an insertion published a new site or selected an existing one.+data InsertionDisposition = Inserted | AlreadyPresent+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Reason a floating-point coordinate cannot enter the exact-predicate domain.+data CoordinateError+  = CoordinateNaN+  | CoordinateInfinite+  | CoordinateTooSmall+  | CoordinateTooLarge+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Classification retained when a numeric parameter is not finite.+data NonFiniteValue+  = ValueNaN+  | ValuePositiveInfinity+  | ValueNegativeInfinity+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Classify NaN and signed infinity, leaving finite values unclassified.+classifyNonFinite :: Double -> Maybe NonFiniteValue+classifyNonFinite value+  | isNaN value = Just ValueNaN+  | isInfinite value && value < 0 = Just ValueNegativeInfinity+  | isInfinite value = Just ValuePositiveInfinity+  | otherwise = Nothing++-- | An admitted finite, non-negative squared radius. This belongs to the+-- shared geometric vocabulary because both circle queries and alpha+-- filtration consume it.+newtype RadiusSquared = RadiusSquared Double+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Typed refusal shared by every squared-radius consumer.+data RadiusSquaredError+  = NonFiniteRadiusSquared !NonFiniteValue+  | NegativeRadiusSquared !Double+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | 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)++-- | The admitted binary64 threshold.+radiusSquaredValue :: RadiusSquared -> Double+radiusSquaredValue (RadiusSquared value) = value++-- | Total construction and rewrite obstruction surface.+data BuildError+  = InvalidCoordinate !(Maybe Int) {-# UNPACK #-} !Double !CoordinateError+  | PointLocationFailed !(Point)+  | LocationWalkExhausted !(Point) {-# UNPACK #-} !Int+  | RefinementInputTopologyInvalid !InvariantViolation+  | SeamFrontierUnavailable+  | SeamSourceEdgeRequiresFlip !UndirectedEdgeId+  | FreshInsertionMatchedExistingVertex !VertexId !VertexId+  | DegenerateLineEndpointMissingOutgoing !VertexId+  | DegenerateLineEndpointTurnMissing {-# UNPACK #-} !Int+  | DegenerateLineConnectedVertexMissing {-# UNPACK #-} !Int+  | HullStartNotVisible !DirectedEdgeId+  | OuterRangeDidNotTerminate !DirectedEdgeId !DirectedEdgeId {-# UNPACK #-} !Int+  | OuterRangeContainsInnerEdge !DirectedEdgeId !FaceId+  | ConstrainedEdgeFlipRefused !UndirectedEdgeId+  | RemovalVertexOutOfRange !VertexId {-# UNPACK #-} !Int+  | RemovalEdgeOutOfRange !UndirectedEdgeId {-# UNPACK #-} !Int+  | RemovalFaceOutOfRange !FaceId {-# UNPACK #-} !Int+  | RemovalFaceCycleDidNotTerminate+      !FaceId+      !DirectedEdgeId+      {-# UNPACK #-} !Int+  | RemovalEmptyTriangulation !VertexId+  | RemovalTwoPointDegreeMismatch !VertexId {-# UNPACK #-} !Int+  | RemovalCollinearDegreeMismatch !VertexId {-# UNPACK #-} !Int+  | RemovalBorderTooShort {-# UNPACK #-} !Int+  | RemovalBorderArityMismatch {-# UNPACK #-} !Int+  | RemovalOutgoingCycleDidNotTerminate+      !VertexId+      !DirectedEdgeId+      {-# UNPACK #-} !Int+  | CircleSweepRequiresDenseStorage+  | CircleSweepHullEmpty+  | OuterCycleDidNotTerminate+      !DirectedEdgeId+      !DirectedEdgeId+      {-# UNPACK #-} !Int+  | HierarchyLevelPopulationMismatch+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+  | HierarchyInsertionHandleMismatch !VertexId !VertexId+  | PointIndexCapacityExhausted {-# UNPACK #-} !Int+  | RefinementMinimumAngleNotFinite !NonFiniteValue+  | RefinementMinimumAngleOutOfRange {-# UNPACK #-} !Double+  | RefinementMinimumAngleDerivedRatioNotFinite !NonFiniteValue+  | RefinementMaximumAdditionalVerticesNegative {-# UNPACK #-} !Int+  | RefinementMinimumAreaNotFinite !NonFiniteValue+  | RefinementMinimumAreaNegative {-# UNPACK #-} !Double+  | RefinementMaximumAreaNotFinite !NonFiniteValue+  | RefinementMaximumAreaNotPositive {-# UNPACK #-} !Double+  | RefinementMaximumRadiusEdgeRatioNotFinite !NonFiniteValue+  | RefinementMaximumRadiusEdgeRatioNotPositive {-# UNPACK #-} !Double+  | RefinementMaximumEdgeLengthNotFinite !NonFiniteValue+  | RefinementMaximumEdgeLengthNotPositive {-# UNPACK #-} !Double+  | RefinementMinimumAreaExceedsMaximum+      {-# UNPACK #-} !Double+      {-# UNPACK #-} !Double+  | RefinementSeedFaceNotActive !FaceId {-# UNPACK #-} !Int+  | RefinementDomainTopologyChanged+  | RefinementDomainRequiresConvexHullPreservation+  | RefinementDomainRequiresConstraintPreservation+  | RefinementDomainForbidsOuterFaceExclusion+  | RefinementDomainRequiresFiniteVertexBudget+  | RefinementSeamBridgeBudgetExceeded+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+  | RefinementSeamBridgeMidpointCollapsed !UndirectedEdgeId+  | BoundarySplitRequiresBoundaryEdge !UndirectedEdgeId+  | RefinementDomainWouldCrossInterface !UndirectedEdgeId !FaceId+  | RefinementDomainWouldRewriteProtectedFace !FaceId+  | RefinementDomainProtectedFaceChanged !FaceId+  | RefinementDomainInterfaceOppositeFaceNotPermitted !UndirectedEdgeId !FaceId+  | RefinementOversizedEdge+      !FaceId+      !UndirectedEdgeId+      {-# UNPACK #-} !Double+      {-# UNPACK #-} !Double+  | CapacityExceeded {-# UNPACK #-} !Int+  | HalfEdgeCapacityExceeded {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | FaceCapacityExceeded {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | PayloadStorageFailure !BoxedStorageError+  | CoordinatePayloadCountMismatch+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Exact position of a query relative to the finite triangulation.+data Location+  = EmptyTriangulation+  | OnVertex !VertexId+  | OnEdge !DirectedEdgeId+  | InFace !FaceId+  | OutsideConvexHull !(Maybe DirectedEdgeId)+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Optional starting cell for point-location descent.+data LocationHint+  = VertexHint !VertexId+  | FaceHint !FaceId+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Work performed by point-location descent.+data LocationStats = LocationStats+  { locationWalkSteps :: {-# UNPACK #-} !Int+  , locationUsedFallback :: !Bool+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Location telemetry for a query that required no descent.+emptyLocationStats :: LocationStats+emptyLocationStats = LocationStats 0 False++-- | Work performed by a nearest-neighbor query.+data NearestStats = NearestStats+  { nearestWalkSteps :: {-# UNPACK #-} !Int+  , nearestDistanceTests :: {-# UNPACK #-} !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Independent quality bounds and a finite Steiner-vertex budget.+data RefinementParameters = RefinementParameters+  { refineMaxAdditionalVertices :: !(Maybe Int)+  , refineMinArea :: !(Maybe Double)+  , refineMaxArea :: !(Maybe Double)+  , refineMaxRadiusEdgeRatio :: !(Maybe Double)+  , refineMaxEdgeLength :: !(Maybe Double)+  , refinePreserveConvexHull :: !Bool+  , refineKeepConstraintEdges :: !Bool+  , refineExcludeOuterFaces :: !Bool+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Conservative refinement defaults with no explicit area or edge bounds.+defaultRefinementParameters :: RefinementParameters+defaultRefinementParameters =+  RefinementParameters+    { refineMaxAdditionalVertices = Nothing+    , refineMinArea = Nothing+    , refineMaxArea = Nothing+    , refineMaxRadiusEdgeRatio = Just 1+    , refineMaxEdgeLength = Nothing+    , refinePreserveConvexHull = True+    , refineKeepConstraintEdges = False+    , refineExcludeOuterFaces = False+    }++-- | A concrete witness that an immutable DCEL law does not hold.+data InvariantViolation+  = CoordinatePlaneLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | VertexOutgoingLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | VertexPayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | TopologyArenaLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | DirectedPayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | UndirectedPayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | DirectedEdgeCountOdd {-# UNPACK #-} !Int+  | ConstraintLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | NonCanonicalConstraintFlag !UndirectedEdgeId !Word8+  | CachedConstraintCountMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | CachedConstraintIndexMismatch+  | MissingOuterFace+  | FacePayloadLengthMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | EdgeOriginOutOfRange !DirectedEdgeId !VertexId {-# UNPACK #-} !Int+  | EdgeNextOutOfRange !DirectedEdgeId !DirectedEdgeId {-# UNPACK #-} !Int+  | EdgePreviousOutOfRange !DirectedEdgeId !DirectedEdgeId {-# UNPACK #-} !Int+  | EdgeFaceOutOfRange !DirectedEdgeId !FaceId {-# UNPACK #-} !Int+  | VertexOutgoingOutOfRange !VertexId !DirectedEdgeId {-# UNPACK #-} !Int+  | FaceAdjacentOutOfRange !FaceId !DirectedEdgeId {-# UNPACK #-} !Int+  | EdgeNextPreviousMismatch !DirectedEdgeId !DirectedEdgeId+  | EdgePreviousNextMismatch !DirectedEdgeId !DirectedEdgeId+  | EdgeDoubleReversalMismatch !DirectedEdgeId+  | EdgeSelfLinkedNext !DirectedEdgeId+  | EdgeSelfLinkedPrevious !DirectedEdgeId+  | InnerFaceNotTriangularAtEdge !DirectedEdgeId+  | FaceMissingAdjacentEdge !FaceId+  | FaceRepresentativeMismatch !FaceId !DirectedEdgeId !FaceId+  | InnerFaceVertexCardinalityMismatch !FaceId {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | ConnectedVertexMissingOutgoing !VertexId+  | VertexOutgoingOriginMismatch !VertexId !DirectedEdgeId !VertexId+  | CollinearEdgeCountMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | EulerCharacteristicMismatch {-# UNPACK #-} !Int+  | InnerFaceNotCounterClockwise !FaceId+  | LocallyIllegalDelaunayEdge !UndirectedEdgeId+  | DelaunayIncidentFaceNotTriangular !UndirectedEdgeId+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)
+ src-dcel/Moonlight/Triangulation/Internal/Validation.hs view
@@ -0,0 +1,526 @@+-- | Discharge: the invariants the constructors guarantee, checkable on a value+-- built by any route.+module Moonlight.Triangulation.Internal.Validation+  ( validateTopology+  , ValidationClosureStats (..)+  , validateTopologyClosure+  , validateTopologyClosureWithStats+  , validateDelaunay+  , validateTriangulation+  , triangulationIsValid+  , faceArea+  , faceMinimumAngleDegrees+  ) where++import Data.List (nub)+import qualified Data.IntSet as IntSet+import Moonlight.Triangulation.Internal.BoxedPaged (boxedPagedLength)+import Moonlight.Triangulation.Internal.BoundaryCycle (orderedPair)+import Moonlight.Triangulation.Internal.Paged (pagedFoldl', pagedLength, pagedUnsafeIndex)+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (allFaces, directedEdges, undirectedEdges, vertices)+import Moonlight.Triangulation.Internal.PackedIndex (noIndex, unpackIndex)+import Moonlight.Triangulation.Internal.Predicates+import Moonlight.Triangulation.Math+  ( squaredDistance+  , triangleArea+  )+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types++-- | Every structural invariant violated, not the first.+validateTopology :: Triangulation mode vertex directed undirected face -> [InvariantViolation]+validateTopology triangulation =+  structuralViolations ++ orientationViolations+ where+  verticesCount = numVertices triangulation+  halfCount = numDirectedEdges triangulation+  edgeCount = numUndirectedEdges triangulation+  facesCount = numFaces triangulation++  -- Geometry descends only after the finite DCEL has glued structurally.+  -- Reading triangle coordinates through malformed links would turn a typed+  -- validation failure into an indexing crash.+  structuralViolations =+    cardinalityViolations+      ++ rangeViolations+      ++ edgeViolations+      ++ faceViolations+      ++ vertexViolations+      ++ eulerViolations++  orientationViolations+    | not (null structuralViolations) = []+    | otherwise =+        [ InnerFaceNotCounterClockwise face+        | face <- allFaces triangulation+        , face /= outerFace+        , Just (first, second, third) <- [innerFaceVertices triangulation face]+        , orient2d+            (vertexPoint triangulation first)+            (vertexPoint triangulation second)+            (vertexPoint triangulation third)+            /= GT+        ]++  cardinalityViolations =+    [ CoordinatePlaneLengthMismatch pointXCount pointYCount+    | pointXCount /= pointYCount+    ]+      ++ [VertexOutgoingLengthMismatch vertexOutCount verticesCount | vertexOutCount /= verticesCount]+      ++ [VertexPayloadLengthMismatch vertexPayloadCount verticesCount | vertexPayloadCount /= verticesCount]+      ++ [TopologyArenaLengthMismatch topologyLength (4 * halfCount) | not halfArraysEqual]+      ++ [DirectedPayloadLengthMismatch directedPayloadCount halfCount | directedPayloadCount /= halfCount]+      ++ [UndirectedPayloadLengthMismatch undirectedPayloadCount edgeCount | undirectedPayloadCount /= edgeCount]+      ++ [DirectedEdgeCountOdd halfCount | odd halfCount]+      ++ [ConstraintLengthMismatch constraintLength edgeCount | constraintLength /= edgeCount]+      ++ [ NonCanonicalConstraintFlag (UndirectedEdgeId (fromIntegral index)) flag+         | index <- [0 .. pagedLength (triConstraint triangulation) - 1]+         , let flag = pagedUnsafeIndex (triConstraint triangulation) index+         , flag /= 0 && flag /= 1+         ]+      ++ [CachedConstraintCountMismatch (triConstraintCount triangulation) actualConstraintCount | triConstraintCount triangulation /= actualConstraintCount]+      ++ [ CachedConstraintIndexMismatch+         | constraintLength == edgeCount+         , triConstraintEdges triangulation /= indexedConstraintEdges+         ]+      ++ [MissingOuterFace | facesCount == 0]+      ++ [FacePayloadLengthMismatch facePayloadCount facesCount | facePayloadCount /= facesCount]++  pointXCount = pagedLength (triPointX triangulation)+  pointYCount = pagedLength (triPointY triangulation)+  vertexOutCount = pagedLength (triVertexOut triangulation)+  vertexPayloadCount = boxedPagedLength (triVertexData triangulation)+  topologyLength = pagedLength (triHalfTopology triangulation)+  directedPayloadCount = boxedPagedLength (triDirectedData triangulation)+  undirectedPayloadCount = boxedPagedLength (triUndirectedData triangulation)+  constraintLength = pagedLength (triConstraint triangulation)+  facePayloadCount = boxedPagedLength (triFaceData triangulation)+  actualConstraintCount = pagedFoldl' (\count flag -> if flag == 1 then count + 1 else count) 0 (triConstraint triangulation)+  halfArraysEqual = topologyLength == 4 * halfCount++  indexedConstraintEdges =+    IntSet.fromAscList+      [ index+      | index <- [0 .. edgeCount - 1]+      , pagedUnsafeIndex (triConstraint triangulation) index == 1+      ]++  rangeViolations =+    [ EdgeOriginOutOfRange (DirectedEdgeId (fromIntegral index)) (VertexId value) verticesCount+    | index <- [0 .. halfCount - 1]+    , let value = pagedUnsafeIndex (triHalfTopology triangulation) (4 * index)+    , unpackIndex value >= verticesCount+    ]+      ++ [ EdgeNextOutOfRange (DirectedEdgeId (fromIntegral index)) (DirectedEdgeId value) halfCount+         | index <- [0 .. halfCount - 1]+         , let value = pagedUnsafeIndex (triHalfTopology triangulation) (4 * index + 1)+         , unpackIndex value >= halfCount+         ]+      ++ [ EdgePreviousOutOfRange (DirectedEdgeId (fromIntegral index)) (DirectedEdgeId value) halfCount+         | index <- [0 .. halfCount - 1]+         , let value = pagedUnsafeIndex (triHalfTopology triangulation) (4 * index + 2)+         , unpackIndex value >= halfCount+         ]+      ++ [ EdgeFaceOutOfRange (DirectedEdgeId (fromIntegral index)) (FaceId value) facesCount+         | index <- [0 .. halfCount - 1]+         , let value = pagedUnsafeIndex (triHalfTopology triangulation) (4 * index + 3)+         , unpackIndex value >= facesCount+         ]+      ++ [ VertexOutgoingOutOfRange (VertexId (fromIntegral index)) (DirectedEdgeId value) halfCount+         | index <- [0 .. pagedLength (triVertexOut triangulation) - 1]+         , let value = pagedUnsafeIndex (triVertexOut triangulation) index+         , value /= noIndex+         , unpackIndex value >= halfCount+         ]+      ++ [ FaceAdjacentOutOfRange (FaceId (fromIntegral index)) (DirectedEdgeId value) halfCount+         | index <- [0 .. facesCount - 1]+         , let value = pagedUnsafeIndex (triFaceEdge triangulation) index+         , value /= noIndex+         , unpackIndex value >= halfCount+         ]++  edgeViolations+    | not halfArraysEqual || odd halfCount || not (null rangeViolations) = []+    | otherwise = concatMap validateEdge (directedEdges triangulation)++  validateEdge edge =+    let index = directedEdgeIdIndex edge+        nextEdge = next triangulation edge+        previousEdge = previous triangulation edge+        twinEdge = reverseEdge edge+        local =+          [ EdgeNextPreviousMismatch edge nextEdge+          | validEdge nextEdge && previous triangulation nextEdge /= edge+          ]+            ++ [ EdgePreviousNextMismatch edge previousEdge+               | validEdge previousEdge && next triangulation previousEdge /= edge+               ]+            ++ [EdgeDoubleReversalMismatch edge | reverseEdge twinEdge /= edge]+            ++ [EdgeSelfLinkedNext edge | nextEdge == edge && halfCount > 2]+            ++ [EdgeSelfLinkedPrevious edge | previousEdge == edge && halfCount > 2]+        innerCycle =+          if incidentFace triangulation edge /= outerFace && validEdge nextEdge && validEdge previousEdge+            then+              [ InnerFaceNotTriangularAtEdge edge+              | next triangulation (next triangulation nextEdge) /= edge+              ]+            else []+     in if index < halfCount then local ++ innerCycle else []++  validEdge edge = directedEdgeIdIndex edge < halfCount++  faceViolations+    | not (null rangeViolations) = []+    | otherwise = concatMap validateFace (allFaces triangulation)+  validateFace face@(FaceId _) =+    case adjacentEdge triangulation face of+      Nothing+        | face == outerFace && halfCount == 0 -> []+        | otherwise -> [FaceMissingAdjacentEdge face]+      Just edge ->+        [ FaceRepresentativeMismatch face edge representedFace+        | let representedFace = incidentFace triangulation edge+        , representedFace /= face+        ]+          ++ [ InnerFaceVertexCardinalityMismatch face (length faceVertexIds) (length (nub faceVertexIds))+             | face /= outerFace+             , let faceVertexIds = faceVertices triangulation face+             , length faceVertexIds /= 3 || length (nub faceVertexIds) /= 3+             ]++  vertexViolations+    | vertexOutCount /= verticesCount || not (null rangeViolations) = []+    | otherwise = concatMap validateVertex (vertices triangulation)+  validateVertex vertex = case vertexOutEdge triangulation vertex of+    Nothing+      | verticesCount <= 1 -> []+      | otherwise -> [ConnectedVertexMissingOutgoing vertex]+    Just edge ->+      [ VertexOutgoingOriginMismatch vertex edge actualOrigin+      | let actualOrigin = origin triangulation edge+      , actualOrigin /= vertex+      ]++  eulerViolations+    | not (null cardinalityViolations) || verticesCount < 2 = []+    | numInnerFaces triangulation == 0 =+        [ CollinearEdgeCountMismatch (verticesCount - 1) edgeCount+        | edgeCount /= verticesCount - 1+        ]+    | otherwise =+        [ EulerCharacteristicMismatch eulerCharacteristic+        | eulerCharacteristic /= 2+        ]+   where+    eulerCharacteristic = verticesCount - edgeCount + facesCount++-- | Apply the same DCEL edge, face, vertex, and orientation laws as+-- 'validateTopology', but only to a certified local closure.  The caller+-- supplies the admitted inner faces and the interface pairs; the collar faces+-- on the other side of those pairs are included here so a protected source+-- cannot be changed behind the local transaction.  Cardinality and Euler+-- observations remain global scalar invariants and are deliberately not+-- rebuilt from the resident mesh.+validateTopologyClosure+  :: IntSet.IntSet+  -> IntSet.IntSet+  -> Triangulation mode vertex directed undirected face+  -> [InvariantViolation]+validateTopologyClosure admittedFaces interfacePairs triangulation =+  snd (validateTopologyClosureWithStats admittedFaces interfacePairs triangulation)++validateTopologyClosureWithStats+  :: IntSet.IntSet+  -> IntSet.IntSet+  -> Triangulation mode vertex directed undirected face+  -> (ValidationClosureStats, [InvariantViolation])+validateTopologyClosureWithStats admittedFaces interfacePairs triangulation =+  ( ValidationClosureStats+      { validationClosureFaces = IntSet.size selectedFaces+      , validationClosureDirectedEdges = IntSet.size selectedEdges+      , validationClosureVertices = IntSet.size selectedVertices+      , validationClosureInterfacePairs = IntSet.size interfacePairs+      , validationClosureConstraintPairs = IntSet.size selectedPairs+      }+  , rangeViolations ++ edgeViolations ++ faceViolations ++ vertexViolations ++ orientationViolations ++ constraintViolations+  )+ where+  verticesCount = numVertices triangulation+  halfCount = numDirectedEdges triangulation+  facesCount = numFaces triangulation++  collarFaces =+    IntSet.fromList+      [ rawFace+      | rawPair <- IntSet.toAscList interfacePairs+      , rawPair >= 0+      , rawPair < numUndirectedEdges triangulation+      , let edge = UndirectedEdgeId (fromIntegral rawPair)+      , let (forward, backward) = directedPair edge+      , rawFace <- fmap faceIdIndex [incidentFace triangulation forward, incidentFace triangulation backward]+      , rawFace > 0+      ]+  selectedFaces = IntSet.union admittedFaces collarFaces++  selectedFaceEdges =+    IntSet.fromList+      [ rawEdge+      | rawFace <- IntSet.toAscList selectedFaces+      , edge <- faceEdgesBounded (FaceId (fromIntegral rawFace))+      , rawEdge <- [directedEdgeIdIndex edge, directedEdgeIdIndex (reverseEdge edge)]+      ]+  selectedInterfaceEdges =+    IntSet.fromList+      [ rawEdge+      | rawPair <- IntSet.toAscList interfacePairs+      , rawPair >= 0+      , rawPair <= (maxBound - 1) `quot` 2+      , rawEdge <- [2 * rawPair, 2 * rawPair + 1]+      ]+  selectedEdges = IntSet.union selectedFaceEdges selectedInterfaceEdges+  selectedVertices =+    IntSet.fromList+      [ rawVertex+      | rawEdge <- IntSet.toAscList selectedEdges+      , rawEdge >= 0+      , rawEdge < halfCount+      , directedEdgeIdIndex (reverseEdge (DirectedEdgeId (fromIntegral rawEdge))) < halfCount+      , rawVertex <-+          [ vertexIdIndex (origin triangulation (DirectedEdgeId (fromIntegral rawEdge)))+          , vertexIdIndex (destination triangulation (DirectedEdgeId (fromIntegral rawEdge)))+          ]+      , rawVertex < verticesCount+      ]++  rangeViolations =+    [ EdgeOriginOutOfRange edge vertex verticesCount+    | rawEdge <- IntSet.toAscList selectedEdges+    , rawEdge >= 0+    , let edge = DirectedEdgeId (fromIntegral rawEdge)+    , rawEdge < halfCount+    , let vertex = origin triangulation edge+    , vertexIdIndex vertex >= verticesCount+    ]+      ++ [ EdgeNextOutOfRange edge nextEdge halfCount+         | rawEdge <- IntSet.toAscList selectedEdges+         , rawEdge >= 0+         , rawEdge < halfCount+         , let edge = DirectedEdgeId (fromIntegral rawEdge)+         , let nextEdge = next triangulation edge+         , directedEdgeIdIndex nextEdge >= halfCount+         ]+      ++ [ EdgePreviousOutOfRange edge previousEdge halfCount+         | rawEdge <- IntSet.toAscList selectedEdges+         , rawEdge >= 0+         , rawEdge < halfCount+         , let edge = DirectedEdgeId (fromIntegral rawEdge)+         , let previousEdge = previous triangulation edge+         , directedEdgeIdIndex previousEdge >= halfCount+         ]+      ++ [ EdgeFaceOutOfRange edge face facesCount+         | rawEdge <- IntSet.toAscList selectedEdges+         , rawEdge >= 0+         , rawEdge < halfCount+         , let edge = DirectedEdgeId (fromIntegral rawEdge)+         , let face = incidentFace triangulation edge+         , faceIdIndex face >= facesCount+         ]+      ++ [ FaceAdjacentOutOfRange face edge halfCount+         | rawFace <- IntSet.toAscList selectedFaces+         , rawFace > 0+         , rawFace < facesCount+         , let face = FaceId (fromIntegral rawFace)+         , Just edge <- [adjacentEdge triangulation face]+         , directedEdgeIdIndex edge >= halfCount+         ]++  edgeViolations =+    concatMap validateEdge (IntSet.toAscList selectedEdges)++  validateEdge rawEdge+    | rawEdge < 0 || rawEdge >= halfCount = []+    | otherwise =+        let edge = DirectedEdgeId (fromIntegral rawEdge)+            nextEdge = next triangulation edge+            previousEdge = previous triangulation edge+            twinEdge = reverseEdge edge+            nextValid = directedEdgeIdIndex nextEdge < halfCount+            previousValid = directedEdgeIdIndex previousEdge < halfCount+            nextNextValid = nextValid && directedEdgeIdIndex (next triangulation nextEdge) < halfCount+            innerCycle =+              if incidentFace triangulation edge /= outerFace && nextValid && previousValid && nextNextValid+                then [InnerFaceNotTriangularAtEdge edge | next triangulation (next triangulation nextEdge) /= edge]+                else []+         in [ EdgeNextPreviousMismatch edge nextEdge+            | nextValid && previous triangulation nextEdge /= edge+            ]+              ++ [ EdgePreviousNextMismatch edge previousEdge+                 | previousValid && next triangulation previousEdge /= edge+                 ]+              ++ [EdgeDoubleReversalMismatch edge | reverseEdge twinEdge /= edge]+              ++ [EdgeSelfLinkedNext edge | nextEdge == edge && halfCount > 2]+              ++ [EdgeSelfLinkedPrevious edge | previousEdge == edge && halfCount > 2]+              ++ innerCycle++  faceViolations = concatMap validateFace (IntSet.toAscList selectedFaces)++  validateFace rawFace+    | rawFace <= 0 || rawFace >= facesCount = []+    | otherwise =+      let face = FaceId (fromIntegral rawFace)+       in case adjacentEdge triangulation face of+          Nothing -> [FaceMissingAdjacentEdge face]+          Just edge+            | directedEdgeIdIndex edge >= halfCount -> []+            | otherwise ->+                let representedFace = incidentFace triangulation edge+                    (faceEdges, faceVertices') = triangleEdgesAndVertices face+                 in [FaceRepresentativeMismatch face edge representedFace | representedFace /= face]+                      ++ [ InnerFaceVertexCardinalityMismatch face (length faceVertices') (length (nub faceVertices'))+                         | rawFace > 0+                         , length faceVertices' /= 3 || length (nub faceVertices') /= 3+                         ]+                      ++ [InnerFaceNotTriangularAtEdge edge+                         | rawFace > 0+                         , not (triangleClosed faceEdges)+                         ]++  triangleEdgesAndVertices face =+    let edges = faceEdgesBounded face+        vertices' = fmap (vertexIdIndex . origin triangulation) edges+     in (edges, vertices')++  triangleClosed edges =+    case edges of+      [first, _, third] -> next triangulation third == first+      _ -> False++  vertexViolations = concatMap validateVertex (IntSet.toAscList selectedVertices)++  validateVertex rawVertex =+    let vertex = VertexId (fromIntegral rawVertex)+     in case vertexOutEdge triangulation vertex of+          Nothing+            | verticesCount > 1 -> [ConnectedVertexMissingOutgoing vertex]+            | otherwise -> []+          Just edge+            | directedEdgeIdIndex edge >= halfCount ->+                [VertexOutgoingOutOfRange vertex edge halfCount]+            | otherwise ->+                [ VertexOutgoingOriginMismatch vertex edge actualOrigin+                | let actualOrigin = origin triangulation edge+                , actualOrigin /= vertex+                ]++  orientationViolations =+    [ InnerFaceNotCounterClockwise face+    | rawFace <- IntSet.toAscList selectedFaces+    , rawFace > 0+    , let face = FaceId (fromIntegral rawFace)+    , let (_, vertices') = triangleEdgesAndVertices face+    , all (< verticesCount) vertices'+    , [first, second, third] <- [fmap (VertexId . fromIntegral) vertices']+    , orient2d (vertexPoint triangulation first) (vertexPoint triangulation second) (vertexPoint triangulation third) /= GT+    ]++  constraintViolations =+    [ NonCanonicalConstraintFlag edge flag+    | rawPair <- IntSet.toAscList selectedPairs+    , rawPair >= 0+    , let edge = UndirectedEdgeId (fromIntegral rawPair)+    , rawPair < numUndirectedEdges triangulation+    , let flag = pagedUnsafeIndex (triConstraint triangulation) rawPair+    , flag /= 0 && flag /= 1+    ]+      ++ [ CachedConstraintIndexMismatch+         | rawPair <- IntSet.toAscList selectedPairs+         , rawPair >= 0+         , rawPair < numUndirectedEdges triangulation+         , let flag = pagedUnsafeIndex (triConstraint triangulation) rawPair+         , (flag == 1) /= IntSet.member rawPair (triConstraintEdges triangulation)+         ]++  selectedPairs = IntSet.fromList [rawEdge `quot` 2 | rawEdge <- IntSet.toAscList selectedEdges]++  faceEdgesBounded face =+    case face of+      FaceId raw+        | toInteger raw <= 0 || toInteger raw >= toInteger facesCount -> []+      _ -> adjacentEdges+   where+    adjacentEdges = case adjacentEdge triangulation face of+      Nothing -> []+      Just start+        | directedEdgeIdIndex start >= halfCount -> []+        | otherwise ->+            let second = next triangulation start+             in if directedEdgeIdIndex second >= halfCount+                  then [start]+                  else+                    let third = next triangulation second+                     in if directedEdgeIdIndex third >= halfCount+                          then [start, second]+                          else [start, second, third]++-- | Every edge whose circumcircle is not empty.+validateDelaunay :: Triangulation mode vertex directed undirected face -> [InvariantViolation]+validateDelaunay triangulation = concatMap validateEdge (undirectedEdges triangulation)+ where+  validateEdge edge+    | isConstraintEdge triangulation edge = []+    | isBoundaryEdge triangulation edge = []+    | otherwise =+        let directed = normalizedDirected edge+            twin = reverseEdge directed+         in case (innerFaceDirectedEdges triangulation (incidentFace triangulation directed), innerFaceDirectedEdges triangulation (incidentFace triangulation twin)) of+              (Just _, Just _) ->+                let a = vertexPoint triangulation (origin triangulation directed)+                    b = vertexPoint triangulation (destination triangulation directed)+                    c = vertexPoint triangulation (origin triangulation (previous triangulation directed))+                    d = vertexPoint triangulation (origin triangulation (previous triangulation twin))+                    convex = orient2d c d b == GT && orient2d d c a == GT+                    circle = inCircle a b c d+                    illegal = convex && (circle == GT || (circle == EQ && orderedPair c d < orderedPair a b))+                 in [LocallyIllegalDelaunayEdge edge | illegal]+              _ -> [DelaunayIncidentFaceNotTriangular edge]++-- | Topology first; the Delaunay property only if the topology holds.+validateTriangulation+  :: Triangulation mode vertex directed undirected face+  -> [InvariantViolation]+validateTriangulation triangulation =+  let topology = validateTopology triangulation+   in if null topology+        then validateDelaunay triangulation+        else topology++-- | Whether 'validateTriangulation' is empty.+triangulationIsValid+  :: Triangulation mode vertex directed undirected face+  -> Bool+triangulationIsValid = null . validateTriangulation++-- | Signed area, or 'Nothing' where the face is not a triangle.+faceArea :: Triangulation mode vertex directed undirected face -> FaceId -> Maybe Double+faceArea triangulation face = do+  (v0, v1, v2) <- innerFaceVertices triangulation face+  pure (triangleArea (vertexPoint triangulation v0) (vertexPoint triangulation v1) (vertexPoint triangulation v2))++-- | Smallest interior angle, in degrees.+faceMinimumAngleDegrees :: Triangulation mode vertex directed undirected face -> FaceId -> Maybe Double+faceMinimumAngleDegrees triangulation face = do+  (v0, v1, v2) <- innerFaceVertices triangulation face+  let p0 = vertexPoint triangulation v0+      p1 = vertexPoint triangulation v1+      p2 = vertexPoint triangulation v2+      a = sqrt (squaredDistance p1 p2)+      b = sqrt (squaredDistance p2 p0)+      c = sqrt (squaredDistance p0 p1)+  if min a (min b c) <= 0+    then Nothing+    else Just (minimum [angle b c a, angle c a b, angle a b c])+ where+  angle left right opposite = acos (clamp ((left * left + right * right - opposite * opposite) / (2 * left * right))) * 180 / pi+  clamp = max (-1) . min 1
+ src-dcel/Moonlight/Triangulation/Interop.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE FlexibleInstances #-}++-- | Boundary conversions between Moonlight points and common coordinate pairs.+module Moonlight.Triangulation.Interop+  ( Coordinate2 (..)+  , mapCoordinate2+  ) where++import Data.Complex (Complex ((:+)))+import Moonlight.Triangulation.Types (Point (..))++-- | Minimal mint-like interchange class. It owns no geometry and introduces no+-- second point representation inside the triangulation; conversion happens only+-- at an ecosystem boundary.+class Coordinate2 value where+  toPoint :: value -> Point+  fromPoint :: Point -> value++instance Coordinate2 (Point) where+  toPoint = id+  fromPoint = id++instance Coordinate2 (Double, Double) where+  toPoint (x, y) = Point x y+  fromPoint (Point x y) = (x, y)++instance Coordinate2 (Complex Double) where+  toPoint (x :+ y) = Point x y+  fromPoint (Point x y) = x :+ y++-- | Transform a coordinate through the canonical 'Point' representation.+mapCoordinate2+  :: (Coordinate2 input, Coordinate2 output)+  => (Point -> Point)+  -> input+  -> output+mapCoordinate2 transform = fromPoint . transform . toPoint
+ src-dcel/Moonlight/Triangulation/IntersectionIterator.hs view
@@ -0,0 +1,465 @@+{-# LANGUAGE BangPatterns #-}++-- | Ordered traversal of the mesh features met by a line segment.+module Moonlight.Triangulation.IntersectionIterator+  ( Intersection (..)+  , lineIntersections+  , lineIntersectionsBetweenVertices+  , foldCorridorBetweenPoints+  , foldCorridorBetweenVertices+  , conflictingEdges+  , segmentIntersectsNonCollinear+  ) where++import Data.List (sortBy)+import Data.Maybe (mapMaybe)+import Data.Ord (comparing)+import Data.Void (Void, absurd)+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Internal.Predicates+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (undirectedEdges, vertices)+import Moonlight.Triangulation.Math+  ( projectionFactor+  , squaredDistanceWide+  )+import Moonlight.Triangulation.PointLocation+import Moonlight.Triangulation.Types++-- | One crossing: an edge cut, a vertex hit, or a collinear overlap.+data Intersection+  = EdgeIntersection !DirectedEdgeId+  | VertexIntersection !VertexId+  | EdgeOverlap !DirectedEdgeId+  deriving stock (Eq, Ord, Show)++-- | Every crossing between two points, ordered along the segment.+lineIntersections+  :: Triangulation mode vertex directed undirected face+  -> QueryPoint+  -> QueryPoint+  -> [Intersection]+lineIntersections triangulation queryFrom queryTo =+  let !from = queryPointValue queryFrom+      !to = queryPointValue queryTo+   in if endpointNearerToWalkSeed triangulation to from+        then case firstIntersection triangulation queryTo queryFrom of+          Nothing -> []+          Just first -> walkIntersections AgainstQuery triangulation to from first+        else case firstIntersection triangulation queryFrom queryTo of+          Nothing -> []+          Just first -> walkIntersections AlongQuery triangulation from to first++-- | 'lineIntersections' between two existing vertices.+lineIntersectionsBetweenVertices :: Triangulation mode vertex directed undirected face -> VertexId -> VertexId -> [Intersection]+lineIntersectionsBetweenVertices triangulation fromVertex toVertex =+  let from = vertexPoint triangulation fromVertex+      to = vertexPoint triangulation toVertex+   in walkIntersections AlongQuery triangulation from to (VertexIntersection fromVertex)++-- | The directed edges a crossing list cuts.+conflictingEdges :: [Intersection] -> [DirectedEdgeId]+conflictingEdges = mapMaybe asConflict+ where+  asConflict (EdgeIntersection edge) = Just edge+  asConflict _ = Nothing++-- | Fold the corridor one crossing at a time, stopping the instant the step+-- function answers.+--+-- The list-producing walks cannot stop early: their step budget is only known+-- to have been respected once the walk ends, so the whole corridor is+-- materialized before the first event is visible. A caller whose answer is+-- settled by a prefix — anything asking whether some crossing exists — should+-- not pay for the suffix. 'Nothing' reports a walk that outran its budget and+-- is the caller's signal to fall back to the materialized walk, which+-- substitutes the exact scan.+foldCorridorBetweenVertices+  :: Triangulation mode vertex directed undirected face+  -> VertexId+  -> VertexId+  -> (state -> Intersection -> Either answer state)+  -> state+  -> Maybe (Either answer state)+foldCorridorBetweenVertices triangulation fromVertex toVertex =+  foldCorridor+    triangulation+    (vertexPoint triangulation fromVertex)+    (vertexPoint triangulation toVertex)+    (VertexIntersection fromVertex)++-- | As 'foldCorridorBetweenVertices', for a corridor given by its endpoints.+-- A segment that meets nothing at all folds to the initial state.+foldCorridorBetweenPoints+  :: Triangulation mode vertex directed undirected face+  -> QueryPoint+  -> QueryPoint+  -> (state -> Intersection -> Either answer state)+  -> state+  -> Maybe (Either answer state)+foldCorridorBetweenPoints triangulation queryFrom queryTo step state =+  case firstIntersection triangulation queryFrom queryTo of+    Nothing -> Just (Right state)+    Just first ->+      foldCorridor+        triangulation+        (queryPointValue queryFrom)+        (queryPointValue queryTo)+        first+        step+        state++foldCorridor+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> Point+  -> Intersection+  -> (state -> Intersection -> Either answer state)+  -> state+  -> Maybe (Either answer state)+foldCorridor triangulation from to first step =+  go (2 * numDirectedEdges triangulation + numVertices triangulation + 8) first+ where+  go !remaining !current !state+    | remaining <= 0 = Nothing+    | otherwise = case step state current of+        Left answer -> Just (Left answer)+        Right advanced ->+          case nextIntersection triangulation from to current of+            Nothing -> Just (Right advanced)+            Just following -> go (remaining - 1) following advanced+-- The early-answer 'Either' exists to let a caller stop at the first event it+-- cares about; it should not survive to runtime. Inlining the non-recursive+-- wrapper puts the worker at each call site with 'step' statically known, so+-- the constructor is matched where it is built — and at 'walkIntersections',+-- where the answer is 'Void', the left branch is erased outright.+{-# INLINE foldCorridor #-}++data QueryDirection = AlongQuery | AgainstQuery++walkIntersections+  :: QueryDirection+  -> Triangulation mode vertex directed undirected face+  -> Point+  -> Point+  -> Intersection+  -> [Intersection]+walkIntersections direction triangulation from to first =+  case foldCorridor triangulation from to first collect [] of+    Nothing -> orientExact (exactIntersectionScan triangulation from to)+    Just (Left impossible) -> absurd impossible+    Just (Right events) -> orientCollected events+ where+  collect :: [Intersection] -> Intersection -> Either Void [Intersection]+  collect accumulated event = Right (event : accumulated)+  orientExact = case direction of+    AlongQuery -> id+    AgainstQuery -> map reverseIntersection . reverse+  orientCollected = case direction of+    AlongQuery -> reverse+    AgainstQuery -> map reverseIntersection++reverseIntersection :: Intersection -> Intersection+reverseIntersection event = case event of+  VertexIntersection vertex -> VertexIntersection vertex+  EdgeIntersection edge -> EdgeIntersection (reverseEdge edge)+  EdgeOverlap edge -> EdgeOverlap (reverseEdge edge)++-- The unhinted point locator starts at face one. Choosing the segment endpoint+-- decisively nearer one of that face's vertices shortens the same exact walk+-- without making ordinary interior chords pay to reverse similar paths.+endpointNearerToWalkSeed+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> Point+  -> Bool+endpointNearerToWalkSeed triangulation candidate incumbent =+  case innerFaceVertices triangulation (FaceId 1) of+    Just (anchor, _, _) ->+      let !seed = vertexPoint triangulation anchor+       in 4 * squaredDistanceWide seed candidate < squaredDistanceWide seed incumbent+    Nothing -> False++nextIntersection :: Triangulation mode vertex directed undirected face -> Point -> Point -> Intersection -> Maybe Intersection+nextIntersection triangulation lineFrom lineTo current = case current of+  EdgeIntersection edge -> case traceDirectionOutOfEdge triangulation edge lineFrom lineTo of+    EdgeOutHull -> Nothing+    EdgeOutVertex vertex -> Just (VertexIntersection vertex)+    EdgeOutEdge nextEdge -> Just (EdgeIntersection nextEdge)+    EdgeOutNone -> Nothing+  VertexIntersection vertex+    | vertexPoint triangulation vertex == lineTo -> Nothing+    | otherwise -> case traceDirectionOutOfVertex triangulation vertex lineTo of+        VertexOutHull -> Nothing+        VertexOutOverlap edge -> Just (EdgeOverlap edge)+        VertexOutEdge edge ->+          let from = vertexPoint triangulation (origin triangulation edge)+              to = vertexPoint triangulation (destination triangulation edge)+           in if orient2d from to lineTo == LT then Nothing else Just (EdgeIntersection edge)+  EdgeOverlap edge+    | lineFrom == lineTo -> Nothing+    | onClosedSegment lineFrom lineTo (vertexPoint triangulation (destination triangulation edge)) ->+        Just (VertexIntersection (destination triangulation edge))+    | otherwise -> Nothing++firstIntersection :: Triangulation mode vertex directed undirected face -> QueryPoint -> QueryPoint -> Maybe Intersection+firstIntersection triangulation queryFrom queryTo =+  case locatePoint triangulation queryFrom of+    EmptyTriangulation -> singleVertexHit+    OnVertex vertex -> Just (VertexIntersection vertex)+    OnEdge edge -> Just (classifyStartingEdge edge)+    InFace face -> firstFromFace face+    OutsideConvexHull entry -> firstFromOutside entry+ where+  !lineFrom = queryPointValue queryFrom+  !lineTo = queryPointValue queryTo+  singleVertexHit = case vertices triangulation of+    [vertex]+      | onClosedSegment lineFrom lineTo (vertexPoint triangulation vertex) -> Just (VertexIntersection vertex)+    _ -> Nothing++  classifyStartingEdge edge =+    let a = vertexPoint triangulation (origin triangulation edge)+        b = vertexPoint triangulation (destination triangulation edge)+     in if orient2d lineFrom lineTo a == EQ && orient2d lineFrom lineTo b == EQ+          then EdgeOverlap (orientAlongLine edge)+          else EdgeIntersection (orientTowardTarget edge)++  firstFromFace face = firstEdgeFromRing (faceDirectedEdges triangulation face)++  firstEdgeFromRing [] = Nothing+  firstEdgeFromRing (edge : remaining) =+    let a = vertexPoint triangulation (origin triangulation edge)+        b = vertexPoint triangulation (destination triangulation edge)+     in if segmentIntersectsNonCollinear lineFrom lineTo a b+          then+            if orient2d lineFrom lineTo a == EQ+              then Just (VertexIntersection (origin triangulation edge))+              else+                if orient2d lineFrom lineTo b == EQ+                  then Just (VertexIntersection (destination triangulation edge))+                  else Just (EdgeIntersection (reverseEdge edge))+          else firstEdgeFromRing remaining++  -- Outside the region the segment's first contact with it lies on the ring+  -- the locator's edge sits on, so only that ring can carry the earliest+  -- event. A ring that outran its budget, an absent locator edge, and+  -- endpoints that leave the parameter comparison without a total order all+  -- keep the exact scan.+  firstFromOutside (Just edge) =+    case hullEntryIntersection triangulation lineFrom lineTo edge of+      Just entry -> entry+      Nothing -> firstFromScan+  firstFromOutside _ = firstFromScan++  firstFromScan = case exactIntersectionScan triangulation lineFrom lineTo of+    event : _ -> Just event+    [] -> Nothing++  orientAlongLine edge =+    let a = vertexPoint triangulation (origin triangulation edge)+        b = vertexPoint triangulation (destination triangulation edge)+     in if projectionFactor lineFrom lineTo a <= projectionFactor lineFrom lineTo b then edge else reverseEdge edge++  orientTowardTarget edge =+    let a = vertexPoint triangulation (origin triangulation edge)+        b = vertexPoint triangulation (destination triangulation edge)+     in if orient2d a b lineTo == LT then reverseEdge edge else edge++data VertexOut+  = VertexOutHull+  | VertexOutOverlap !DirectedEdgeId+  | VertexOutEdge !DirectedEdgeId++data EdgeOut+  = EdgeOutHull+  | EdgeOutVertex !VertexId+  | EdgeOutEdge !DirectedEdgeId+  | EdgeOutNone++traceDirectionOutOfVertex :: Triangulation mode vertex directed undirected face -> VertexId -> Point -> VertexOut+traceDirectionOutOfVertex triangulation vertex target =+  case vertexOutEdge triangulation vertex of+    Nothing -> VertexOutHull+    Just start ->+      let !startSide = sideOf start+          !rotateCounterClockwise = startSide == GT+       in go rotateCounterClockwise (numDirectedEdges triangulation + 1) start startSide+ where+  go !rotateCounterClockwise !remaining !current !currentSide+    | remaining <= 0 = VertexOutHull+    | currentSide == EQ && projectionFactor currentPoint (edgeTarget current) target >= 0 =+        VertexOutOverlap current+    | otherwise =+        let following = if rotateCounterClockwise then counterClockwise triangulation current else clockwise triangulation current+            followingSide = sideOf following+         in if followingSide == EQ && projectionFactor currentPoint (edgeTarget following) target >= 0+              then VertexOutOverlap following+              else+                let faceBetween = if rotateCounterClockwise then incidentFace triangulation current else incidentFace triangulation following+                 in if faceBetween == outerFace+                      then VertexOutHull+                      else+                        if rotateCounterClockwise == (followingSide == LT)+                          then+                            let segment = if rotateCounterClockwise then next triangulation current else previous triangulation (reverseEdge current)+                             in VertexOutEdge (reverseEdge segment)+                          else go rotateCounterClockwise (remaining - 1) following followingSide++  currentPoint = vertexPoint triangulation vertex+  edgeTarget edge = vertexPoint triangulation (destination triangulation edge)+  sideOf edge = orient2d currentPoint (edgeTarget edge) target++traceDirectionOutOfEdge :: Triangulation mode vertex directed undirected face -> DirectedEdgeId -> Point -> Point -> EdgeOut+traceDirectionOutOfEdge triangulation edge lineFrom lineTo+  | incidentFace triangulation edge == outerFace = EdgeOutHull+  | otherwise =+      case (previousIntersects, nextIntersects) of+        (True, False) -> EdgeOutEdge (reverseEdge edgePrevious)+        (False, True) -> EdgeOutEdge (reverseEdge edgeNext)+        (True, True) -> EdgeOutVertex (origin triangulation edgePrevious)+        (False, False) -> EdgeOutNone+ where+  edgePrevious = previous triangulation edge+  edgeNext = next triangulation edge++  -- The face runs @edge@ A->B, @edgeNext@ B->C, @edgePrevious@ C->A, so the+  -- two candidates share C and each vertex's side of the line is read once+  -- rather than once per candidate. Whether the segment reaches a candidate is+  -- then asked only of one the line already separates, and a walk that entered+  -- across A->B leaves that true for exactly one of the two.+  pointA = vertexPoint triangulation (origin triangulation edge)+  pointB = vertexPoint triangulation (origin triangulation edgeNext)+  pointC = vertexPoint triangulation (origin triangulation edgePrevious)++  sideA = orient2d lineFrom lineTo pointA+  sideB = orient2d lineFrom lineTo pointB+  sideC = orient2d lineFrom lineTo pointC++  previousIntersects = sideC /= sideA && reaches pointC pointA+  nextIntersects = sideB /= sideC && reaches pointB pointC++  reaches from to = orient2d from to lineFrom /= orient2d from to lineTo++-- | Whether two segments properly cross; collinear touching does not.+segmentIntersectsNonCollinear :: Point -> Point -> Point -> Point -> Bool+segmentIntersectsNonCollinear p0 p1 q0 q1 =+  -- Equality admits an endpoint on the opposite segment; four equal sides+  -- reject the collinear case without recomputing either orientation pair.+  p0Side /= p1Side+    && q0Side /= q1Side+ where+  !p0Side = orient2d q0 q1 p0+  !p1Side = orient2d q0 q1 p1+  !q0Side = orient2d p0 p1 q0+  !q1Side = orient2d p0 p1 q1+{-# INLINE segmentIntersectsNonCollinear #-}++exactIntersectionScan :: Triangulation mode vertex directed undirected face -> Point -> Point -> [Intersection]+exactIntersectionScan triangulation lineFrom lineTo =+  map eventValue . sortBy compareEvent $ vertexEvents ++ edgeEvents+ where+  vertexEvents = mapMaybe (vertexEvent triangulation lineFrom lineTo) (vertices triangulation)+  edgeEvents = mapMaybe (edgeEvent triangulation lineFrom lineTo) (undirectedEdges triangulation)++data Event = Event+  { eventParameter :: !Double+  , eventPriority :: {-# UNPACK #-} !Int+  , eventValue :: !Intersection+  }++compareEvent :: Event -> Event -> Ordering+compareEvent = comparing (\event -> (eventParameter event, eventPriority event, eventValue event))++-- Ties in this order are the same 'Intersection', so a traversal that reaches+-- the minimum by a different route still reports the value the sorted scan's+-- head reports.+vertexEvent+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> Point+  -> VertexId+  -> Maybe (Event)+vertexEvent triangulation lineFrom lineTo vertex+  | onClosedSegment lineFrom lineTo point = Just (Event (projectionFactor lineFrom lineTo point) 0 (VertexIntersection vertex))+  | otherwise = Nothing+ where+  point = vertexPoint triangulation vertex++edgeEvent+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> Point+  -> UndirectedEdgeId+  -> Maybe (Event)+edgeEvent triangulation lineFrom lineTo edge+  | oa == EQ && ob == EQ =+      if low < high+        then Just (Event low 1 (EdgeOverlap (if projectedA <= projectedB then directed else reverseEdge directed)))+        else Nothing+  | segmentsIntersect lineFrom lineTo a b && oa /= EQ && ob /= EQ =+      Just (Event (segmentIntersectionParameter lineFrom lineTo a b) 2 (EdgeIntersection oriented))+  | otherwise = Nothing+ where+  directed = normalizedDirected edge+  a = vertexPoint triangulation (origin triangulation directed)+  b = vertexPoint triangulation (destination triangulation directed)+  oa = orient2d lineFrom lineTo a+  ob = orient2d lineFrom lineTo b+  projectedA = projectionFactor lineFrom lineTo a+  projectedB = projectionFactor lineFrom lineTo b+  low = max 0 (min projectedA projectedB)+  high = min 1 (max projectedA projectedB)+  oriented = if orient2d a b lineTo == LT then reverseEdge directed else directed++-- | Restrict an outside segment to the hull edge supplied by point location,+-- then follow only the side on which its entry can lie. The outer 'Maybe'+-- witnesses a hull walk that closed within its topology budget; the inner one+-- is the geometric answer. An exhausted or impossible local section descends+-- to the exact scan owned by 'firstIntersection'.+hullEntryIntersection+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> Point+  -> DirectedEdgeId+  -> Maybe (Maybe Intersection)+hullEntryIntersection triangulation lineFrom lineTo entry+  | orient2d entryFrom entryTo lineFrom == EQ =+      Just+        ( Just+            ( VertexIntersection+                ( if squaredDistanceWide entryTo lineFrom < squaredDistanceWide entryFrom lineFrom+                    then destination triangulation entry+                    else origin triangulation entry+                )+            )+        )+  | otherwise = go (numDirectedEdges triangulation + 1) entry+ where+  entryFrom = vertexPoint triangulation (origin triangulation entry)+  entryTo = vertexPoint triangulation (destination triangulation entry)++  go !remaining !edge+    | remaining <= 0 = Nothing+    | otherwise =+        let !edgeFrom = vertexPoint triangulation (origin triangulation edge)+            !edgeTo = vertexPoint triangulation (destination triangulation edge)+            !fromSide = orient2d lineFrom lineTo edgeFrom+            !toSide = orient2d lineFrom lineTo edgeTo+         in if orient2d edgeFrom edgeTo lineTo == GT+              then Just Nothing+              else case (fromSide == GT, toSide /= LT) of+                (True, True) -> go (remaining - 1) (previous triangulation edge)+                (False, False) -> go (remaining - 1) (next triangulation edge)+                (False, True)+                  | toSide == EQ -> Just (Just (VertexIntersection (destination triangulation edge)))+                  | fromSide == EQ -> Just (Just (VertexIntersection (origin triangulation edge)))+                  | otherwise -> Just (Just (EdgeIntersection (reverseEdge edge)))+                (True, False) -> Nothing++segmentIntersectionParameter :: Point -> Point -> Point -> Point -> Double+segmentIntersectionParameter (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy)+  | denominator == 0 = 0+  | otherwise = ((cx - ax) * (dy - cy) - (cy - ay) * (dx - cx)) / denominator+ where+  denominator = (bx - ax) * (dy - cy) - (by - ay) * (dx - cx)
+ src-dcel/Moonlight/Triangulation/JoinSemilattice.hs view
@@ -0,0 +1,20 @@+-- | Payloads that can be glued coordinate-wise when triangulation site sets+-- overlap. The laws are the contract: implementations must be commutative,+-- associative, and idempotent.+module Moonlight.Triangulation.JoinSemilattice+  ( JoinSemilattice (..)+  ) where++-- | A join-semilattice carried by vertex annotations.+--+-- @+-- joinAnnotations left right == joinAnnotations right left+-- joinAnnotations (joinAnnotations a b) c == joinAnnotations a (joinAnnotations b c)+-- joinAnnotations value value == value+-- @+class Eq annotation => JoinSemilattice annotation where+  joinAnnotations :: annotation -> annotation -> annotation++instance JoinSemilattice () where+  joinAnnotations _ _ = ()+  {-# INLINE joinAnnotations #-}
+ src-dcel/Moonlight/Triangulation/Math.hs view
@@ -0,0 +1,446 @@+{-# LANGUAGE BangPatterns #-}++-- | Robust planar predicates and derived Euclidean constructions.+module Moonlight.Triangulation.Math+  ( orient2d+  , sideQuery+  , inCircle+  , orientDetApprox+  , inCircleDetApprox+  , onClosedSegment+  , SegmentRelation (..)+  , allSegmentRelations+  , segmentRelation+  , segmentsProperlyCross+  , segmentsIntersect+  , squaredDistance+  , squaredDistanceWide+  , segmentDistanceSquared+  , segmentDistanceSquaredWide+  , distance+  , negateVector+  , normalizeVector+  , midpoint+  , centroid+  , triangleArea+  , triangleRadiusEdgeRatio+  , triangleRadiusEdgeRatioSquaredWithArea+  , triangleRadiusEdgeRatioSquaredWithAreaAndSides+  , circumcenter+  , barycentricCoordinates+  , inDiametralCircle+  , projectionFactor+  , canonicalPoint+  , canonicalCoordinate+  , validateCoordinate+  , mkQueryPoint+  , validatePoint+  , mitigateUnderflow+  , isFinite+  ) where++import Moonlight.Triangulation.Internal.Dyadic+  ( exactBarycentricDeterminants+  , integerRatioToDouble+  )+import Moonlight.Triangulation.Internal.Predicates qualified as Admitted+import Moonlight.Triangulation.Internal.SegmentRelation+  ( SegmentRelation (..)+  , allSegmentRelations+  )+import Moonlight.Triangulation.LineSideInfo (LineSideInfo)+import Moonlight.Triangulation.Scalar+  ( canonicalScalarZero+  , isFinite+  , maximumAllowedCoordinate+  , minimumAllowedCoordinate+  , scalarCcwErrorBound+  )+import Moonlight.Triangulation.Internal.Types+  ( BuildError (..)+  , CoordinateError (..)+  , Point (..)+  , PointValidationError (..)+  , QueryPoint (..)+  )++-- | Exact relation between two admitted closed segments.+segmentRelation+  :: QueryPoint+  -> QueryPoint+  -> QueryPoint+  -> QueryPoint+  -> SegmentRelation+segmentRelation firstFrom firstTo secondFrom secondTo =+  Admitted.segmentRelation+    (queryPointValue firstFrom)+    (queryPointValue firstTo)+    (queryPointValue secondFrom)+    (queryPointValue secondTo)++-- | Whether two admitted closed segments share any point.+segmentsIntersect+  :: QueryPoint+  -> QueryPoint+  -> QueryPoint+  -> QueryPoint+  -> Bool+segmentsIntersect firstFrom firstTo secondFrom secondTo =+  Admitted.segmentsIntersect+    (queryPointValue firstFrom)+    (queryPointValue firstTo)+    (queryPointValue secondFrom)+    (queryPointValue secondTo)++-- | The proper-crossing section of 'segmentRelation'. Consumers which reject+-- only that constructor need not compute the collinear and endpoint-touch+-- distinctions required by the complete ADT after either side already proves+-- separation.+segmentsProperlyCross+  :: QueryPoint+  -> QueryPoint+  -> QueryPoint+  -> QueryPoint+  -> Bool+segmentsProperlyCross firstFrom firstTo secondFrom secondTo =+  Admitted.segmentsProperlyCross+    (queryPointValue firstFrom)+    (queryPointValue firstTo)+    (queryPointValue secondFrom)+    (queryPointValue secondTo)++-- | Classify a coordinate outside the exact-predicate input domain.+validateCoordinate :: Double -> Maybe CoordinateError+validateCoordinate value+  | isNaN value = Just CoordinateNaN+  | isInfinite value = Just CoordinateInfinite+  | value /= 0 && abs value < minimumAllowedCoordinate = Just CoordinateTooSmall+  | abs value > maximumAllowedCoordinate = Just CoordinateTooLarge+  | otherwise = Nothing++-- | Admit and normalize a finite point for read-only geometric queries.+mkQueryPoint :: Point -> Either PointValidationError (QueryPoint)+mkQueryPoint point@(Point x y) = do+  maybe (Right ()) (Left . InvalidPointX) (validateCoordinate x)+  maybe (Right ()) (Left . InvalidPointY) (validateCoordinate y)+  Right (QueryPoint (canonicalPoint point))++-- | Validate a construction point while retaining its optional input slot.+validatePoint :: Maybe Int -> Point -> Either BuildError (QueryPoint)+validatePoint slot point@(Point x y) =+  case mkQueryPoint point of+    Left (InvalidPointX reason) -> Left (InvalidCoordinate slot x reason)+    Left (InvalidPointY reason) -> Left (InvalidCoordinate slot y reason)+    Right queryPoint -> Right queryPoint++-- | Round coordinates below the robust-predicate input floor toward zero.+-- The operation never changes a coordinate already accepted by+-- 'validateCoordinate'.+mitigateUnderflow :: Point -> Point+mitigateUnderflow (Point x y) = Point (mitigate x) (mitigate y)+ where+  mitigate :: Double -> Double+  mitigate value+    | value /= 0 && abs value < minimumAllowedCoordinate = 0+    | otherwise = value++-- | Canonicalize both coordinate components for point identity.+canonicalPoint :: Point -> Point+canonicalPoint (Point x y) = Point (canonicalCoordinate x) (canonicalCoordinate y)+{-# INLINE canonicalPoint #-}++-- | Round a signed zero to the canonical zero. The law that makes two points+-- at the same position compare equal lives here; @canonicalPoint@ is its+-- component-wise form and coordinate-carrying callers use it directly so no+-- t'Point' is built only to be taken apart again.+canonicalCoordinate :: Double -> Double+canonicalCoordinate = canonicalScalarZero+{-# INLINE canonicalCoordinate #-}++-- | Fast approximate signed orientation determinant.+orientDetApprox :: Point -> Point -> Point -> Double+orientDetApprox (Point ax ay) (Point bx by) (Point cx cy) =+  (ax - cx) * (by - cy) - (ay - cy) * (bx - cx)+{-# INLINE orientDetApprox #-}++-- | Exact orientation ordering of three admitted points.+orient2d :: QueryPoint -> QueryPoint -> QueryPoint -> Ordering+orient2d first second third =+  Admitted.orient2d+    (queryPointValue first)+    (queryPointValue second)+    (queryPointValue third)+{-# INLINE orient2d #-}++-- | Exact side of an admitted oriented line.+sideQuery :: QueryPoint -> QueryPoint -> QueryPoint -> LineSideInfo+sideQuery from to query =+  Admitted.sideQuery+    (queryPointValue from)+    (queryPointValue to)+    (queryPointValue query)+{-# INLINE sideQuery #-}++-- | Fast approximate oriented in-circle determinant.+inCircleDetApprox+  :: Point -> Point -> Point -> Point -> Double+inCircleDetApprox+  (Point ax ay)+  (Point bx by)+  (Point cx cy)+  (Point dx dy) =+    alift * bcdet + blift * cadet + clift * abdet+ where+  !adx = ax - dx+  !ady = ay - dy+  !bdx = bx - dx+  !bdy = by - dy+  !cdx = cx - dx+  !cdy = cy - dy+  !abdet = adx * bdy - bdx * ady+  !bcdet = bdx * cdy - cdx * bdy+  !cadet = cdx * ady - adx * cdy+  !alift = adx * adx + ady * ady+  !blift = bdx * bdx + bdy * bdy+  !clift = cdx * cdx + cdy * cdy+{-# INLINE inCircleDetApprox #-}++-- | Ordering of the admitted oriented incircle determinant. For a+-- counter-clockwise triangle, 'GT' means the fourth point lies strictly inside+-- its circumcircle.+inCircle+  :: QueryPoint -> QueryPoint -> QueryPoint -> QueryPoint -> Ordering+inCircle first second third query =+  Admitted.inCircle+    (queryPointValue first)+    (queryPointValue second)+    (queryPointValue third)+    (queryPointValue query)+{-# INLINE inCircle #-}++-- | Whether an admitted point lies on an admitted closed segment.+onClosedSegment :: QueryPoint -> QueryPoint -> QueryPoint -> Bool+onClosedSegment from to query =+  Admitted.onClosedSegment+    (queryPointValue from)+    (queryPointValue to)+    (queryPointValue query)+{-# INLINE onClosedSegment #-}++-- | Squared Euclidean distance.+squaredDistance :: Point -> Point -> Double+squaredDistance (Point ax ay) (Point bx by) =+  let !dx = ax - bx+      !dy = ay - by+   in dx * dx + dy * dy+{-# INLINE squaredDistance #-}++-- | Squared Euclidean distance in the mesh's Binary64 coordinate domain.+squaredDistanceWide :: Point -> Point -> Double+squaredDistanceWide = squaredDistance+{-# INLINE squaredDistanceWide #-}++-- | Squared distance from a point to a closed segment.+segmentDistanceSquared+  :: Point -> Point -> Point -> Double+segmentDistanceSquared from@(Point ax ay) to@(Point bx by) point@(Point px py)+  | lengthSquared == 0 = squaredDistance from point+  | factor <= 0 = squaredDistance from point+  | factor >= 1 = squaredDistance to point+  | otherwise = squaredDistance point (Point (ax + factor * dx) (ay + factor * dy))+ where+  !dx = bx - ax+  !dy = by - ay+  !lengthSquared = dx * dx + dy * dy+  !factor = ((px - ax) * dx + (py - ay) * dy) / lengthSquared+{-# INLINE segmentDistanceSquared #-}++-- | Comparison form retained beside 'segmentDistanceSquared' for callers that+-- state metric intent explicitly.+segmentDistanceSquaredWide+  :: Point -> Point -> Point -> Double+segmentDistanceSquaredWide = segmentDistanceSquared+{-# INLINE segmentDistanceSquaredWide #-}++-- | Euclidean distance.+distance :: Point -> Point -> Double+distance left right = sqrt (squaredDistance left right)+{-# INLINE distance #-}++-- | Negate a point interpreted as a vector.+negateVector :: Point -> Point+negateVector (Point x y) = Point (-x) (-y)+{-# INLINE negateVector #-}++-- | Normalize a point interpreted as a vector without overflowing its length.+normalizeVector :: Point -> Point+normalizeVector (Point x y)+  | scale == 0 = Point 0 0+  | otherwise =+      let !scaledX = x / scale+          !scaledY = y / scale+          !length' = sqrt (scaledX * scaledX + scaledY * scaledY)+       in Point (scaledX / length') (scaledY / length')+ where+  !scale = max (abs x) (abs y)+{-# INLINE normalizeVector #-}++-- | Midpoint of two points.+midpoint :: Point -> Point -> Point+midpoint (Point ax ay) (Point bx by) = Point (0.5 * ax + 0.5 * bx) (0.5 * ay + 0.5 * by)+{-# INLINE midpoint #-}++-- | Centroid of three points.+centroid :: Point -> Point -> Point -> Point+centroid (Point ax ay) (Point bx by) (Point cx cy) =+  Point (ax + (bx - ax) / 3 + (cx - ax) / 3) (ay + (by - ay) / 3 + (cy - ay) / 3)+{-# INLINE centroid #-}++-- | Unsigned area of a triangle.+triangleArea :: Point -> Point -> Point -> Double+triangleArea a b c = 0.5 * abs (orientDetApprox a b c)+{-# INLINE triangleArea #-}++-- | Circumradius divided by shortest edge length.+triangleRadiusEdgeRatio+  :: Point -> Point -> Point -> Maybe Double+triangleRadiusEdgeRatio p0 p1 p2+  | area <= 0 || shortest <= 0 = Nothing+  | not (isFinite ratio) = Nothing+  | otherwise = Just ratio+ where+  !area = triangleArea p0 p1 p2+  !side01 = distance p0 p1+  !side12 = distance p1 p2+  !side20 = distance p2 p0+  !shortest = min side01 (min side12 side20)+  !otherProduct+    | side01 <= side12 && side01 <= side20 = side12 * side20+    | side12 <= side20 = side20 * side01+    | otherwise = side01 * side12+  !ratio = otherProduct / (4 * area)++-- | The square of 'triangleRadiusEdgeRatio', for a triangle whose area the+-- caller already has.+--+-- The ratio is only ever compared against a bound, and both sides are+-- non-negative, so the comparison can be made between squares. That is the+-- whole reason to have this: it settles the same question without the three+-- square roots the lengths would need, on the path taken by every face+-- refinement considers.+--+-- The area is a parameter and a degenerate triangle answers with an infinity+-- rather than an absence, because the caller on that path has already computed+-- the area to ask the area question and does nothing with the absence but+-- compare an infinity in its place.+triangleRadiusEdgeRatioSquaredWithArea+  :: Double -> Point -> Point -> Point -> Double+triangleRadiusEdgeRatioSquaredWithArea area p0 p1 p2 =+  triangleRadiusEdgeRatioSquaredWithAreaAndSides+    area+    (squaredDistance p0 p1)+    (squaredDistance p1 p2)+    (squaredDistance p2 p0)++-- | The same squared ratio from side squares already paid for by a caller.+triangleRadiusEdgeRatioSquaredWithAreaAndSides+  :: Double -> Double -> Double -> Double -> Double+triangleRadiusEdgeRatioSquaredWithAreaAndSides area side01 side12 side20+  | area <= 0 || shortest <= 0 = 1 / 0+  | not (isFinite ratio) = 1 / 0+  | otherwise = ratio+ where+  !shortest = min side01 (min side12 side20)+  !otherProduct+    | side01 <= side12 && side01 <= side20 = side12 * side20+    | side12 <= side20 = side20 * side01+    | otherwise = side01 * side12+  !ratio = otherProduct / (16 * area * area)++-- The scale the determinants are divided by cancels out of the quotient+-- exactly, so the computation works on the unscaled differences and divides+-- once per coordinate. Scaling would only matter against overflow, and the+-- validated coordinate domain (|x| <= 3.3e60) keeps every intermediate below+-- 1e183, five orders below the Double ceiling; the four divisions it cost+-- are the circumcentre's hot-path price. Identical points answer through the+-- denominator, which is exactly zero exactly when they are collinear.+-- | Circumcenter of a nondegenerate triangle.+circumcenter+  :: Point -> Point -> Point -> Maybe (Point)+circumcenter (Point ax ay) (Point bx by) (Point cx cy)+  | denominator == 0 = Nothing+  | not (isFinite resultX && isFinite resultY) = Nothing+  | otherwise = Just (canonicalPoint (Point resultX resultY))+ where+  !bax = bx - ax+  !bay = by - ay+  !cax = cx - ax+  !cay = cy - ay+  !bLength = bax * bax + bay * bay+  !cLength = cax * cax + cay * cay+  !denominator = 2 * (bax * cay - bay * cax)+  !offsetX = (cay * bLength - bay * cLength) / denominator+  !offsetY = (bax * cLength - cax * bLength) / denominator+  !resultX = ax + offsetX+  !resultY = ay + offsetY++-- | Barycentric coordinates of a point in a nondegenerate triangle.+barycentricCoordinates+  :: Point -> Point -> Point -> Point+  -> Maybe (Double, Double, Double)+barycentricCoordinates a@(Point ax ay) b@(Point bx by) c@(Point cx cy) query@(Point qx qy)+  | all reliable [denominatorInfo, weightAInfo, weightBInfo, weightCInfo] =+      if denominator == 0+        then Nothing+        else Just (weightA / denominator, weightB / denominator, weightC / denominator)+  | exactDenominator == 0 = Nothing+  | otherwise =+      Just+        ( integerRatioToDouble exactWeightA exactDenominator+        , integerRatioToDouble exactWeightB exactDenominator+        , integerRatioToDouble exactWeightC exactDenominator+        )+ where+  !denominatorInfo@(denominator, _) = determinantInfo a b c+  !weightAInfo@(weightA, _) = determinantInfo query b c+  !weightBInfo@(weightB, _) = determinantInfo a query c+  !weightCInfo@(weightC, _) = determinantInfo a b query+  (!exactDenominator, !exactWeightA, !exactWeightB, !exactWeightC) =+    exactBarycentricDeterminants ax ay bx by cx cy qx qy++  reliable (determinant, determinantSum) =+    isFinite determinant && abs determinant > scalarCcwErrorBound * determinantSum++  determinantInfo :: Point -> Point -> Point -> (Double, Double)+  determinantInfo (Point px py) (Point rx ry) (Point sx sy) =+    let !left = (px - sx) * (ry - sy)+        !right = (py - sy) * (rx - sx)+     in (left - right, abs left + abs right)++-- | Whether an admitted point lies in the closed diametral disk of an admitted+-- segment, decided by the sign of @(a-p)·(b-p)@.+--+-- The approximation is two coordinate differences and one product per term+-- combined additively, which is the arithmetic shape 'orient2d' is analysed+-- under: the forward error of @fl(fl(a⊖b) ⊗ fl(c⊖d))@ combined by one rounded+-- addition does not depend on the sign of that combination. The orientation+-- coefficient therefore transfers unchanged, and the exact dot product remains+-- the oracle for the uncertain band.+inDiametralCircle :: QueryPoint -> QueryPoint -> QueryPoint -> Bool+inDiametralCircle from to query =+  Admitted.inDiametralCircle+    (queryPointValue from)+    (queryPointValue to)+    (queryPointValue query)+{-# INLINE inDiametralCircle #-}++-- | Projection parameter of a point onto an oriented segment line.+projectionFactor :: Point -> Point -> Point -> Double+projectionFactor (Point ax ay) (Point bx by) (Point qx qy)+  | lengthSquared == 0 = 0+  | otherwise = ((qx - ax) * dx + (qy - ay) * dy) / lengthSquared+ where+  !dx = bx - ax+  !dy = by - ay+  !lengthSquared = dx * dx + dy * dy+{-# INLINE projectionFactor #-}
+ src-dcel/Moonlight/Triangulation/Payload.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE RankNTypes #-}++-- | The payload parameters' functorial and traversable structure: relabeling a+-- payload touches no geometry, so every law here holds for the reason that a+-- triangulation's points and its annotations are separate things.+module Moonlight.Triangulation.Payload+  ( PayloadTraversal+  , vertexPayloads+  , directedPayloads+  , undirectedPayloads+  , facePayloads+  , mapVertices+  , mapDirectedEdges+  , mapUndirectedEdges+  , mapFaces+  , overPayloads+  , foldPayloads+  , payloadList+  ) where++import Data.Functor.Const (Const (..))+import Data.Functor.Identity (Identity (..))+import Data.Monoid (Endo (..))+import Moonlight.Triangulation.Internal.Representation+  ( PayloadTraversal+  , directedPayloads+  , facePayloads+  , mapDirectedEdges+  , mapFaces+  , mapUndirectedEdges+  , mapVertices+  , undirectedPayloads+  , vertexPayloads+  )++-- | Relabel every payload a traversal reaches.+--+-- The 'mapVertices' family is this at each parameter and cheaper: a pure map+-- leaves an unmaterialized page unmaterialized, where a traversal must visit+-- every slot the page would have reported and so materializes it. Reach for+-- this one when the traversal is chosen at runtime, and for the named map when+-- the parameter is known where you stand.+overPayloads+  :: PayloadTraversal source target payload payload'+  -> (payload -> payload')+  -> source+  -> target+overPayloads traversal relabel = runIdentity . traversal (Identity . relabel)+{-# INLINE overPayloads #-}++-- | Summarize every payload a traversal reaches.+foldPayloads+  :: Monoid summary+  => PayloadTraversal source source payload payload+  -> (payload -> summary)+  -> source+  -> summary+foldPayloads traversal measure = getConst . traversal (Const . measure)+{-# INLINE foldPayloads #-}++-- | Every payload a traversal reaches, in visit order. Accumulated through+-- t'Endo' so the list is built by a right fold rather than by repeated append.+payloadList :: PayloadTraversal source source payload payload -> source -> [payload]+payloadList traversal source = appEndo (foldPayloads traversal (Endo . (:)) source) []+{-# INLINE payloadList #-}
+ src-dcel/Moonlight/Triangulation/PointLocation.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE BangPatterns #-}++-- | Walk location over the finite mesh; the hinted form takes a starting point+-- and reports the steps it spent.+module Moonlight.Triangulation.PointLocation+  ( locatePoint+  , locatePointWithHint+  ) where++import Data.List (find)+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Handles.Iterators.FixedIterators+import Moonlight.Triangulation.Internal.FaceProbe+import Moonlight.Triangulation.Internal.Predicates+import Moonlight.Triangulation.Types++-- | Locate an admitted point without an initial topology hint.+locatePoint :: Triangulation mode vertex directed undirected face -> QueryPoint -> Location+locatePoint triangulation query = fst (locatePointWithHint triangulation Nothing query)++-- | Locate an admitted point from an optional starting cell and report the+-- descent work.+locatePointWithHint :: Triangulation mode vertex directed undirected face -> Maybe LocationHint -> QueryPoint -> (Location, LocationStats)+locatePointWithHint triangulation hint queryPoint+  | numVertices triangulation == 0 = (EmptyTriangulation, emptyLocationStats)+  | numInnerFaces triangulation == 0 = (locateDegenerate triangulation query, emptyLocationStats)+  | otherwise = walk budget 0 startFace+ where+  !query = queryPointValue queryPoint+  !budget = max 8 (numFaces triangulation + numUndirectedEdges triangulation + 4)+  !startFace = chooseStart triangulation hint++  walk !remaining !steps !face+    | remaining <= 0 = scanAll steps+    | face == outerFace =+        (outsideLocation triangulation query, LocationStats steps False)+    | otherwise =+        case probeFace triangulation face query of+          FaceHit location -> (location, LocationStats (steps + 1) False)+          FaceCross edge ->+            let adjacent = incidentFace triangulation edge+             in if adjacent == outerFace+                  then (OutsideConvexHull (Just edge), LocationStats (steps + 1) False)+                  else walk (remaining - 1) (steps + 1) adjacent+          FaceMiss -> scanAll (steps + 1)++  scanAll !steps =+    case findHit (innerFaces triangulation) of+      Just location -> (location, LocationStats steps True)+      Nothing -> (outsideLocation triangulation query, LocationStats steps True)++  findHit [] = Nothing+  findHit (face : remaining) =+    case probeFace triangulation face query of+      FaceHit location -> Just location+      _ -> findHit remaining++data FaceProbe = FaceHit !Location | FaceCross !DirectedEdgeId | FaceMiss++probeFace :: Triangulation mode vertex directed undirected face -> FaceId -> Point -> FaceProbe+probeFace triangulation face query =+  case innerFaceDirectedEdges triangulation face of+    Nothing -> FaceMiss+    Just (e0, e1, e2) -> classify [e0, e1, e2] Nothing+ where+  classify [] Nothing = FaceHit (InFace face)+  classify [] (Just edge) = FaceCross edge+  classify (edge : remaining) crossing =+    let fromVertex = origin triangulation edge+        toVertex = destination triangulation edge+        from = vertexPoint triangulation fromVertex+        to = vertexPoint triangulation toVertex+     in case probeBoundary reverseEdge query edge fromVertex from toVertex to of+          BoundaryClear -> classify remaining crossing+          BoundaryOnVertex vertex -> FaceHit (OnVertex vertex)+          BoundaryOnEdge boundary -> FaceHit (OnEdge boundary)+          BoundaryCrossing boundary -> classify remaining (Just boundary)++locateDegenerate :: Triangulation mode vertex directed undirected face -> Point -> Location+locateDegenerate triangulation query =+  case find ((== query) . vertexPoint triangulation) (vertices triangulation) of+    Just vertex -> OnVertex vertex+    Nothing ->+      case find contains (undirectedEdges triangulation) of+        Just edge -> OnEdge (normalizedDirected edge)+        Nothing ->+          case undirectedEdges triangulation of+            [] -> OutsideConvexHull Nothing+            edge : _ ->+              let forward = normalizedDirected edge+                  from = vertexPoint triangulation (origin triangulation forward)+                  to = vertexPoint triangulation (destination triangulation forward)+                  directed = case orient2d from to query of+                    GT -> forward+                    LT -> reverseEdge forward+                    EQ -> forward+               in OutsideConvexHull (Just directed)+ where+  contains edge =+    let forward = normalizedDirected edge+     in onClosedSegment+          (vertexPoint triangulation (origin triangulation forward))+          (vertexPoint triangulation (destination triangulation forward))+          query++outsideLocation :: Triangulation mode vertex directed undirected face -> Point -> Location+outsideLocation triangulation query =+  OutsideConvexHull (find visible (faceDirectedEdges triangulation outerFace))+ where+  visible edge =+    orient2d+      (vertexPoint triangulation (origin triangulation edge))+      (vertexPoint triangulation (destination triangulation edge))+      query+      /= LT++chooseStart :: Triangulation mode vertex directed undirected face -> Maybe LocationHint -> FaceId+chooseStart triangulation hint =+  case hint of+    Just (FaceHint face)+      | face /= outerFace && faceIdIndex face < numFaces triangulation -> face+    Just (VertexHint vertex@(VertexId index))+      | toInteger index < toInteger (numVertices triangulation) ->+          case [face | edge <- vertexOutgoingEdges triangulation vertex, let face = incidentFace triangulation edge, face /= outerFace] of+            face : _ -> face+            [] -> FaceId 1+      | otherwise -> FaceId 1+    _ -> FaceId 1
+ src-dcel/Moonlight/Triangulation/Region.hs view
@@ -0,0 +1,430 @@+-- | 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.List as List+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+  ( admitsSimpleCycleEdgeRelation+  , 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+        ( admitsSimpleCycleEdgeRelation+            segmentCount+            leftIndex+            rightIndex+            relation+        )+    ] 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)++loopWinding :: ExactLoop -> Ordering+loopWinding (ExactLoop points) =+  exactSignum+    ( List.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/Simplex.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TypeApplications #-}++-- | Canonical labelled simplices and downward-closed planar complexes.+-- Labels, rather than resident DCEL handles, own identity across independently+-- constructed meshes.+module Moonlight.Triangulation.Simplex+  ( SimplexDimension (..)+  , PlanarSimplex+  , PlanarSimplexError (..)+  , planarVertex+  , planarEdge+  , planarFace+  , planarSimplexDimension+  , planarSimplexVertices+  , planarSimplexBoundary+  , PlanarComplex+  , PlanarComplexError (..)+  , planarComplex+  , planarComplexCells+  , planarComplexBasisAt+  , unionPlanarComplex+  , intersectPlanarComplex+  )+where++import Control.DeepSeq (NFData)+import Data.List qualified as List+import Data.List.NonEmpty (NonEmpty (..))+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import GHC.Generics (Generic)++-- | The closed dimension vocabulary for planar simplicial complexes.+data SimplexDimension+  = SimplexDimension0+  | SimplexDimension1+  | SimplexDimension2+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)+  deriving anyclass (NFData)++-- | One canonical simplex. Edge and face labels are strictly ascending.+data PlanarSimplex label+  = PlanarVertex !label+  | PlanarEdge !label !label+  | PlanarFace !label !label !label+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A repeated vertex would lower the requested simplex's dimension.+data PlanarSimplexError label+  = PlanarSimplexRepeatedVertex !label+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++planarVertex :: label -> PlanarSimplex label+planarVertex = PlanarVertex++planarEdge+  :: Ord label+  => label+  -> label+  -> Either (PlanarSimplexError label) (PlanarSimplex label)+planarEdge firstLabel secondLabel =+  case compare firstLabel secondLabel of+    LT -> Right (PlanarEdge firstLabel secondLabel)+    EQ -> Left (PlanarSimplexRepeatedVertex firstLabel)+    GT -> Right (PlanarEdge secondLabel firstLabel)++planarFace+  :: Ord label+  => label+  -> label+  -> label+  -> Either (PlanarSimplexError label) (PlanarSimplex label)+planarFace firstLabel secondLabel thirdLabel =+  let (firstLow, firstHigh) = ascendingPair firstLabel secondLabel+      (secondLow, finalHigh) = ascendingPair firstHigh thirdLabel+      (finalLow, finalMiddle) = ascendingPair firstLow secondLow+   in if finalLow == finalMiddle+        then Left (PlanarSimplexRepeatedVertex finalLow)+        else+          if finalMiddle == finalHigh+            then Left (PlanarSimplexRepeatedVertex finalMiddle)+            else Right (PlanarFace finalLow finalMiddle finalHigh)++planarSimplexDimension :: PlanarSimplex label -> SimplexDimension+planarSimplexDimension simplex =+  case simplex of+    PlanarVertex _ -> SimplexDimension0+    PlanarEdge _ _ -> SimplexDimension1+    PlanarFace _ _ _ -> SimplexDimension2++planarSimplexVertices :: PlanarSimplex label -> NonEmpty label+planarSimplexVertices simplex =+  case simplex of+    PlanarVertex label -> label :| []+    PlanarEdge firstLabel secondLabel -> firstLabel :| [secondLabel]+    PlanarFace firstLabel secondLabel thirdLabel ->+      firstLabel :| [secondLabel, thirdLabel]++-- | The canonical oriented simplicial boundary.+planarSimplexBoundary+  :: Num coefficient+  => PlanarSimplex label+  -> [(coefficient, PlanarSimplex label)]+planarSimplexBoundary simplex =+  case simplex of+    PlanarVertex _ -> []+    PlanarEdge firstLabel secondLabel ->+      [ (-1, PlanarVertex firstLabel)+      , (1, PlanarVertex secondLabel)+      ]+    PlanarFace firstLabel secondLabel thirdLabel ->+      [ (1, PlanarEdge secondLabel thirdLabel)+      , (-1, PlanarEdge firstLabel thirdLabel)+      , (1, PlanarEdge firstLabel secondLabel)+      ]++-- | A requested cell whose boundary is absent from the same complex.+data PlanarComplexError label+  = PlanarComplexBoundaryMissing+      !(PlanarSimplex label)+      !(PlanarSimplex label)+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | An admitted downward-closed complex and its canonical dense bases.+data PlanarComplex label = PlanarComplex+  { storedPlanarComplexCells :: !(Set (PlanarSimplex label))+  , storedPlanarVertexBasis :: !(Vector (PlanarSimplex label))+  , storedPlanarEdgeBasis :: !(Vector (PlanarSimplex label))+  , storedPlanarFaceBasis :: !(Vector (PlanarSimplex label))+  }+  deriving stock (Show, Generic)+  deriving anyclass (NFData)++instance Eq label => Eq (PlanarComplex label) where+  left == right =+    storedPlanarComplexCells left == storedPlanarComplexCells right++planarComplex+  :: Ord label+  => Set (PlanarSimplex label)+  -> Either (PlanarComplexError label) (PlanarComplex label)+planarComplex cells =+  case List.find (\(_, boundary) -> Set.notMember boundary cells) boundaryPairs of+    Just (simplex, boundary) ->+      Left (PlanarComplexBoundaryMissing simplex boundary)+    Nothing -> Right (admittedPlanarComplex cells)+ where+  boundaryPairs =+    [ (simplex, boundary)+    | simplex <- Set.toAscList cells+    , (_, boundary) <- planarSimplexBoundary @Int simplex+    ]++planarComplexCells :: PlanarComplex label -> Set (PlanarSimplex label)+planarComplexCells = storedPlanarComplexCells++planarComplexBasisAt+  :: SimplexDimension+  -> PlanarComplex label+  -> Vector (PlanarSimplex label)+planarComplexBasisAt dimension complexValue =+  case dimension of+    SimplexDimension0 -> storedPlanarVertexBasis complexValue+    SimplexDimension1 -> storedPlanarEdgeBasis complexValue+    SimplexDimension2 -> storedPlanarFaceBasis complexValue++-- | Union preserves downward closure, so no second validation is needed.+unionPlanarComplex+  :: Ord label+  => PlanarComplex label+  -> PlanarComplex label+  -> PlanarComplex label+unionPlanarComplex left right =+  admittedPlanarComplex+    (Set.union (planarComplexCells left) (planarComplexCells right))++-- | Intersection also preserves downward closure.+intersectPlanarComplex+  :: Ord label+  => PlanarComplex label+  -> PlanarComplex label+  -> PlanarComplex label+intersectPlanarComplex left right =+  admittedPlanarComplex+    (Set.intersection (planarComplexCells left) (planarComplexCells right))++admittedPlanarComplex :: Set (PlanarSimplex label) -> PlanarComplex label+admittedPlanarComplex cells =+  let (vertices, edges, faces) =+        foldr partitionSimplex ([], [], []) (Set.toAscList cells)+   in PlanarComplex+        { storedPlanarComplexCells = cells+        , storedPlanarVertexBasis = Vector.fromList vertices+        , storedPlanarEdgeBasis = Vector.fromList edges+        , storedPlanarFaceBasis = Vector.fromList faces+        }++partitionSimplex+  :: PlanarSimplex label+  -> ( [PlanarSimplex label]+     , [PlanarSimplex label]+     , [PlanarSimplex label]+     )+  -> ( [PlanarSimplex label]+     , [PlanarSimplex label]+     , [PlanarSimplex label]+     )+partitionSimplex simplex (vertices, edges, faces) =+  case simplex of+    PlanarVertex _ -> (simplex : vertices, edges, faces)+    PlanarEdge _ _ -> (vertices, simplex : edges, faces)+    PlanarFace _ _ _ -> (vertices, edges, simplex : faces)++ascendingPair :: Ord value => value -> value -> (value, value)+ascendingPair firstValue secondValue =+  if firstValue <= secondValue+    then (firstValue, secondValue)+    else (secondValue, firstValue)
+ src-dcel/Moonlight/Triangulation/Types.hs view
@@ -0,0 +1,45 @@+-- | The package vocabulary: sites and validated queries, the mode-indexed+-- triangulation, what construction returns, and the closed failure types.+module Moonlight.Triangulation.Types+  ( Point (..)+  , SiteRelation (..)+  , QueryPoint+  , queryPointValue+  , PointValidationError (..)+  , HasPosition (..)+  , ElementDefaults (..)+  , unitElementDefaults+  , ConstraintMode (..)+  , KnownConstraintMode (..)+  , Triangulation+  , DelaunayTriangulation+  , ConstrainedDelaunayTriangulation+  , BuildResult (..)+  , InsertionDisposition (..)+  , InsertionResult (..)+  , BuildStats (..)+  , emptyBuildStats+  , CoordinateError (..)+  , NonFiniteValue (..)+  , classifyNonFinite+  , RadiusSquared+  , RadiusSquaredError (..)+  , mkRadiusSquared+  , radiusSquaredValue+  , BuildError (..)+  , Location (..)+  , LocationHint (..)+  , LocationStats (..)+  , emptyLocationStats+  , NearestStats (..)+  , RefinementParameters (..)+  , defaultRefinementParameters+  , ValidationClosureStats (..)+  , RefinementReceipt (..)+  , RefinementDomainResult (..)+  , RefinementResult (..)+  , InvariantViolation (..)+  ) where++import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types
+ src-dcel/Moonlight/Triangulation/Validation.hs view
@@ -0,0 +1,11 @@+-- | Whole-value DCEL validation and face-quality observations.+module Moonlight.Triangulation.Validation+  ( validateTopology+  , validateDelaunay+  , validateTriangulation+  , triangulationIsValid+  , faceArea+  , faceMinimumAngleDegrees+  ) where++import Moonlight.Triangulation.Internal.Validation
+ src-dcel/Moonlight/Triangulation/Valuation.hs view
@@ -0,0 +1,795 @@+{-# 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+  , ExactPlanarMoments+  , exactPlanarMeasure+  , exactPlanarFirstX+  , exactPlanarFirstY+  , exactPlanarSecondXX+  , exactPlanarSecondXY+  , exactPlanarSecondYY+  , scaleExactPlanarMoments+  , polygonComponentMoments+  , polygonComponentArea+  , ExactLengthTerm+  , lengthCoefficient+  , squaredLength+  , ExactLengthExpression+  , exactLengthTerms+  , CertifiedInterval (..)+  , ExactLengthMeasurement+  , exactLengthExpression+  , exactLengthBounds+  , PlanarValuations+  , valuationEuler+  , valuationArea+  , valuationIntrinsic1+  , ValuationError (..)+  , cellValuations+  , regionValuations+  , planarValuationsPerimeter+  , cellSetPerimeter+  , regionPerimeter+  ) where++import Control.DeepSeq (NFData)+import Data.Bifunctor (first)+import Data.Bits (shiftL)+import Data.Foldable (foldlM)+import qualified Data.List as List+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.Internal.HandleDefs+  ( FaceId (..)+  , UndirectedEdgeId (..)+  , VertexId (..)+  , directedPair+  , faceIdIndex+  , vertexIdIndex+  )+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+  , exactRationalFromNormalizedRatio+  , 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)++instance Semigroup ExactArea where+  ExactArea left <> ExactArea right = ExactArea (left + right)++instance Monoid ExactArea where+  mempty = ExactArea 0++exactAreaValue :: ExactArea -> ExactRational+exactAreaValue (ExactArea value) = value++-- | Exact moments of a bounded planar measure through total degree two.+data ExactPlanarMoments = ExactPlanarMoments+  { exactPlanarMeasure :: !ExactRational+    -- ^ Total signed measure.+  , exactPlanarFirstX :: !ExactRational+    -- ^ Raw first moment integral of @x@.+  , exactPlanarFirstY :: !ExactRational+    -- ^ Raw first moment integral of @y@.+  , exactPlanarSecondXX :: !ExactRational+    -- ^ Raw second moment integral of @x^2@.+  , exactPlanarSecondXY :: !ExactRational+    -- ^ Raw mixed moment integral of @x*y@.+  , exactPlanarSecondYY :: !ExactRational+    -- ^ Raw second moment integral of @y^2@.+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++instance Semigroup ExactPlanarMoments where+  left <> right =+    ExactPlanarMoments+      { exactPlanarMeasure = exactPlanarMeasure left + exactPlanarMeasure right+      , exactPlanarFirstX = exactPlanarFirstX left + exactPlanarFirstX right+      , exactPlanarFirstY = exactPlanarFirstY left + exactPlanarFirstY right+      , exactPlanarSecondXX = exactPlanarSecondXX left + exactPlanarSecondXX right+      , exactPlanarSecondXY = exactPlanarSecondXY left + exactPlanarSecondXY right+      , exactPlanarSecondYY = exactPlanarSecondYY left + exactPlanarSecondYY right+      }++instance Monoid ExactPlanarMoments where+  mempty = ExactPlanarMoments 0 0 0 0 0 0++-- | Scale every moment by one exact coefficient.+scaleExactPlanarMoments+  :: ExactRational+  -> ExactPlanarMoments+  -> ExactPlanarMoments+scaleExactPlanarMoments scalar moments =+  ExactPlanarMoments+    { exactPlanarMeasure = scalar * exactPlanarMeasure moments+    , exactPlanarFirstX = scalar * exactPlanarFirstX moments+    , exactPlanarFirstY = scalar * exactPlanarFirstY moments+    , exactPlanarSecondXX = scalar * exactPlanarSecondXX moments+    , exactPlanarSecondXY = scalar * exactPlanarSecondXY moments+    , exactPlanarSecondYY = scalar * exactPlanarSecondYY moments+    }++-- | Exact area and raw moments of one admitted component. The six unscaled+-- boundary sums are accumulated together and normalized once.+polygonComponentMoments :: PolygonComponent -> ExactPlanarMoments+polygonComponentMoments component =+  let raw =+        foldMap+          loopMomentSums+          (polygonOuterLoop component : polygonHoleLoops component)+   in ExactPlanarMoments+        { exactPlanarMeasure = oneHalf * rawDoubleArea raw+        , exactPlanarFirstX = oneSixth * rawFirstX raw+        , exactPlanarFirstY = oneSixth * rawFirstY raw+        , exactPlanarSecondXX = oneTwelfth * rawSecondXX raw+        , exactPlanarSecondXY = oneTwentyFourth * rawSecondXY raw+        , exactPlanarSecondYY = oneTwelfth * rawSecondYY raw+        }++-- | Exact unsigned area of one already-admitted polygon component.  Winding+-- and hole containment were discharged by 'polygonComponent', so this+-- observation performs no second geometric validation.+polygonComponentArea :: PolygonComponent -> ExactArea+polygonComponentArea = ExactArea . (oneHalf *) . componentDoubleArea++data RawPlanarMomentSums = RawPlanarMomentSums+  { rawDoubleArea :: !ExactRational+  , rawFirstX :: !ExactRational+  , rawFirstY :: !ExactRational+  , rawSecondXX :: !ExactRational+  , rawSecondXY :: !ExactRational+  , rawSecondYY :: !ExactRational+  }++instance Semigroup RawPlanarMomentSums where+  left <> right =+    RawPlanarMomentSums+      { rawDoubleArea = rawDoubleArea left + rawDoubleArea right+      , rawFirstX = rawFirstX left + rawFirstX right+      , rawFirstY = rawFirstY left + rawFirstY right+      , rawSecondXX = rawSecondXX left + rawSecondXX right+      , rawSecondXY = rawSecondXY left + rawSecondXY right+      , rawSecondYY = rawSecondYY left + rawSecondYY right+      }++instance Monoid RawPlanarMomentSums where+  mempty = RawPlanarMomentSums 0 0 0 0 0 0++loopMomentSums :: ExactLoop -> RawPlanarMomentSums+loopMomentSums (ExactLoop points) =+  List.foldl' accumulateMomentEdge mempty (cyclePairs points)++accumulateMomentEdge+  :: RawPlanarMomentSums+  -> (ExactPoint, ExactPoint)+  -> RawPlanarMomentSums+accumulateMomentEdge accumulated (from, to) =+  let (fromX, fromY) = exactPointCoordinates from+      (toX, toY) = exactPointCoordinates to+      cross = exactPointCross from to+   in RawPlanarMomentSums+        { rawDoubleArea = rawDoubleArea accumulated + cross+        , rawFirstX = rawFirstX accumulated + (fromX + toX) * cross+        , rawFirstY = rawFirstY accumulated + (fromY + toY) * cross+        , rawSecondXX =+            rawSecondXX accumulated+              + (fromX * fromX + fromX * toX + toX * toX) * cross+        , rawSecondXY =+            rawSecondXY accumulated+              + (2 * fromX * fromY + fromX * toY + toX * fromY + 2 * toX * toY) * cross+        , rawSecondYY =+            rawSecondYY accumulated+              + (fromY * fromY + fromY * toY + toY * toY) * cross+        }++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)+    (List.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 = not (all (null . snd) boundaryCover)+  euler <- regionEuler boundaryCover+  boundaryAtoms <-+    normalizedRegionBoundaryAtoms+      hasPotentialBoundaryContacts+      componentBoundaries+  let doubleArea =+        List.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 >>= planarValuationsPerimeter+  | otherwise = Left ValuationCellSetNotPureRegion++regionPerimeter+  :: PlanarRegion+  -> Either ValuationError ExactLengthMeasurement+regionPerimeter region = regionValuations region >>= planarValuationsPerimeter++-- | Derive conventional boundary length from an already-computed intrinsic+-- valuation without traversing the source geometry again.+planarValuationsPerimeter+  :: PlanarValuations+  -> Either ValuationError ExactLengthMeasurement+planarValuationsPerimeter 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 = IntSet.member (faceIdIndex face) 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 =+  maybe+    (Left (ValuationCoordinateMissing vertex))+    Right+    (IntMap.lookup (vertexIdIndex vertex) points)++triangleDoubleArea :: ExactPoint -> ExactPoint -> ExactPoint -> ExactRational+triangleDoubleArea firstPoint secondPoint thirdPoint =+  exactPointCross firstPoint secondPoint+    + exactPointCross secondPoint thirdPoint+    + exactPointCross thirdPoint firstPoint++componentDoubleArea :: PolygonComponent -> ExactRational+componentDoubleArea component =+  List.foldl'+    (\area loop -> area + loopDoubleArea loop)+    0+    (polygonOuterLoop component : polygonHoleLoops component)++loopDoubleArea :: ExactLoop -> ExactRational+loopDoubleArea (ExactLoop points) =+  List.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 =+    List.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)++oneSixth :: ExactRational+oneSixth = exactRationalFromNormalizedRatio (1 Ratio.% 6)++oneTwelfth :: ExactRational+oneTwelfth = exactRationalFromNormalizedRatio (1 Ratio.% 12)++oneTwentyFourth :: ExactRational+oneTwentyFourth = exactRationalFromNormalizedRatio (1 Ratio.% 24)
+ src-dual/Moonlight/Triangulation/Internal/InterpolationWorkspace.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}++module Moonlight.Triangulation.Internal.InterpolationWorkspace+  ( NaturalNeighborWorkspace (..)+  , newNaturalNeighborWorkspace+  , nextFaceGeneration+  , nextOriginGeneration+  , workspaceBytes+  ) where++import Control.Monad.Primitive (PrimMonad, PrimState)+import Control.Monad.ST (ST)+import Data.Primitive.MutVar+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32)+import Moonlight.Triangulation.Dcel (numDirectedEdges, numFaces, numVertices)+import Moonlight.Triangulation.Internal.Representation (Triangulation)+import Moonlight.Triangulation.Internal.Types (ConstraintMode)+import Moonlight.Triangulation.Scalar (scalarByteSize)++-- | Reusable scratch space for Sibson interpolation. It borrows no mutable+-- topology: the immutable triangulation is the sole owner, while these arrays+-- are query-local marks, queues and numeric work buffers.+data NaturalNeighborWorkspace state (mode :: ConstraintMode) vertex directed undirected face = NaturalNeighborWorkspace+  { nnTriangulation :: !(Triangulation mode vertex directed undirected face)+  , nnFaceMarks :: !(MUV.MVector state Word32)+  , nnFaceSeenMarks :: !(MUV.MVector state Word32)+    -- The circumcentre plane is stamped by the same generation as the two mark+    -- planes above, and that is what makes it sound: a generation is minted+    -- once per Sibson query, and the circumcentre a face contributes is a+    -- function of the face and the query point together. Holding the plane to+    -- exactly one generation's lifetime holds the query point fixed for as long+    -- as an entry can be read.+  , nnCircumcenterMarks :: !(MUV.MVector state Word32)+  , nnFaceGeneration :: !(MutVar state Word32)+  , nnCircumcenterX :: !(MUV.MVector state Double)+  , nnCircumcenterY :: !(MUV.MVector state Double)+  , nnFaceQueue :: !(MUV.MVector state Word32)+  , nnCavityFaces :: !(MUV.MVector state Word32)+  , nnBoundaryEdges :: !(MUV.MVector state Word32)+  , nnOrderedEdges :: !(MUV.MVector state Word32)+  , nnOriginMarks :: !(MUV.MVector state Word32)+  , nnOriginGeneration :: !(MutVar state Word32)+  , nnOriginEdge :: !(MUV.MVector state Word32)+  , nnInsertionX :: !(MUV.MVector state Double)+  , nnInsertionY :: !(MUV.MVector state Double)+  , nnWeightVertex :: !(MUV.MVector state Word32)+  , nnWeightValue :: !(MUV.MVector state Double)+  }++-- | Allocate reusable interpolation storage sized to one triangulation.+newNaturalNeighborWorkspace+  :: PrimMonad m+  => Triangulation mode vertex directed undirected face+  -> m (NaturalNeighborWorkspace (PrimState m) mode vertex directed undirected face)+newNaturalNeighborWorkspace triangulation = do+  let !faceCapacity = max 1 (numFaces triangulation)+      !edgeCapacity = max 1 (numDirectedEdges triangulation)+      !vertexCapacity = max 1 (numVertices triangulation)+  faceMarks <- MUV.replicate faceCapacity 0+  faceSeenMarks <- MUV.replicate faceCapacity 0+  circumcenterMarks <- MUV.replicate faceCapacity 0+  faceGeneration <- newMutVar 0+  circumcenterX <- MUV.new faceCapacity+  circumcenterY <- MUV.new faceCapacity+  faceQueue <- MUV.new faceCapacity+  cavityFaces <- MUV.new faceCapacity+  boundaryEdges <- MUV.new edgeCapacity+  orderedEdges <- MUV.new edgeCapacity+  originMarks <- MUV.replicate vertexCapacity 0+  originGeneration <- newMutVar 0+  originEdge <- MUV.new vertexCapacity+  insertionX <- MUV.new edgeCapacity+  insertionY <- MUV.new edgeCapacity+  weightVertex <- MUV.new edgeCapacity+  weightValue <- MUV.new edgeCapacity+  pure NaturalNeighborWorkspace+    { nnTriangulation = triangulation+    , nnFaceMarks = faceMarks+    , nnFaceSeenMarks = faceSeenMarks+    , nnCircumcenterMarks = circumcenterMarks+    , nnFaceGeneration = faceGeneration+    , nnCircumcenterX = circumcenterX+    , nnCircumcenterY = circumcenterY+    , nnFaceQueue = faceQueue+    , nnCavityFaces = cavityFaces+    , nnBoundaryEdges = boundaryEdges+    , nnOrderedEdges = orderedEdges+    , nnOriginMarks = originMarks+    , nnOriginGeneration = originGeneration+    , nnOriginEdge = originEdge+    , nnInsertionX = insertionX+    , nnInsertionY = insertionY+    , nnWeightVertex = weightVertex+    , nnWeightValue = weightValue+    }++nextFaceGeneration :: NaturalNeighborWorkspace s mode vertex directed undirected face -> ST s Word32+nextFaceGeneration workspace = do+  current <- readMutVar (nnFaceGeneration workspace)+  let !next = current + 1+  if next == 0+    then do+      MUV.set (nnFaceMarks workspace) 0+      MUV.set (nnFaceSeenMarks workspace) 0+      MUV.set (nnCircumcenterMarks workspace) 0+      writeMutVar (nnFaceGeneration workspace) 1+      pure 1+    else writeMutVar (nnFaceGeneration workspace) next >> pure next++nextOriginGeneration :: NaturalNeighborWorkspace s mode vertex directed undirected face -> ST s Word32+nextOriginGeneration workspace = nextGeneration (nnOriginMarks workspace) (nnOriginGeneration workspace)++nextGeneration :: MUV.MVector s Word32 -> MutVar s Word32 -> ST s Word32+nextGeneration marks reference = do+  current <- readMutVar reference+  let !next = current + 1+  if next == 0+    then do+      MUV.set marks 0+      writeMutVar reference 1+      pure 1+    else writeMutVar reference next >> pure next++-- | Bytes owned by the reusable numeric and index planes.+workspaceBytes+  :: NaturalNeighborWorkspace state mode vertex directed undirected face+  -> Integer+workspaceBytes workspace =+  4 * toInteger wordSlots+    + toInteger scalarByteSize * toInteger scalarSlots+ where+  wordSlots =+    MUV.length (nnFaceMarks workspace)+      + MUV.length (nnFaceSeenMarks workspace)+      + MUV.length (nnCircumcenterMarks workspace)+      + MUV.length (nnFaceQueue workspace)+      + MUV.length (nnCavityFaces workspace)+      + MUV.length (nnBoundaryEdges workspace)+      + MUV.length (nnOrderedEdges workspace)+      + MUV.length (nnOriginMarks workspace)+      + MUV.length (nnOriginEdge workspace)+      + MUV.length (nnWeightVertex workspace)+  scalarSlots =+    MUV.length (nnCircumcenterX workspace)+      + MUV.length (nnCircumcenterY workspace)+      + MUV.length (nnInsertionX workspace)+      + MUV.length (nnInsertionY workspace)+      + MUV.length (nnWeightValue workspace)
+ src-dual/Moonlight/Triangulation/Interpolation.hs view
@@ -0,0 +1,899 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- | Nearest, barycentric, and natural-neighbor interpolation over one+-- authoritative triangulation.+module Moonlight.Triangulation.Interpolation+  ( BarycentricWeights (..)+  , InterpolationStats (..)+  , NaturalNeighborResult (..)+  , NaturalNeighborWorkspace+  , newNaturalNeighborWorkspace+  , workspaceBytes+  , nearestNeighbor+  , barycentricWeights+  , naturalNeighborWeights+  , foldNaturalNeighborWeights+  , interpolateNearest+  , interpolateBarycentric+  , interpolateNaturalNeighbor+  , estimateGradient+  , estimateGradients+  , interpolateNaturalNeighborGradient+  ) where++import Control.DeepSeq (NFData)+import Control.Monad.ST (ST)+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32)+import Moonlight.Triangulation.Dcel+  ( destination+  , counterClockwise+  , foldVertexOutgoingEdges'+  , incidentFace+  , innerFaceDirectedEdges+  , innerFaceVertices+  , isBoundaryEdge+  , next+  , numConstraints+  , numDirectedEdges+  , numVertices+  , origin+  , outerFace+  , vertexOutEdge+  , vertexPoint+  )+import Moonlight.Triangulation.Internal.HandleDefs+  ( DirectedEdgeId (..)+  , asUndirected+  , FaceId (..)+  , faceIdIndex+  , VertexId (..)+  , reverseEdge+  , vertexIdIndex+  )+import Moonlight.Triangulation.Internal.InterpolationWorkspace+import Moonlight.Triangulation.Internal.Predicates (inCircle)+import Moonlight.Triangulation.Math+  ( barycentricCoordinates+  , circumcenter+  , isFinite+  , projectionFactor+  , squaredDistanceWide+  )+import Moonlight.Triangulation.PointLocation (locatePointWithHint)+import Moonlight.Triangulation.Scalar (scalarEpsilon)+import Moonlight.Triangulation.Types+  ( Location (..)+  , LocationHint+  , LocationStats+  , NearestStats (..)+  , Point (..)+  , QueryPoint+  , queryPointValue+  , Triangulation+  )+import GHC.Generics (Generic)++-- | Barycentric weights use the mesh's binary64 coordinate domain.+data BarycentricWeights+  = NoWeights+  | OneWeight !VertexId+  | TwoWeights !VertexId !Double !VertexId !Double+  | ThreeWeights !VertexId !Double !VertexId !Double !VertexId !Double+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Work performed by one natural-neighbor query.+data InterpolationStats = InterpolationStats+  { interpolationCavityFaces :: {-# UNPACK #-} !Int+    -- ^ Faces in the query insertion cavity.+  , interpolationNaturalNeighbors :: {-# UNPACK #-} !Int+    -- ^ Sites contributing nonzero Sibson weight.+  , interpolationFaceTests :: {-# UNPACK #-} !Int+    -- ^ Faces tested while discovering the cavity.+    -- | 'True' exactly when the Sibson pipeline declined and the returned+    -- weights are the barycentric coordinates of the located face instead.+    -- A silent degradation from Sibson to barycentric is a defect that hides;+    -- this bit is the announcement.+  , interpolationUsedFallback :: !Bool+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Weights and receipts produced by one natural-neighbor query.+data NaturalNeighborResult = NaturalNeighborResult+  { naturalNeighborValues :: !(V.Vector (VertexId, Double))+    -- ^ Nonzero weights keyed by source vertex.+  , naturalNeighborLocationStats :: !LocationStats+    -- ^ Work performed while locating the query.+  , naturalNeighborStats :: !InterpolationStats+    -- ^ Work performed while constructing the Sibson coordinates.+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Nearest vertex and query work, using an optional admitted vertex as the+-- descent seed. Empty triangulations have no nearest vertex.+nearestNeighbor+  :: Triangulation mode vertex directed undirected face+  -> Maybe VertexId+  -> QueryPoint+  -> Maybe (VertexId, NearestStats)+nearestNeighbor triangulation hint queryPoint+  | numVertices triangulation == 0 = Nothing+  | numConstraints triangulation == 0 = Just (descend start startDistance 0 0)+  | otherwise = Just (walk start startDistance 0 0)+ where+  !query = queryPointValue queryPoint+  !start = validateHint hint+  !startDistance = squaredDistanceWide query (vertexPoint triangulation start)+  !bound = numDirectedEdges triangulation + numVertices triangulation + 1++  validateHint (Just vertex)+    | vertexIdIndex vertex < numVertices triangulation = vertex+  validateHint _ = VertexId 0++  -- A vertex's Voronoi cell is the intersection of the half-planes its+  -- Delaunay neighbours induce, so a query outside that cell violates one of+  -- them and some neighbour is strictly closer. Descending on the /first/+  -- strict improvement therefore lands on the same vertex as descending on the+  -- best one, having tested about half of the star on average instead of all+  -- of it. The argument needs the Delaunay property, so a constrained+  -- triangulation keeps the exhaustive scan below.+  descend !current !currentDistance !steps !tests+    | steps >= bound = (current, NearestStats steps tests)+    | otherwise =+        case vertexOutEdge triangulation current of+          Nothing -> (current, NearestStats steps tests)+          Just ring -> revolve current currentDistance steps ring ring Nothing tests++  -- Equal-distance neighbours are not an improvement, so they cannot end the+  -- revolution early; the lowest such handle is carried to the end and taken+  -- only if nothing strictly closer appeared. That is the same deterministic+  -- tie the exhaustive scan settles on.+  revolve !current !currentDistance !steps !edge !ring !tie !tests+    | candidateDistance < currentDistance =+        descend candidate candidateDistance (steps + 1) nextTests+    | nextEdge == ring =+        case nextTie of+          Just settled -> descend settled currentDistance (steps + 1) nextTests+          Nothing -> (current, NearestStats steps nextTests)+    | otherwise = revolve current currentDistance steps nextEdge ring nextTie nextTests+   where+    !candidate = destination triangulation edge+    !candidateDistance = squaredDistanceWide query (vertexPoint triangulation candidate)+    !nextTests = tests + 1+    !nextEdge = counterClockwise triangulation edge+    !nextTie+      | candidateDistance == currentDistance && candidate < current =+          case tie of+            Just held | held <= candidate -> tie+            _ -> Just candidate+      | otherwise = tie++  walk !current !currentDistance !steps !tests+    | steps >= bound = (current, NearestStats steps tests)+    | otherwise =+        let (!candidate, !candidateDistance, !newTests) =+              foldVertexOutgoingEdges'+                triangulation+                current+                inspect+                (current, currentDistance, tests)+         in if candidate == current+              then (current, NearestStats steps newTests)+              else walk candidate candidateDistance (steps + 1) newTests++  inspect (!best, !bestDistance, !tests) edge =+    let !candidate = destination triangulation edge+        !candidateDistance = squaredDistanceWide query (vertexPoint triangulation candidate)+        !isBetter =+          candidateDistance < bestDistance+            || (candidateDistance == bestDistance && candidate < best)+     in if isBetter+          then (candidate, candidateDistance, tests + 1)+          else (best, bestDistance, tests + 1)++-- | Barycentric weights at a validated query, plus point-location work.+barycentricWeights+  :: Triangulation mode vertex directed undirected face+  -> Maybe LocationHint+  -> QueryPoint+  -> (BarycentricWeights, LocationStats)+barycentricWeights triangulation hint queryPoint =+  let !query = queryPointValue queryPoint+      (!location, !stats) = locatePointWithHint triangulation hint queryPoint+   in (weightsFor query location, stats)+ where+  weightsFor _ (OnVertex vertex) = OneWeight vertex+  weightsFor query (OnEdge edge) =+    let !from = origin triangulation edge+        !to = destination triangulation edge+        !factor = clamp 0 1 (projectionFactor (vertexPoint triangulation from) (vertexPoint triangulation to) query)+     in TwoWeights from (1 - factor) to factor+  weightsFor query (InFace face) =+    case innerFaceVertices triangulation face of+      Nothing -> NoWeights+      Just (a, b, c) ->+        case barycentricCoordinates+          (vertexPoint triangulation a)+          (vertexPoint triangulation b)+          (vertexPoint triangulation c)+          query of+          Nothing -> NoWeights+          Just (wa, wb, wc) -> ThreeWeights a wa b wb c wc+  weightsFor _ EmptyTriangulation = NoWeights+  weightsFor _ (OutsideConvexHull _) = NoWeights++-- | Calculate Sibson coordinates using fixed-capacity reusable scratch storage.+-- The only per-query heap object is the returned boxed vector.+naturalNeighborWeights+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Maybe LocationHint+  -> QueryPoint+  -> ST s (NaturalNeighborResult)+naturalNeighborWeights workspace hint queryPoint = do+  (!count, !locationStats, !stats) <- queryNaturalNeighborWorkspace workspace hint queryPoint+  values <- V.generateM count $ \index -> do+    rawVertex <- MUV.unsafeRead (nnWeightVertex workspace) index+    weight <- MUV.unsafeRead (nnWeightValue workspace) index+    pure (VertexId rawVertex, weight)+  pure NaturalNeighborResult+    { naturalNeighborValues = values+    , naturalNeighborLocationStats = locationStats+    , naturalNeighborStats = stats+    }++-- | Strictly fold the Sibson coordinates held in a reusable workspace. Unlike+-- 'naturalNeighborWeights', this does not allocate a result vector. It is the+-- canonical path for repeated interpolation and other reductions.+foldNaturalNeighborWeights+  :: (accumulator -> VertexId -> Double -> accumulator)+  -> accumulator+  -> NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Maybe LocationHint+  -> QueryPoint+  -> ST s (accumulator, LocationStats, InterpolationStats)+foldNaturalNeighborWeights combine initial workspace hint query = do+  (!count, !locationStats, !stats) <- queryNaturalNeighborWorkspace workspace hint query+  value <- go 0 initial count+  pure (value, locationStats, stats)+ where+  go !index !accumulator !count+    | index >= count = pure accumulator+    | otherwise = do+        rawVertex <- MUV.unsafeRead (nnWeightVertex workspace) index+        weight <- MUV.unsafeRead (nnWeightValue workspace) index+        let !nextAccumulator = combine accumulator (VertexId rawVertex) weight+        go (index + 1) nextAccumulator count++queryNaturalNeighborWorkspace+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Maybe LocationHint+  -> QueryPoint+  -> ST s (Int, LocationStats, InterpolationStats)+queryNaturalNeighborWorkspace workspace hint queryPoint = do+  let !triangulation = nnTriangulation workspace+      !query = queryPointValue queryPoint+      (!location, !locationStats) = locatePointWithHint triangulation hint queryPoint+  (!count, !stats) <- case location of+    OnVertex vertex -> do+      writeWeight workspace 0 vertex 1+      pure (1, InterpolationStats 0 1 0 False)+    OnEdge edge+      | isBoundaryEdge triangulation (asUndirected edge) -> do+          let !from = origin triangulation edge+              !to = destination triangulation edge+              !factor = clamp 0 1 (projectionFactor (vertexPoint triangulation from) (vertexPoint triangulation to) query)+          writeWeight workspace 0 from (1 - factor)+          writeWeight workspace 1 to factor+          pure (2, InterpolationStats 0 2 0 False)+      | otherwise ->+          let !left = incidentFace triangulation edge+              !right = incidentFace triangulation (reverseEdge edge)+              !start = if left /= outerFace then left else right+           in sibsonQuery workspace query start+    InFace face -> sibsonQuery workspace query face+    EmptyTriangulation -> pure (0, InterpolationStats 0 0 0 False)+    OutsideConvexHull _ -> pure (0, InterpolationStats 0 0 0 False)+  pure (count, locationStats, stats)++sibsonQuery+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Point+  -> FaceId+  -> ST s (Int, InterpolationStats)+sibsonQuery workspace query startFace = do+  generation <- nextFaceGeneration workspace+  (cavityCount, faceTests) <- discoverCavity workspace generation query startFace+  boundaryCount <- collectBoundary workspace generation cavityCount+  orderedCount <- orderBoundary workspace boundaryCount+  if orderedCount < 3+    then fallbackBarycentric workspace query startFace faceTests cavityCount+    else do+      cellOkay <- buildInsertionCell workspace query orderedCount+      if not cellOkay+        then fallbackBarycentric workspace query startFace faceTests cavityCount+        else do+          weightCount <- buildStolenAreas workspace generation query orderedCount+          normalized <- normalizeWeights workspace weightCount+          if normalized+            then pure (weightCount, InterpolationStats cavityCount weightCount faceTests False)+            else fallbackBarycentric workspace query startFace faceTests cavityCount++-- The query cavity is exactly the set of faces whose circumcircles contain the+-- inserted point. Generation marks make clearing O(1).+discoverCavity+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Word32+  -> Point+  -> FaceId+  -> ST s (Int, Int)+discoverCavity workspace generation query startFace@(FaceId rawStart) = do+  MUV.unsafeWrite (nnFaceSeenMarks workspace) (faceIdIndex startFace) generation+  MUV.unsafeWrite (nnFaceQueue workspace) 0 rawStart+  go 1 0 0+ where+  !triangulation = nnTriangulation workspace+  go !queueSize !cavitySize !tests+    | queueSize <= 0 = pure (cavitySize, tests)+    | otherwise = do+        let !slot = queueSize - 1+        rawFace <- MUV.unsafeRead (nnFaceQueue workspace) slot+        let !face = FaceId rawFace+            !inside = containsQuery triangulation query face+            !tests' = tests + 1+        if not inside+          then go slot cavitySize tests'+          else do+            MUV.unsafeWrite (nnFaceMarks workspace) (faceIdIndex face) generation+            MUV.unsafeWrite (nnCavityFaces workspace) cavitySize rawFace+            nextQueue <- pushNeighbors triangulation workspace generation slot face+            go nextQueue (cavitySize + 1) tests'++containsQuery+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> FaceId+  -> Bool+containsQuery triangulation query face =+  case innerFaceVertices triangulation face of+    Nothing -> False+    Just (a, b, c) ->+      -- Strictly inside, matching spade's contained_in_circumference: an+      -- exactly cocircular face is NOT part of the cavity, so its opposite+      -- vertex is not a natural neighbour. A '/= LT' reading would include+      -- such a vertex with a zero stolen area and diverge from spade's+      -- neighbour set on cocircular queries.+      inCircle+        (vertexPoint triangulation a)+        (vertexPoint triangulation b)+        (vertexPoint triangulation c)+        query+        == GT++pushNeighbors+  :: Triangulation mode vertex directed undirected face+  -> NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Word32+  -> Int+  -> FaceId+  -> ST s Int+pushNeighbors triangulation workspace generation start face =+  case innerFaceDirectedEdges triangulation face of+    Nothing -> pure start+    Just (e0, e1, e2) -> do+      size1 <- pushOne start e0+      size2 <- pushOne size1 e1+      pushOne size2 e2+ where+  pushOne !size edge =+    let !adjacent@(FaceId raw) = incidentFace triangulation (reverseEdge edge)+        !index = faceIdIndex adjacent+     in if adjacent == outerFace+          then pure size+          else do+            seen <- MUV.unsafeRead (nnFaceSeenMarks workspace) index+            if seen == generation+              then pure size+              else do+                MUV.unsafeWrite (nnFaceSeenMarks workspace) index generation+                MUV.unsafeWrite (nnFaceQueue workspace) size raw+                pure (size + 1)++collectBoundary+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Word32+  -> Int+  -> ST s Int+collectBoundary workspace generation cavityCount = goFaces 0 0+ where+  !triangulation = nnTriangulation workspace+  goFaces !index !boundarySize+    | index >= cavityCount = pure boundarySize+    | otherwise = do+        rawFace <- MUV.unsafeRead (nnCavityFaces workspace) index+        nextSize <- case innerFaceDirectedEdges triangulation (FaceId rawFace) of+          Nothing -> pure boundarySize+          Just (e0, e1, e2) -> do+            size1 <- appendIfBoundary boundarySize e0+            size2 <- appendIfBoundary size1 e1+            appendIfBoundary size2 e2+        goFaces (index + 1) nextSize+  appendIfBoundary !size edge = do+    let adjacent = incidentFace triangulation (reverseEdge edge)+    outside <- if adjacent == outerFace+      then pure True+      else (/= generation) <$> MUV.unsafeRead (nnFaceMarks workspace) (faceIdIndex adjacent)+    if outside+      then case edge of+        DirectedEdgeId raw -> MUV.unsafeWrite (nnBoundaryEdges workspace) size raw >> pure (size + 1)+      else pure size++orderBoundary+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Int+  -> ST s Int+orderBoundary _ 0 = pure 0+orderBoundary workspace count = do+  generation <- nextOriginGeneration workspace+  install generation 0+  firstRaw <- MUV.unsafeRead (nnBoundaryEdges workspace) 0+  follow generation firstRaw firstRaw 0+ where+  !triangulation = nnTriangulation workspace+  install !generation !index+    | index >= count = pure ()+    | otherwise = do+        rawEdge <- MUV.unsafeRead (nnBoundaryEdges workspace) index+        let !from = vertexIdIndex (origin triangulation (DirectedEdgeId rawEdge))+        MUV.unsafeWrite (nnOriginMarks workspace) from generation+        MUV.unsafeWrite (nnOriginEdge workspace) from rawEdge+        install generation (index + 1)+  follow !generation !firstRaw !currentRaw !index+    | index >= count =+        if currentRaw == firstRaw then pure count else pure 0+    | otherwise = do+        MUV.unsafeWrite (nnOrderedEdges workspace) index currentRaw+        let !to = vertexIdIndex (destination triangulation (DirectedEdgeId currentRaw))+        marked <- MUV.unsafeRead (nnOriginMarks workspace) to+        if marked /= generation+          then pure 0+          else do+            nextRaw <- MUV.unsafeRead (nnOriginEdge workspace) to+            if nextRaw == firstRaw && index + 1 == count+              then pure count+              else if nextRaw == firstRaw+                then pure 0+                else follow generation firstRaw nextRaw (index + 1)++buildInsertionCell+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Point+  -> Int+  -> ST s Bool+buildInsertionCell workspace query count = go 0+ where+  !triangulation = nnTriangulation workspace+  go !index+    | index >= count = pure True+    | otherwise = do+        rawEdge <- MUV.unsafeRead (nnOrderedEdges workspace) index+        let !edge = DirectedEdgeId rawEdge+            !from = vertexPoint triangulation (origin triangulation edge)+            !to = vertexPoint triangulation (destination triangulation edge)+        case circumcenter (subtractPoint to query) (subtractPoint from query) (Point 0 0) of+          Nothing -> pure False+          Just (Point x y)+            | isFinite x && isFinite y -> do+                MUV.unsafeWrite (nnInsertionX workspace) index x+                MUV.unsafeWrite (nnInsertionY workspace) index y+                go (index + 1)+            | otherwise -> pure False++buildStolenAreas+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Word32+  -> Point+  -> Int+  -> ST s Int+buildStolenAreas workspace generation query count = do+  lastRaw <- MUV.unsafeRead (nnOrderedEdges workspace) (count - 1)+  lastX <- MUV.unsafeRead (nnInsertionX workspace) (count - 1)+  lastY <- MUV.unsafeRead (nnInsertionY workspace) (count - 1)+  go 0 (DirectedEdgeId lastRaw) (Point lastX lastY)+ where+  !triangulation = nnTriangulation workspace+  go !index !lastEdge !lastPoint+    | index >= count = pure count+    | otherwise = do+        rawStop <- MUV.unsafeRead (nnOrderedEdges workspace) index+        firstX <- MUV.unsafeRead (nnInsertionX workspace) index+        firstY <- MUV.unsafeRead (nnInsertionY workspace) index+        let !stopEdge = DirectedEdgeId rawStop+            !first = Point firstX firstY+        area <- stolenArea workspace generation query stopEdge first lastEdge lastPoint+        case area of+          Nothing -> pure 0+          Just polygonArea -> do+            writeWeight workspace index (origin triangulation stopEdge) polygonArea+            go (index + 1) stopEdge first++stolenArea+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Word32+  -> Point+  -> DirectedEdgeId+  -> Point+  -> DirectedEdgeId+  -> Point+  -> ST s (Maybe Double)+stolenArea workspace generation query stopEdge first initialEdge initialPoint =+  walk initialEdge initialPoint initialPositive initialNegative 0+ where+  !triangulation = nnTriangulation workspace+  -- The boundary loop runs counterclockwise around the cavity, so the fan+  -- walk around each boundary vertex necessarily runs clockwise: the+  -- shoelace sequence first, lastPoint, circumcenters... is the clockwise+  -- traversal of the stolen polygon, and positive - negative is the+  -- NEGATED twice-area. The result is negated here so the returned value is+  -- the positive twice-area 'normalizeWeights' requires. (spade's identical+  -- walk leaves the sum negative and cancels the sign in its total; its+  -- "ordered ccw" comment is wrong.)+  !initialPositive = pointX first * pointY initialPoint+  !initialNegative = pointY first * pointX initialPoint+  !target = reverseEdge stopEdge+  !limit = numDirectedEdges triangulation + 1+  walk !lastEdge !lastPoint !positive !negative !steps+    | steps >= limit = pure Nothing+    | face == outerFace = pure Nothing+    | otherwise = do+        center <- cachedFaceCircumcenter workspace generation query face+        case center of+          Nothing -> pure Nothing+          Just current ->+            let !positive' = positive + pointX lastPoint * pointY current+                !negative' = negative + pointY lastPoint * pointX current+                !nextEdge = reverseEdge (next triangulation lastEdge)+             in if nextEdge == target+                  then+                    let !closedPositive = positive' + pointX current * pointY first+                        !closedNegative = negative' + pointY current * pointX first+                     in pure (Just (closedNegative - closedPositive))+                  else walk nextEdge current positive' negative' (steps + 1)+   where+    face = incidentFace triangulation lastEdge++-- Each fan turns around the vertex two consecutive boundary edges share, so a+-- cavity face is walked once per vertex it has on the boundary loop: twice for+-- two, three times for a face whose whole triangle is on the loop, which is+-- every face of a single-face cavity. Without this plane each of those visits+-- pays two divisions and a dozen multiply-adds for a value already in hand.+--+-- The cached value is the one 'faceCircumcenterRelative' returned, stored as+-- its own coordinates and handed back unchanged; nothing is recomputed from a+-- rearrangement, so a hit and a miss are the same bits. Soundness needs only+-- that the query point cannot change while an entry is readable, which the+-- generation supplies: it is minted once per Sibson query and every stamp from+-- an earlier query is strictly smaller.+--+-- A 'Nothing' is not recorded. It cannot repeat: the first one aborts this+-- fan, and 'buildStolenAreas' abandons the query on the spot.+cachedFaceCircumcenter+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Word32+  -> Point+  -> FaceId+  -> ST s (Maybe (Point))+cachedFaceCircumcenter workspace generation query face = do+  stamp <- MUV.unsafeRead (nnCircumcenterMarks workspace) slot+  if stamp == generation+    then do+      x <- MUV.unsafeRead (nnCircumcenterX workspace) slot+      y <- MUV.unsafeRead (nnCircumcenterY workspace) slot+      pure (Just (Point x y))+    else case faceCircumcenterRelative (nnTriangulation workspace) query face of+      Nothing -> pure Nothing+      Just center@(Point x y) -> do+        MUV.unsafeWrite (nnCircumcenterX workspace) slot x+        MUV.unsafeWrite (nnCircumcenterY workspace) slot y+        MUV.unsafeWrite (nnCircumcenterMarks workspace) slot generation+        pure (Just center)+ where+  !slot = faceIdIndex face++faceCircumcenterRelative+  :: Triangulation mode vertex directed undirected face+  -> Point+  -> FaceId+  -> Maybe (Point)+faceCircumcenterRelative triangulation query face = do+  (a, b, c) <- innerFaceVertices triangulation face+  center <- circumcenter+    (subtractPoint (vertexPoint triangulation a) query)+    (subtractPoint (vertexPoint triangulation b) query)+    (subtractPoint (vertexPoint triangulation c) query)+  if finitePoint center then Just center else Nothing++normalizeWeights+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Int+  -> ST s Bool+normalizeWeights _ 0 = pure False+normalizeWeights workspace count = do+  (!total, !minimumWeight, !finite) <- firstPass 0 0 0 True+  let !tolerance = max 1.0e-12 (128 * scalarEpsilon)+  if not finite || total == 0 || minimumWeight < negate tolerance+    then pure False+    else do+      clampedTotal <- clampPass 0 0+      if clampedTotal <= 0 || not (isFinite clampedTotal)+        then pure False+        else normalizePass 0 clampedTotal >> pure True+ where+  firstPass !index !total !minimumWeight !finite+    | index >= count = pure (total, minimumWeight, finite)+    | otherwise = do+        weight <- MUV.unsafeRead (nnWeightValue workspace) index+        let !minimumWeight' = if index == 0 then weight else min minimumWeight weight+        firstPass (index + 1) (total + weight) minimumWeight' (finite && isFinite weight)+  clampPass !index !total+    | index >= count = pure total+    | otherwise = do+        weight <- MUV.unsafeRead (nnWeightValue workspace) index+        let !clamped = max 0 weight+        MUV.unsafeWrite (nnWeightValue workspace) index clamped+        clampPass (index + 1) (total + clamped)+  normalizePass !index !total+    | index >= count = pure ()+    | otherwise = do+        weight <- MUV.unsafeRead (nnWeightValue workspace) index+        MUV.unsafeWrite (nnWeightValue workspace) index (weight / total)+        normalizePass (index + 1) total++fallbackBarycentric+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Point+  -> FaceId+  -> Int+  -> Int+  -> ST s (Int, InterpolationStats)+fallbackBarycentric workspace query face faceTests cavityCount =+  case innerFaceVertices triangulation face of+    Nothing -> pure (0, InterpolationStats cavityCount 0 faceTests True)+    Just (a, b, c) ->+      case barycentricCoordinates+        (vertexPoint triangulation a)+        (vertexPoint triangulation b)+        (vertexPoint triangulation c)+        query of+        Nothing -> pure (0, InterpolationStats cavityCount 0 faceTests True)+        Just (wa, wb, wc) -> do+          writeWeight workspace 0 a wa+          writeWeight workspace 1 b wb+          writeWeight workspace 2 c wc+          pure (3, InterpolationStats cavityCount 3 faceTests True)+ where+  triangulation = nnTriangulation workspace++writeWeight+  :: NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Int+  -> VertexId+  -> Double+  -> ST s ()+writeWeight workspace index (VertexId vertex) weight = do+  MUV.unsafeWrite (nnWeightVertex workspace) index vertex+  MUV.unsafeWrite (nnWeightValue workspace) index weight++-- | Sample the nearest vertex, or return 'Nothing' for an empty mesh.+interpolateNearest+  :: (VertexId -> value)+  -> Triangulation mode vertex directed undirected face+  -> Maybe VertexId+  -> QueryPoint+  -> Maybe value+interpolateNearest sample triangulation hint query = sample . fst <$> nearestNeighbor triangulation hint query++-- | Interpolate scalar vertex samples in the cell containing the query.+interpolateBarycentric+  :: (VertexId -> Double)+  -> Triangulation mode vertex directed undirected face+  -> Maybe LocationHint+  -> QueryPoint+  -> Maybe Double+interpolateBarycentric sample triangulation hint query =+  case fst (barycentricWeights triangulation hint query) of+    NoWeights -> Nothing+    OneWeight vertex -> Just (sample vertex)+    TwoWeights a wa b wb -> Just (wa * sample a + wb * sample b)+    ThreeWeights a wa b wb c wc -> Just (wa * sample a + wb * sample b + wc * sample c)++-- | Interpolate from reusable Sibson weights.+interpolateNaturalNeighbor+  :: (VertexId -> Double)+  -> NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Maybe LocationHint+  -> QueryPoint+  -> ST s (Maybe Double, InterpolationStats)+interpolateNaturalNeighbor sample workspace hint query = do+  (total, _, stats) <-+    foldNaturalNeighborWeights+      (\accumulator vertex weight -> accumulator + weight * sample vertex)+      0+      workspace+      hint+      query+  pure (if interpolationNaturalNeighbors stats == 0 then Nothing else Just total, stats)++-- | Estimate one vertex gradient from its Delaunay neighbors.+estimateGradient+  :: (VertexId -> Double)+  -> Triangulation mode vertex directed undirected face+  -> VertexId+  -> (Double, Double)+estimateGradient sample triangulation vertex =+  case vertexOutEdge triangulation vertex of+    Nothing -> (0, 0)+    Just start ->+      let !nextEdge = counterClockwise triangulation start+       in if nextEdge == start+            then (0, 0)+            else+              let (!nx, !ny, !nz) = walk start start 0 0 0 0+               in if nz /= 0 && isFinite nz then (-nx / nz, -ny / nz) else (0, 0)+ where+  Point vx vy = vertexPoint triangulation vertex+  !vz = sample vertex+  !bound = numDirectedEdges triangulation + 1++  walk !start !current !steps !sumX !sumY !sumZ+    | steps >= bound = (sumX, sumY, sumZ)+    | otherwise =+        let !nextEdge = counterClockwise triangulation current+            !leftVertex = destination triangulation current+            !rightVertex = destination triangulation nextEdge+            (!nextX, !nextY, !nextZ) = accumulate sumX sumY sumZ leftVertex rightVertex+         in if nextEdge == start+              then (nextX, nextY, nextZ)+              else walk start nextEdge (steps + 1) nextX nextY nextZ++  accumulate !sumX !sumY !sumZ leftVertex rightVertex =+    let Point lx ly = vertexPoint triangulation leftVertex+        Point rx ry = vertexPoint triangulation rightVertex+        !lz = sample leftVertex+        !rz = sample rightVertex+        !d0x = lx - vx+        !d0y = ly - vy+        !d0z = lz - vz+        !d1x = rx - vx+        !d1y = ry - vy+        !d1z = rz - vz+        !normalX = d0y * d1z - d0z * d1y+        !normalY = d0z * d1x - d0x * d1z+        !normalZ = d0x * d1y - d0y * d1x+     in if normalZ > 0+          then (sumX + normalX, sumY + normalY, sumZ + normalZ)+          else (sumX, sumY, sumZ)++-- | Estimate gradients for every vertex in handle order.+estimateGradients+  :: (VertexId -> Double)+  -> Triangulation mode vertex directed undirected face+  -> V.Vector (Double, Double)+estimateGradients sample triangulation =+  V.generate (numVertices triangulation) $ \index ->+    estimateGradient sample triangulation (VertexId (fromIntegral index))++-- | Natural-neighbor interpolation with nodal-gradient correction.+interpolateNaturalNeighborGradient+  :: (VertexId -> Double)+  -> (VertexId -> (Double, Double))+  -> Double+  -> NaturalNeighborWorkspace s mode vertex directed undirected face+  -> Maybe LocationHint+  -> QueryPoint+  -> ST s (Maybe Double, InterpolationStats)+interpolateNaturalNeighborGradient sample gradient flatness workspace hint queryPoint+  | flatness < 0 || not (isFinite flatness) = pure (Nothing, InterpolationStats 0 0 0 False)+  | otherwise = do+      (!count, _, !stats) <- queryNaturalNeighborWorkspace workspace hint queryPoint+      if count == 0+        then pure (Nothing, stats)+        else do+          accumulation <- accumulate 0 count Nothing (0, 0, 0, 0, 0)+          pure (finish accumulation, stats)+ where+  !query = queryPointValue queryPoint+  !triangulation = nnTriangulation workspace++  -- 'flatness' is 0.5 or 1 in practice and @**@ is an exp/log pair per natural+  -- neighbour per query, so both are answered directly. The two shortcuts do+  -- not stand on the same ground.+  --+  -- The identity is exact. @x@ raised to 1 is @x@, which is already a float,+  -- and rounding an exactly representable result admits only that result, so+  -- any implementation faithful to within an ulp returns it.+  --+  -- The square root is not exact and does not need to be. IEEE-754 mandates a+  -- correctly rounded 'sqrt'; @pow@ is a recommended operation carrying no such+  -- requirement. Where the two disagree it is therefore in the last ulp, and it+  -- is 'sqrt' that holds the correctly rounded answer — this substitution can+  -- only move the result toward it. Against this platform's libm they in fact+  -- agree on every non-negative binary32 and on every non-negative binary64+  -- sampled, which is a measurement and not a proof.+  --+  -- They part company at negative zero, where @pow@ answers @+0@ and 'sqrt'+  -- answers @-0@. A sum of two squares is never negative zero, and were it one+  -- the sole consumer below tests @== 0@, which both zeroes satisfy alike.+  raiseToFlatness squared+    | flatness == 0.5 = sqrt squared+    | flatness == 1 = squared+    | otherwise = squared ** flatness++  accumulate !index !count !exact !totals+    | index >= count = pure (exact, totals)+    | otherwise = do+        rawVertex <- MUV.unsafeRead (nnWeightVertex workspace) index+        weight <- MUV.unsafeRead (nnWeightValue workspace) index+        let !vertex = VertexId rawVertex+            !point = vertexPoint triangulation vertex+            !exact' =+              case exact of+                Just _ -> exact+                Nothing+                  | query == point -> Just (sample vertex)+                  | otherwise -> Nothing+            !totals' = contribution totals vertex weight+        accumulate (index + 1) count exact' totals'++  finish+    :: (Maybe Double, (Double, Double, Double, Double, Double))+    -> Maybe Double+  finish (Just value, _) = Just value+  finish (Nothing, (!sumC0, !sumC1, !sumC1Weights, !alphaNumerator, !beta))+    | sumC1Weights == 0 = Just sumC0+    | otherwise =+        let !alpha = alphaNumerator / sumC1Weights+            !c1 = sumC1 / sumC1Weights+            !denominator = alpha + beta+         in if denominator == 0 || not (isFinite denominator)+              then Just sumC0+              else Just ((alpha * sumC0 + beta * c1) / denominator)++  contribution (!sumC0, !sumC1, !sumC1Weights, !alpha, !beta) vertex weight =+    let Point qx qy = query+        Point vx vy = vertexPoint triangulation vertex+        !dx = qx - vx+        !dy = qy - vy+        !radiusSquared = dx * dx + dy * dy+        !radiusPower = raiseToFlatness radiusSquared+        !c1Weight = if radiusPower == 0 then 0 else weight / radiusPower+        (!gx, !gy) = gradient vertex+        !height = sample vertex+        !zeta = height + dx * gx + dy * gy+     in ( sumC0 + height * weight+        , sumC1 + zeta * c1Weight+        , sumC1Weights + c1Weight+        , alpha + c1Weight * radiusSquared+        , beta + weight * radiusSquared+        )++subtractPoint :: Point -> Point -> Point+subtractPoint (Point ax ay) (Point bx by) = Point (ax - bx) (ay - by)+{-# INLINE subtractPoint #-}++finitePoint :: Point -> Bool+finitePoint (Point x y) = isFinite x && isFinite y+{-# INLINE finitePoint #-}++clamp :: Ord value => value -> value -> value -> value+clamp low high = max low . min high+{-# INLINE clamp #-}
+ src-dual/Moonlight/Triangulation/Voronoi.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | The Voronoi dual, addressed by its own handle family: every cell, edge and+-- vertex is a view of the Delaunay mesh rather than a second structure.+module Moonlight.Triangulation.Voronoi+  ( VoronoiFaceId (..)+  , DirectedVoronoiEdgeId (..)+  , UndirectedVoronoiEdgeId (..)+  , VoronoiVertexId (..)+  , VoronoiEdgeGeometry (..)+  , voronoiFaces+  , directedVoronoiEdges+  , undirectedVoronoiEdges+  , asDelaunayDirectedEdge+  , asDelaunayUndirectedEdge+  , asDirectedVoronoiEdge+  , asUndirectedVoronoiEdge+  , reverseVoronoiEdge+  , voronoiNext+  , voronoiPrevious+  , voronoiFrom+  , voronoiTo+  , voronoiIncidentFace+  , voronoiFaceSite+  , voronoiFaceAdjacentEdges+  , voronoiVertexPosition+  , voronoiVertexOutgoingEdges+  , voronoiDirectionVector+  , voronoiEdgeGeometry+  , faceCircumcenter+  ) where++import Control.DeepSeq (NFData)+import Moonlight.Triangulation.Dcel+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (directedEdges, undirectedEdges, vertices)+import Moonlight.Triangulation.Math+import Moonlight.Triangulation.Types++-- | A Voronoi face, identified by its primal site.+--+-- The dual uses the exact same fixed-index space as the primal DCEL. These+-- newtypes add semantic separation without allocating or owning any dual mesh.+newtype VoronoiFaceId = VoronoiFaceId { unVoronoiFaceId :: VertexId }+  deriving stock (Show)+  deriving newtype (Eq, Ord, NFData)++-- | An oriented Voronoi edge, identified by its primal directed edge.+newtype DirectedVoronoiEdgeId = DirectedVoronoiEdgeId { unDirectedVoronoiEdgeId :: DirectedEdgeId }+  deriving stock (Show)+  deriving newtype (Eq, Ord, NFData)++-- | An unoriented Voronoi edge, identified by its primal undirected edge.+newtype UndirectedVoronoiEdgeId = UndirectedVoronoiEdgeId { unUndirectedVoronoiEdgeId :: UndirectedEdgeId }+  deriving stock (Show)+  deriving newtype (Eq, Ord, NFData)++-- | A finite dual vertex or an ideal endpoint of an unbounded dual edge.+data VoronoiVertexId+  = InnerVoronoiVertex !FaceId+  | OuterVoronoiVertex !DirectedVoronoiEdgeId+  deriving stock (Eq, Ord, Show)++-- | Finite segment, half-infinite ray, or infinite line in the dual.+data VoronoiEdgeGeometry+  = VoronoiSegment !(Point) !(Point)+  | VoronoiRay !(Point) !(Point)+  | VoronoiLine !(Point) !(Point)+  deriving stock (Eq, Ord, Show)++-- | Voronoi faces in primal vertex-handle order.+voronoiFaces :: Triangulation mode vertex directed undirected face -> [VoronoiFaceId]+voronoiFaces triangulation = map VoronoiFaceId (vertices triangulation)+{-# INLINE voronoiFaces #-}++-- | Directed Voronoi edges in primal directed-edge order.+--+-- Every primal directed edge is one directed edge in the dual. Boundary+-- handles naturally represent half-infinite edges through OuterVoronoiVertex.+directedVoronoiEdges :: Triangulation mode vertex directed undirected face -> [DirectedVoronoiEdgeId]+directedVoronoiEdges triangulation = map DirectedVoronoiEdgeId (directedEdges triangulation)+{-# INLINE directedVoronoiEdges #-}++-- | Undirected Voronoi edges in primal undirected-edge order.+undirectedVoronoiEdges :: Triangulation mode vertex directed undirected face -> [UndirectedVoronoiEdgeId]+undirectedVoronoiEdges triangulation = map UndirectedVoronoiEdgeId (undirectedEdges triangulation)+{-# INLINE undirectedVoronoiEdges #-}++-- | Recover the primal directed edge.+asDelaunayDirectedEdge :: DirectedVoronoiEdgeId -> DirectedEdgeId+asDelaunayDirectedEdge = unDirectedVoronoiEdgeId+{-# INLINE asDelaunayDirectedEdge #-}++-- | Recover the primal undirected edge.+asDelaunayUndirectedEdge :: UndirectedVoronoiEdgeId -> UndirectedEdgeId+asDelaunayUndirectedEdge = unUndirectedVoronoiEdgeId+{-# INLINE asDelaunayUndirectedEdge #-}++-- | View a primal directed edge in the dual handle family.+asDirectedVoronoiEdge :: DirectedEdgeId -> DirectedVoronoiEdgeId+asDirectedVoronoiEdge = DirectedVoronoiEdgeId+{-# INLINE asDirectedVoronoiEdge #-}++-- | View a primal undirected edge in the dual handle family.+asUndirectedVoronoiEdge :: UndirectedEdgeId -> UndirectedVoronoiEdgeId+asUndirectedVoronoiEdge = UndirectedVoronoiEdgeId+{-# INLINE asUndirectedVoronoiEdge #-}++-- | Reverse a directed Voronoi edge.+reverseVoronoiEdge :: DirectedVoronoiEdgeId -> DirectedVoronoiEdgeId+reverseVoronoiEdge (DirectedVoronoiEdgeId edge) = DirectedVoronoiEdgeId (reverseEdge edge)+{-# INLINE reverseVoronoiEdge #-}++-- | Next dual edge around the incident Voronoi face.+--+-- Dual next/previous rotate around the primal origin site.+voronoiNext+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> DirectedVoronoiEdgeId+voronoiNext triangulation (DirectedVoronoiEdgeId edge) =+  DirectedVoronoiEdgeId (counterClockwise triangulation edge)+{-# INLINE voronoiNext #-}++-- | Previous dual edge around the incident Voronoi face.+voronoiPrevious+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> DirectedVoronoiEdgeId+voronoiPrevious triangulation (DirectedVoronoiEdgeId edge) =+  DirectedVoronoiEdgeId (clockwise triangulation edge)+{-# INLINE voronoiPrevious #-}++-- | Origin dual vertex, including ideal endpoints on the hull.+voronoiFrom+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> VoronoiVertexId+voronoiFrom triangulation edge@(DirectedVoronoiEdgeId primal)+  | face == outerFace = OuterVoronoiVertex edge+  | otherwise = InnerVoronoiVertex face+ where+  face = incidentFace triangulation primal+{-# INLINE voronoiFrom #-}++-- | Destination dual vertex, including ideal endpoints on the hull.+voronoiTo+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> VoronoiVertexId+voronoiTo triangulation = voronoiFrom triangulation . reverseVoronoiEdge+{-# INLINE voronoiTo #-}++-- | Voronoi face to the left of a directed dual edge.+voronoiIncidentFace+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> VoronoiFaceId+voronoiIncidentFace triangulation (DirectedVoronoiEdgeId edge) =+  VoronoiFaceId (origin triangulation edge)+{-# INLINE voronoiIncidentFace #-}++-- | Primal site represented by a Voronoi face.+voronoiFaceSite :: VoronoiFaceId -> VertexId+voronoiFaceSite = unVoronoiFaceId+{-# INLINE voronoiFaceSite #-}++-- | Directed boundary of a Voronoi face.+voronoiFaceAdjacentEdges+  :: Triangulation mode vertex directed undirected face+  -> VoronoiFaceId+  -> [DirectedVoronoiEdgeId]+voronoiFaceAdjacentEdges triangulation (VoronoiFaceId site) =+  map DirectedVoronoiEdgeId (vertexOutgoingEdges triangulation site)+{-# INLINE voronoiFaceAdjacentEdges #-}++-- | Position of a finite dual vertex; ideal hull endpoints have no position.+--+-- A caller reaches this through 'voronoiFrom' or 'voronoiTo', which build the+-- endpoint sum immediately before it is taken apart again. Only an unfolding at+-- the consumer lets the two meet, so the constructor never reaches the heap.+voronoiVertexPosition+  :: Triangulation mode vertex directed undirected face+  -> VoronoiVertexId+  -> Maybe (Point)+voronoiVertexPosition triangulation vertex = case vertex of+  InnerVoronoiVertex face -> faceCircumcenter triangulation face+  OuterVoronoiVertex _ -> Nothing+{-# INLINE voronoiVertexPosition #-}++-- | Directed dual edges leaving a finite dual vertex.+voronoiVertexOutgoingEdges+  :: Triangulation mode vertex directed undirected face+  -> VoronoiVertexId+  -> Maybe [DirectedVoronoiEdgeId]+voronoiVertexOutgoingEdges triangulation vertex = case vertex of+  OuterVoronoiVertex _ -> Nothing+  InnerVoronoiVertex face ->+    map DirectedVoronoiEdgeId . faceDirectedEdges triangulation <$> nonOuter face+ where+  nonOuter face+    | face == outerFace = Nothing+    | otherwise = Just face+{-# INLINE voronoiVertexOutgoingEdges #-}++-- | Unit direction of the dual edge orthogonal to a primal edge.+voronoiDirectionVector+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> Point+voronoiDirectionVector triangulation (DirectedVoronoiEdgeId edge) =+  case vertexPoint triangulation (origin triangulation edge) of+    Point ax ay -> case vertexPoint triangulation (destination triangulation edge) of+      Point bx by -> Point (ay - by) (bx - ax)++-- | Circumcenter of a bounded primal face.+--+-- The circumcentre stands on the absolute vertex positions, which is a+-- different value from the query-relative one the Sibson pipeline caches: that+-- one rescales the differences it was handed, so translating the inputs moves+-- the rounding and the two do not differ by the translation. The interpolation+-- workspace's plane therefore cannot serve this function, and the repetition+-- here is across calls rather than within one — a sweep recomputes each face+-- once per incident dual edge, while a single call touches two distinct faces.+-- That threefold repetition is what a dual which is a view rather than a+-- structure costs, and the referent pays it identically, so no cache is owed.+faceCircumcenter+  :: Triangulation mode vertex directed undirected face+  -> FaceId+  -> Maybe (Point)+faceCircumcenter triangulation face+  | face == outerFace = Nothing+  | otherwise = case adjacentEdge triangulation face of+      Nothing -> Nothing+      Just e0 ->+        let !e1 = next triangulation e0+            !e2 = next triangulation e1+         in if next triangulation e2 /= e0+              then Nothing+              else+                circumcenter+                  (vertexPoint triangulation (origin triangulation e0))+                  (vertexPoint triangulation (origin triangulation e1))+                  (vertexPoint triangulation (origin triangulation e2))+{-# INLINE faceCircumcenter #-}++-- | Geometric realization of one dual edge.+--+-- The endpoint classification 'voronoiFrom' and 'voronoiTo' publish is two face+-- reads and two comparisons; taken through those observations it is also two+-- sum values built and immediately scrutinized. The geometry reads the faces+-- itself so that the classification stays in registers.+voronoiEdgeGeometry+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> Maybe (VoronoiEdgeGeometry)+voronoiEdgeGeometry triangulation edge@(DirectedVoronoiEdgeId primal)+  | innerFrom, innerTo =+      VoronoiSegment <$> faceCircumcenter triangulation fromFace <*> faceCircumcenter triangulation toFace+  | innerFrom = do+      start <- faceCircumcenter triangulation fromFace+      pure (VoronoiRay start (normalizeVector (voronoiDirectionVector triangulation edge)))+  | innerTo = do+      end <- faceCircumcenter triangulation toFace+      pure (VoronoiRay end (normalizeVector (negateVector (voronoiDirectionVector triangulation edge))))+  | otherwise =+      let !center = midpoint+            (vertexPoint triangulation (origin triangulation primal))+            (vertexPoint triangulation (destination triangulation primal))+       in Just (VoronoiLine center (normalizeVector (voronoiDirectionVector triangulation edge)))+ where+  !fromFace = incidentFace triangulation primal+  !toFace = incidentFace triangulation (reverseEdge primal)+  !innerFrom = fromFace /= outerFace+  !innerTo = toFace /= outerFace
+ src-dual/Moonlight/Triangulation/Voronoi/Handles.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE DataKinds #-}++-- | Zero-copy Voronoi views that retain the owning triangulation.+module Moonlight.Triangulation.Voronoi.Handles+  ( VoronoiFaceHandle+  , DirectedVoronoiEdgeHandle+  , UndirectedVoronoiEdgeHandle+  , VoronoiVertexHandle+  , voronoiFaceHandle+  , directedVoronoiEdgeHandle+  , undirectedVoronoiEdgeHandle+  , vertexAsVoronoiFaceH+  , directedEdgeAsVoronoiH+  , undirectedEdgeAsVoronoiH+  , innerFaceAsVoronoiVertexH+  , fixVoronoiFace+  , fixDirectedVoronoiEdge+  , fixUndirectedVoronoiEdge+  , fixVoronoiVertex+  , voronoiEdgeReverseH+  , voronoiEdgeNextH+  , voronoiEdgePreviousH+  , voronoiEdgeFromH+  , voronoiEdgeToH+  , voronoiEdgeFaceH+  , voronoiEdgeAsUndirectedH+  , voronoiEdgeAsDelaunayH+  , voronoiFaceSiteH+  , voronoiFaceAdjacentEdgesH+  , voronoiVertexPositionH+  , voronoiVertexOutEdgesH+  , voronoiVertexAsDelaunayFaceH+  , voronoiVertexAsOuterEdgeH+  , voronoiEdgeDirectionH+  , voronoiEdgeGeometryH+  ) where++import Moonlight.Triangulation.Handles.Dynamic+import Moonlight.Triangulation.Math (midpoint, negateVector, normalizeVector)+import Moonlight.Triangulation.Types+import Moonlight.Triangulation.Voronoi++-- | Zero-copy dual handles. Each dual value contains exactly one primal handle,+-- so it cannot accidentally combine an identifier from one triangulation with+-- the storage of another.+newtype VoronoiFaceHandle mode vertex directed undirected face =+  VoronoiFaceHandle (VertexHandle mode vertex directed undirected face)++-- | An owning handle to a directed dual edge.+newtype DirectedVoronoiEdgeHandle mode vertex directed undirected face =+  DirectedVoronoiEdgeHandle (DirectedEdgeHandle mode vertex directed undirected face)++-- | An owning handle to an undirected dual edge.+newtype UndirectedVoronoiEdgeHandle mode vertex directed undirected face =+  UndirectedVoronoiEdgeHandle (UndirectedEdgeHandle mode vertex directed undirected face)++-- | An owning handle to a finite or ideal dual vertex.+data VoronoiVertexHandle mode vertex directed undirected face+  = InnerVoronoiVertexHandle+      !(FaceHandle InnerTag mode vertex directed undirected face)+  | OuterVoronoiVertexHandle+      !(DirectedVoronoiEdgeHandle mode vertex directed undirected face)++instance Show (VoronoiFaceHandle mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixVoronoiFace++instance Show (DirectedVoronoiEdgeHandle mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixDirectedVoronoiEdge++instance Show (UndirectedVoronoiEdgeHandle mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixUndirectedVoronoiEdge++instance Show (VoronoiVertexHandle mode vertex directed undirected face) where+  showsPrec precedence = showsPrec precedence . fixVoronoiVertex++-- | Admit a fixed Voronoi face identifier into a triangulation.+voronoiFaceHandle+  :: Triangulation mode vertex directed undirected face+  -> VoronoiFaceId+  -> Maybe (VoronoiFaceHandle mode vertex directed undirected face)+voronoiFaceHandle triangulation (VoronoiFaceId site) =+  VoronoiFaceHandle <$> vertexHandle triangulation site++-- | View an admitted primal vertex as its Voronoi face.+vertexAsVoronoiFaceH+  :: VertexHandle mode vertex directed undirected face+  -> VoronoiFaceHandle mode vertex directed undirected face+vertexAsVoronoiFaceH = VoronoiFaceHandle++-- | Admit a fixed directed Voronoi edge identifier into a triangulation.+directedVoronoiEdgeHandle+  :: Triangulation mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+  -> Maybe (DirectedVoronoiEdgeHandle mode vertex directed undirected face)+directedVoronoiEdgeHandle triangulation (DirectedVoronoiEdgeId edge) =+  DirectedVoronoiEdgeHandle <$> directedEdgeHandle triangulation edge++-- | View an admitted primal directed edge in the dual handle family.+directedEdgeAsVoronoiH+  :: DirectedEdgeHandle mode vertex directed undirected face+  -> DirectedVoronoiEdgeHandle mode vertex directed undirected face+directedEdgeAsVoronoiH = DirectedVoronoiEdgeHandle++-- | Admit a fixed undirected Voronoi edge identifier into a triangulation.+undirectedVoronoiEdgeHandle+  :: Triangulation mode vertex directed undirected face+  -> UndirectedVoronoiEdgeId+  -> Maybe (UndirectedVoronoiEdgeHandle mode vertex directed undirected face)+undirectedVoronoiEdgeHandle triangulation (UndirectedVoronoiEdgeId edge) =+  UndirectedVoronoiEdgeHandle <$> undirectedEdgeHandle triangulation edge++-- | View an admitted primal undirected edge in the dual handle family.+undirectedEdgeAsVoronoiH+  :: UndirectedEdgeHandle mode vertex directed undirected face+  -> UndirectedVoronoiEdgeHandle mode vertex directed undirected face+undirectedEdgeAsVoronoiH = UndirectedVoronoiEdgeHandle++-- | View an admitted bounded primal face as a finite dual vertex.+innerFaceAsVoronoiVertexH+  :: FaceHandle InnerTag mode vertex directed undirected face+  -> VoronoiVertexHandle mode vertex directed undirected face+innerFaceAsVoronoiVertexH = InnerVoronoiVertexHandle++-- | Forget ownership and recover a fixed Voronoi face identifier.+fixVoronoiFace :: VoronoiFaceHandle mode vertex directed undirected face -> VoronoiFaceId+fixVoronoiFace (VoronoiFaceHandle site) = VoronoiFaceId (fixVertex site)+{-# INLINE fixVoronoiFace #-}++-- | Forget ownership and recover a fixed directed dual edge identifier.+fixDirectedVoronoiEdge+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> DirectedVoronoiEdgeId+fixDirectedVoronoiEdge (DirectedVoronoiEdgeHandle edge) =+  DirectedVoronoiEdgeId (fixDirectedEdge edge)+{-# INLINE fixDirectedVoronoiEdge #-}++-- | Forget ownership and recover a fixed undirected dual edge identifier.+fixUndirectedVoronoiEdge+  :: UndirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> UndirectedVoronoiEdgeId+fixUndirectedVoronoiEdge (UndirectedVoronoiEdgeHandle edge) =+  UndirectedVoronoiEdgeId (fixUndirectedEdge edge)+{-# INLINE fixUndirectedVoronoiEdge #-}++-- | Forget ownership and recover a fixed dual vertex identifier.+fixVoronoiVertex+  :: VoronoiVertexHandle mode vertex directed undirected face+  -> VoronoiVertexId+fixVoronoiVertex (InnerVoronoiVertexHandle face) =+  InnerVoronoiVertex (fixedFaceId (fixFace face))+fixVoronoiVertex (OuterVoronoiVertexHandle edge) =+  OuterVoronoiVertex (fixDirectedVoronoiEdge edge)+{-# INLINE fixVoronoiVertex #-}++-- | Reverse an admitted directed dual edge.+voronoiEdgeReverseH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> DirectedVoronoiEdgeHandle mode vertex directed undirected face+voronoiEdgeReverseH (DirectedVoronoiEdgeHandle edge) =+  DirectedVoronoiEdgeHandle (directedEdgeReverse edge)++-- | Next admitted dual edge around its Voronoi face.+voronoiEdgeNextH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> DirectedVoronoiEdgeHandle mode vertex directed undirected face+voronoiEdgeNextH (DirectedVoronoiEdgeHandle edge) =+  DirectedVoronoiEdgeHandle (directedEdgeCounterClockwise edge)++-- | Previous admitted dual edge around its Voronoi face.+voronoiEdgePreviousH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> DirectedVoronoiEdgeHandle mode vertex directed undirected face+voronoiEdgePreviousH (DirectedVoronoiEdgeHandle edge) =+  DirectedVoronoiEdgeHandle (directedEdgeClockwise edge)++-- | Origin finite or ideal vertex of an admitted dual edge.+voronoiEdgeFromH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> VoronoiVertexHandle mode vertex directed undirected face+voronoiEdgeFromH edge@(DirectedVoronoiEdgeHandle primal) =+  case faceAsInner (directedEdgeFace primal) of+    Just inner -> InnerVoronoiVertexHandle inner+    Nothing -> OuterVoronoiVertexHandle edge++-- | Destination finite or ideal vertex of an admitted dual edge.+voronoiEdgeToH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> VoronoiVertexHandle mode vertex directed undirected face+voronoiEdgeToH = voronoiEdgeFromH . voronoiEdgeReverseH++-- | Voronoi face to the left of an admitted directed dual edge.+voronoiEdgeFaceH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> VoronoiFaceHandle mode vertex directed undirected face+voronoiEdgeFaceH (DirectedVoronoiEdgeHandle edge) =+  VoronoiFaceHandle (directedEdgeFrom edge)++-- | Forget orientation while retaining ownership.+voronoiEdgeAsUndirectedH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> UndirectedVoronoiEdgeHandle mode vertex directed undirected face+voronoiEdgeAsUndirectedH (DirectedVoronoiEdgeHandle edge) =+  UndirectedVoronoiEdgeHandle (directedEdgeAsUndirected edge)++-- | Recover the owning primal directed-edge handle.+voronoiEdgeAsDelaunayH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> DirectedEdgeHandle mode vertex directed undirected face+voronoiEdgeAsDelaunayH (DirectedVoronoiEdgeHandle edge) = edge++-- | Recover the owning primal site handle.+voronoiFaceSiteH+  :: VoronoiFaceHandle mode vertex directed undirected face+  -> VertexHandle mode vertex directed undirected face+voronoiFaceSiteH (VoronoiFaceHandle site) = site++-- | Admitted directed boundary of a Voronoi face.+voronoiFaceAdjacentEdgesH+  :: VoronoiFaceHandle mode vertex directed undirected face+  -> [DirectedVoronoiEdgeHandle mode vertex directed undirected face]+voronoiFaceAdjacentEdgesH (VoronoiFaceHandle site) =+  map DirectedVoronoiEdgeHandle (vertexHandleOutEdges site)++-- | Position of a finite admitted dual vertex.+voronoiVertexPositionH+  :: VoronoiVertexHandle mode vertex directed undirected face+  -> Maybe (Point)+voronoiVertexPositionH (InnerVoronoiVertexHandle face) = innerFaceCircumcenter face+voronoiVertexPositionH (OuterVoronoiVertexHandle _) = Nothing++-- | Directed dual edges leaving a finite admitted dual vertex.+voronoiVertexOutEdgesH+  :: VoronoiVertexHandle mode vertex directed undirected face+  -> Maybe [DirectedVoronoiEdgeHandle mode vertex directed undirected face]+voronoiVertexOutEdgesH (InnerVoronoiVertexHandle face) =+  Just (map DirectedVoronoiEdgeHandle (faceAdjacentEdges face))+voronoiVertexOutEdgesH (OuterVoronoiVertexHandle _) = Nothing++-- | Recover the primal bounded face underlying a finite dual vertex.+voronoiVertexAsDelaunayFaceH+  :: VoronoiVertexHandle mode vertex directed undirected face+  -> Maybe (FaceHandle InnerTag mode vertex directed undirected face)+voronoiVertexAsDelaunayFaceH (InnerVoronoiVertexHandle face) = Just face+voronoiVertexAsDelaunayFaceH (OuterVoronoiVertexHandle _) = Nothing++-- | Recover the primal hull edge underlying an ideal dual vertex.+voronoiVertexAsOuterEdgeH+  :: VoronoiVertexHandle mode vertex directed undirected face+  -> Maybe (DirectedVoronoiEdgeHandle mode vertex directed undirected face)+voronoiVertexAsOuterEdgeH (InnerVoronoiVertexHandle _) = Nothing+voronoiVertexAsOuterEdgeH (OuterVoronoiVertexHandle edge) = Just edge++-- | Unit direction of the dual edge orthogonal to the primal edge.+voronoiEdgeDirectionH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> Point+voronoiEdgeDirectionH (DirectedVoronoiEdgeHandle primal) =+  let (Point ax ay, Point bx by) = directedEdgePositions primal+   in Point (ay - by) (bx - ax)++-- | Geometric realization of an admitted dual edge.+voronoiEdgeGeometryH+  :: DirectedVoronoiEdgeHandle mode vertex directed undirected face+  -> Maybe (VoronoiEdgeGeometry)+voronoiEdgeGeometryH edge@(DirectedVoronoiEdgeHandle primal) =+  case (voronoiEdgeFromH edge, voronoiEdgeToH edge) of+    (InnerVoronoiVertexHandle fromFace, InnerVoronoiVertexHandle toFace) ->+      VoronoiSegment <$> innerFaceCircumcenter fromFace <*> innerFaceCircumcenter toFace+    (InnerVoronoiVertexHandle fromFace, OuterVoronoiVertexHandle _) -> do+      start <- innerFaceCircumcenter fromFace+      pure (VoronoiRay start (normalizeVector (voronoiEdgeDirectionH edge)))+    (OuterVoronoiVertexHandle _, InnerVoronoiVertexHandle toFace) -> do+      end <- innerFaceCircumcenter toFace+      pure (VoronoiRay end (normalizeVector (negateVector (voronoiEdgeDirectionH edge))))+    (OuterVoronoiVertexHandle _, OuterVoronoiVertexHandle _) ->+      let (from, to) = directedEdgePositions primal+       in Just (VoronoiLine (midpoint from to) (normalizeVector (voronoiEdgeDirectionH edge)))++-- The handle verbs cross the same component boundary as the fixed-index ones+-- and carry their unfoldings for the same reason. 'voronoiVertexPositionH'+-- reaches its arithmetic through 'innerFaceCircumcenter', whose own worker+-- publishes no unfolding, so it stops at that call until the dcel layer says+-- otherwise.
+ src-hex/Moonlight/Hex/Coordinate.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Global axial coordinates and the six translations of the hexagonal grid.+module Moonlight.Hex.Coordinate+  ( HexCoord (..)+  , HexDirection (..)+  , allHexDirections+  , oppositeHexDirection+  , hexDirectionDelta+  , hexStepCoord+  ) where++import Control.DeepSeq (NFData)+import Data.List.NonEmpty (NonEmpty (..))+import GHC.Generics (Generic)++-- | A global axial coordinate. Layouts restrict which coordinates are present;+-- the coordinate itself remains stable across restrictions and gluing.+data HexCoord = HexCoord+  { hexQ :: !Int+  , hexR :: !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | The six translations of the axial lattice.+data HexDirection+  = HexEast+  | HexNorthEast+  | HexNorthWest+  | HexWest+  | HexSouthWest+  | HexSouthEast+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)+  deriving anyclass (NFData)++allHexDirections :: NonEmpty HexDirection+allHexDirections =+  HexEast :| [HexNorthEast, HexNorthWest, HexWest, HexSouthWest, HexSouthEast]++oppositeHexDirection :: HexDirection -> HexDirection+oppositeHexDirection direction = case direction of+  HexEast -> HexWest+  HexNorthEast -> HexSouthWest+  HexNorthWest -> HexSouthEast+  HexWest -> HexEast+  HexSouthWest -> HexNorthEast+  HexSouthEast -> HexNorthWest+{-# INLINE oppositeHexDirection #-}++hexDirectionDelta :: HexDirection -> HexCoord+hexDirectionDelta direction = case direction of+  HexEast -> HexCoord 1 0+  HexNorthEast -> HexCoord 1 (-1)+  HexNorthWest -> HexCoord 0 (-1)+  HexWest -> HexCoord (-1) 0+  HexSouthWest -> HexCoord (-1) 1+  HexSouthEast -> HexCoord 0 1+{-# INLINE hexDirectionDelta #-}++-- | Translate once, returning 'Nothing' only when the machine 'Int' boundary+-- would be crossed. Layout membership is deliberately a separate question.+hexStepCoord :: HexCoord -> HexDirection -> Maybe HexCoord+hexStepCoord (HexCoord q r) direction =+  let HexCoord dq dr = hexDirectionDelta direction+   in HexCoord <$> checkedUnitAdd q dq <*> checkedUnitAdd r dr+{-# INLINE hexStepCoord #-}++checkedUnitAdd :: Int -> Int -> Maybe Int+checkedUnitAdd value delta+  | delta > 0 && value == maxBound = Nothing+  | delta < 0 && value == minBound = Nothing+  | otherwise = Just (value + delta)+{-# INLINE checkedUnitAdd #-}
+ src-hex/Moonlight/Hex/Element.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Canonical vertices and sides of native axial hexagonal cells.+module Moonlight.Hex.Element+  ( HexCorner (..)+  , HexVertex+  , hexVertexCoordinates+  , HexSide+  , hexSideEndpoints+  , HexBoundarySide+  , hexBoundaryDirection+  , hexBoundaryFrom+  , hexBoundaryTo+  , hexBoundaryIdentity+  , hexCellVertex+  , hexCellVertices+  , hexCellSide+  , hexCellSides+  , hexCellBoundarySide+  , hexCellBoundary+  ) where++import Control.DeepSeq (NFData)+import Data.List.NonEmpty (NonEmpty (..))+import GHC.Generics (Generic)+import Moonlight.Hex.Coordinate (HexCoord (..), HexDirection (..))++-- | Corners in counter-clockwise boundary order.+data HexCorner+  = HexEastCorner+  | HexNorthEastCorner+  | HexNorthWestCorner+  | HexWestCorner+  | HexSouthWestCorner+  | HexSouthEastCorner+  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)+  deriving anyclass (NFData)++-- | A vertex in the integer affine embedding of the global axial lattice.+data HexVertex = HexVertex !Integer !Integer+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++hexVertexCoordinates :: HexVertex -> (Integer, Integer)+hexVertexCoordinates (HexVertex x y) = (x, y)+{-# INLINE hexVertexCoordinates #-}++-- | An unoriented side with endpoints stored in canonical ascending order.+data HexSide = HexSide !HexVertex !HexVertex+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++hexSideEndpoints :: HexSide -> (HexVertex, HexVertex)+hexSideEndpoints (HexSide from to) = (from, to)+{-# INLINE hexSideEndpoints #-}++-- | One counter-clockwise cell-boundary side, together with the neighbouring+-- cell direction across it and its canonical unoriented identity.+data HexBoundarySide = HexBoundarySide+  !HexDirection+  !HexVertex+  !HexVertex+  !HexSide+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++hexBoundaryDirection :: HexBoundarySide -> HexDirection+hexBoundaryDirection (HexBoundarySide direction _ _ _) = direction+{-# INLINE hexBoundaryDirection #-}++hexBoundaryFrom :: HexBoundarySide -> HexVertex+hexBoundaryFrom (HexBoundarySide _ from _ _) = from+{-# INLINE hexBoundaryFrom #-}++hexBoundaryTo :: HexBoundarySide -> HexVertex+hexBoundaryTo (HexBoundarySide _ _ to _) = to+{-# INLINE hexBoundaryTo #-}++hexBoundaryIdentity :: HexBoundarySide -> HexSide+hexBoundaryIdentity (HexBoundarySide _ _ _ side) = side+{-# INLINE hexBoundaryIdentity #-}++hexCellVertex :: HexCoord -> HexCorner -> HexVertex+hexCellVertex (HexCoord q r) corner =+  let centerX = 3 * toInteger q+      centerY = 2 * toInteger r + toInteger q+      (offsetX, offsetY) = cornerOffset corner+   in HexVertex (centerX + offsetX) (centerY + offsetY)+{-# INLINE hexCellVertex #-}++hexCellVertices :: HexCoord -> NonEmpty HexVertex+hexCellVertices coordinate =+  hexCellVertex coordinate HexEastCorner+    :| [ hexCellVertex coordinate HexNorthEastCorner+       , hexCellVertex coordinate HexNorthWestCorner+       , hexCellVertex coordinate HexWestCorner+       , hexCellVertex coordinate HexSouthWestCorner+       , hexCellVertex coordinate HexSouthEastCorner+       ]++-- | The side shared with the cell in the given direction.+hexCellSide :: HexCoord -> HexDirection -> HexSide+hexCellSide coordinate direction =+  let (fromCorner, toCorner) = directionCorners direction+   in canonicalSide+        (hexCellVertex coordinate fromCorner)+        (hexCellVertex coordinate toCorner)+{-# INLINE hexCellSide #-}++hexCellSides :: HexCoord -> NonEmpty HexSide+hexCellSides coordinate =+  hexCellSide coordinate HexEast+    :| [ hexCellSide coordinate HexNorthEast+       , hexCellSide coordinate HexNorthWest+       , hexCellSide coordinate HexWest+       , hexCellSide coordinate HexSouthWest+       , hexCellSide coordinate HexSouthEast+       ]++hexCellBoundarySide :: HexCoord -> HexDirection -> HexBoundarySide+hexCellBoundarySide coordinate direction =+  let (fromCorner, toCorner) = boundaryDirectionCorners direction+      from = hexCellVertex coordinate fromCorner+      to = hexCellVertex coordinate toCorner+   in HexBoundarySide direction from to (canonicalSide from to)+{-# INLINE hexCellBoundarySide #-}++hexCellBoundary :: HexCoord -> NonEmpty HexBoundarySide+hexCellBoundary coordinate =+  hexCellBoundarySide coordinate HexEast+    :| [ hexCellBoundarySide coordinate HexSouthEast+       , hexCellBoundarySide coordinate HexSouthWest+       , hexCellBoundarySide coordinate HexWest+       , hexCellBoundarySide coordinate HexNorthWest+       , hexCellBoundarySide coordinate HexNorthEast+       ]++cornerOffset :: HexCorner -> (Integer, Integer)+cornerOffset corner = case corner of+  HexEastCorner -> (2, 0)+  HexNorthEastCorner -> (1, 1)+  HexNorthWestCorner -> (-1, 1)+  HexWestCorner -> (-2, 0)+  HexSouthWestCorner -> (-1, -1)+  HexSouthEastCorner -> (1, -1)+{-# INLINE cornerOffset #-}++directionCorners :: HexDirection -> (HexCorner, HexCorner)+directionCorners direction = case direction of+  HexEast -> (HexEastCorner, HexNorthEastCorner)+  HexNorthEast -> (HexSouthEastCorner, HexEastCorner)+  HexNorthWest -> (HexSouthWestCorner, HexSouthEastCorner)+  HexWest -> (HexWestCorner, HexSouthWestCorner)+  HexSouthWest -> (HexNorthWestCorner, HexWestCorner)+  HexSouthEast -> (HexNorthEastCorner, HexNorthWestCorner)+{-# INLINE directionCorners #-}++boundaryDirectionCorners :: HexDirection -> (HexCorner, HexCorner)+boundaryDirectionCorners direction = case direction of+  HexEast -> (HexEastCorner, HexNorthEastCorner)+  HexSouthEast -> (HexNorthEastCorner, HexNorthWestCorner)+  HexSouthWest -> (HexNorthWestCorner, HexWestCorner)+  HexWest -> (HexWestCorner, HexSouthWestCorner)+  HexNorthWest -> (HexSouthWestCorner, HexSouthEastCorner)+  HexNorthEast -> (HexSouthEastCorner, HexEastCorner)+{-# INLINE boundaryDirectionCorners #-}++canonicalSide :: HexVertex -> HexVertex -> HexSide+canonicalSide left right =+  if left <= right then HexSide left right else HexSide right left+{-# INLINE canonicalSide #-}
+ src-hex/Moonlight/Hex/Region.hs view
@@ -0,0 +1,552 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Bounded axial layouts and native packed finite-set algebra.+module Moonlight.Hex.Region+  ( HexLayout+  , HexLayoutObstruction (..)+  , hexLayout+  , hexLayoutOrigin+  , hexLayoutWidth+  , hexLayoutHeight+  , hexLayoutCellCount+  , hexLayoutWordCount+  , hexLayoutContains+  , hexLayoutCoordAt+  , HexRegion+  , HexRegionObstruction (..)+  , emptyHexRegion+  , fullHexRegion+  , singletonHexRegion+  , hexRegionFromCoords+  , hexRegionGenerate+  , hexRegionLayout+  , hexRegionMember+  , hexRegionCardinality+  , foldHexRegionPackedWords+  , hexRegionCoords+  , foldHexRegionCoords+  , hexRegionUnion+  , hexRegionIntersection+  , hexRegionDifference+  , hexRegionSymmetricDifference+  , complementHexRegion+  , hexRegionSubsetOf+  , restrictHexRegion+  , reframeHexRegion+  , HexGluingObstruction (..)+  , glueCompatibleHexRegions+  , hexNeighbourCoord+  ) where++import Control.DeepSeq (NFData)+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)+import Control.Monad.ST (ST, runST)+import Data.Bits ((.&.), (.|.), complement, countTrailingZeros, popCount, shiftL, shiftR, xor)+import Data.Foldable (traverse_)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import Data.Vector.Unboxed qualified as U+import Data.Vector.Unboxed.Mutable qualified as MU+import Data.Word (Word64)+import GHC.Generics (Generic)+import Moonlight.Hex.Coordinate (HexCoord (..), HexDirection, hexStepCoord)++-- | A nonempty axial parallelogram with an overflow-safe dense row-major index.+data HexLayout = HexLayout+  { layoutOrigin :: !HexCoord+  , layoutWidth :: !Int+  , layoutHeight :: !Int+  , layoutCellCount :: !Int+  , layoutWordCount :: !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data HexLayoutObstruction+  = HexLayoutWidthNotPositive !Int+  | HexLayoutHeightNotPositive !Int+  | HexLayoutCoordinateRangeOverflow !HexCoord !Int !Int+  | HexLayoutCellCountOverflow !Integer+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++hexLayout :: HexCoord -> Int -> Int -> Either HexLayoutObstruction HexLayout+hexLayout origin width height+  | width <= 0 = Left (HexLayoutWidthNotPositive width)+  | height <= 0 = Left (HexLayoutHeightNotPositive height)+  | not (coordinateRangeFits origin width height) =+      Left (HexLayoutCoordinateRangeOverflow origin width height)+  | cells > toInteger (maxBound :: Int) = Left (HexLayoutCellCountOverflow cells)+  | otherwise =+      let cellCount = fromInteger cells+       in Right+            HexLayout+              { layoutOrigin = origin+              , layoutWidth = width+              , layoutHeight = height+              , layoutCellCount = cellCount+              , layoutWordCount =+                  cellCount `quot` 64+                    + if cellCount `rem` 64 == 0 then 0 else 1+              }+ where+  cells = toInteger width * toInteger height++hexLayoutOrigin :: HexLayout -> HexCoord+hexLayoutOrigin = layoutOrigin+{-# INLINE hexLayoutOrigin #-}++hexLayoutWidth :: HexLayout -> Int+hexLayoutWidth = layoutWidth+{-# INLINE hexLayoutWidth #-}++hexLayoutHeight :: HexLayout -> Int+hexLayoutHeight = layoutHeight+{-# INLINE hexLayoutHeight #-}++hexLayoutCellCount :: HexLayout -> Int+hexLayoutCellCount = layoutCellCount+{-# INLINE hexLayoutCellCount #-}++hexLayoutWordCount :: HexLayout -> Int+hexLayoutWordCount = layoutWordCount+{-# INLINE hexLayoutWordCount #-}++hexLayoutContains :: HexLayout -> HexCoord -> Bool+hexLayoutContains layout coordinate = case hexCoordIndex layout coordinate of+  Nothing -> False+  Just _ -> True+{-# INLINE hexLayoutContains #-}++hexLayoutCoordAt :: HexLayout -> Int -> Maybe HexCoord+hexLayoutCoordAt layout index+  | index < 0 || index >= layoutCellCount layout = Nothing+  | otherwise = Just (hexCoordAtIndex layout index)+{-# INLINE hexLayoutCoordAt #-}++-- | Canonical packed membership: one bit per layout cell and zero padding.+data HexRegion = HexRegion !HexLayout !(U.Vector Word64)+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++data HexRegionObstruction+  = HexRegionCoordinateOutsideLayout !HexLayout !HexCoord+  | HexRegionLayoutMismatch !HexLayout !HexLayout+  | HexRegionRestrictionOutsideLayout !HexLayout !HexLayout+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++emptyHexRegion :: HexLayout -> HexRegion+emptyHexRegion layout = HexRegion layout (U.replicate (layoutWordCount layout) 0)++fullHexRegion :: HexLayout -> HexRegion+fullHexRegion layout =+  HexRegion layout+    ( U.generate+        (layoutWordCount layout)+        (\index ->+            if index + 1 == layoutWordCount layout+              then finalWordMask layout+              else maxBound+        )+    )++singletonHexRegion :: HexLayout -> HexCoord -> Either HexRegionObstruction HexRegion+singletonHexRegion layout coordinate = hexRegionFromCoords layout [coordinate]++hexRegionFromCoords+  :: Foldable collection+  => HexLayout+  -> collection HexCoord+  -> Either HexRegionObstruction HexRegion+hexRegionFromCoords layout coordinates = runST $ do+  mutableWords <- MU.replicate (layoutWordCount layout) 0+  admitted <- runExceptT (traverse_ (insertCoordinate mutableWords) coordinates)+  case admitted of+    Left obstruction -> pure (Left obstruction)+    Right () -> Right . HexRegion layout <$> U.unsafeFreeze mutableWords+ where+  insertCoordinate+    :: MU.MVector s Word64+    -> HexCoord+    -> ExceptT HexRegionObstruction (ST s) ()+  insertCoordinate mutableWords coordinate =+    case hexCoordIndex layout coordinate of+      Nothing -> throwE (HexRegionCoordinateOutsideLayout layout coordinate)+      Just cellIndex ->+        let (wordIndex, bitIndex) = cellIndex `quotRem` 64+         in MU.modify mutableWords (`setBitAt` bitIndex) wordIndex++-- | Generate membership directly into packed words. This is the total bulk+-- authoring path when membership is already a function rather than a sparse+-- coordinate collection.+hexRegionGenerate :: HexLayout -> (HexCoord -> Bool) -> HexRegion+hexRegionGenerate layout predicate =+  HexRegion layout (U.generate (layoutWordCount layout) generateWord)+ where+  generateWord wordIndex =+    let baseIndex = wordIndex * 64+        bitCount = min 64 (layoutCellCount layout - baseIndex)+     in gatherBits baseIndex bitCount 0 0++  gatherBits !baseIndex !bitCount !bitIndex !word+    | bitIndex >= bitCount = word+    | predicate (hexCoordAtIndex layout (baseIndex + bitIndex)) =+        gatherBits baseIndex bitCount (bitIndex + 1) (setBitAt word bitIndex)+    | otherwise = gatherBits baseIndex bitCount (bitIndex + 1) word+{-# INLINE hexRegionGenerate #-}++hexRegionLayout :: HexRegion -> HexLayout+hexRegionLayout (HexRegion layout _) = layout+{-# INLINE hexRegionLayout #-}++hexRegionMember :: HexCoord -> HexRegion -> Bool+hexRegionMember coordinate (HexRegion layout wordsValue) =+  case hexCoordIndex layout coordinate of+    Nothing -> False+    Just cellIndex ->+      let (wordIndex, bitIndex) = cellIndex `quotRem` 64+       in wordsValue `U.unsafeIndex` wordIndex .&. (1 `shiftL` bitIndex) /= 0+{-# INLINE hexRegionMember #-}++hexRegionCardinality :: HexRegion -> Int+hexRegionCardinality (HexRegion _ wordsValue) =+  U.foldl' (\total word -> total + popCount word) 0 wordsValue++-- | Fold the canonical row-major packed words without exposing a constructor+-- that could admit nonzero padding. This is the zero-copy observation used by+-- binary interpreters and digests.+foldHexRegionPackedWords :: (accumulator -> Word64 -> accumulator) -> accumulator -> HexRegion -> accumulator+foldHexRegionPackedWords step initial (HexRegion _ wordsValue) =+  U.foldl' step initial wordsValue+{-# INLINE foldHexRegionPackedWords #-}++hexRegionCoords :: HexRegion -> Vector HexCoord+hexRegionCoords = Vector.fromList . reverse . foldHexRegionCoords (flip (:)) []++foldHexRegionCoords :: (accumulator -> HexCoord -> accumulator) -> accumulator -> HexRegion -> accumulator+foldHexRegionCoords step initial (HexRegion layout wordsValue) =+  U.ifoldl' (foldHexWord layout step) initial wordsValue++foldHexWord+  :: HexLayout+  -> (accumulator -> HexCoord -> accumulator)+  -> accumulator+  -> Int+  -> Word64+  -> accumulator+foldHexWord layout step accumulator wordIndex =+  foldSetHexBits layout step accumulator (wordIndex * 64)++foldSetHexBits+  :: HexLayout+  -> (accumulator -> HexCoord -> accumulator)+  -> accumulator+  -> Int+  -> Word64+  -> accumulator+foldSetHexBits layout step !accumulator !baseIndex !remaining+  | remaining == 0 = accumulator+  | otherwise =+      let bitIndex = countTrailingZeros remaining+          cellIndex = baseIndex + bitIndex+          next = remaining .&. (remaining - 1)+       in foldSetHexBits+            layout+            step+            (step accumulator (hexCoordAtIndex layout cellIndex))+            baseIndex+            next++hexRegionUnion :: HexRegion -> HexRegion -> Either HexRegionObstruction HexRegion+hexRegionUnion = combineHexRegionsWith (.|.)++hexRegionIntersection :: HexRegion -> HexRegion -> Either HexRegionObstruction HexRegion+hexRegionIntersection = combineHexRegionsWith (.&.)++hexRegionDifference :: HexRegion -> HexRegion -> Either HexRegionObstruction HexRegion+hexRegionDifference = combineHexRegionsWith (\left right -> left .&. complement right)++hexRegionSymmetricDifference :: HexRegion -> HexRegion -> Either HexRegionObstruction HexRegion+hexRegionSymmetricDifference = combineHexRegionsWith xor++complementHexRegion :: HexRegion -> HexRegion+complementHexRegion (HexRegion layout wordsValue) =+  HexRegion layout+    ( U.imap+        (\index word ->+            let inverted = complement word+             in if index + 1 == layoutWordCount layout+                  then inverted .&. finalWordMask layout+                  else inverted+        )+        wordsValue+    )++hexRegionSubsetOf :: HexRegion -> HexRegion -> Either HexRegionObstruction Bool+hexRegionSubsetOf (HexRegion leftLayout leftWords) (HexRegion rightLayout rightWords)+  | leftLayout /= rightLayout = Left (HexRegionLayoutMismatch leftLayout rightLayout)+  | otherwise =+      Right+        ( U.ifoldl'+            (\isSubset index leftWord ->+                isSubset+                  && leftWord .&. complement (rightWords `U.unsafeIndex` index) == 0+            )+            True+            leftWords+        )++restrictHexRegion :: HexLayout -> HexRegion -> Either HexRegionObstruction HexRegion+restrictHexRegion target source+  | layoutContainsLayout (hexRegionLayout source) target = Right (reframeHexRegion target source)+  | otherwise = Left (HexRegionRestrictionOutsideLayout (hexRegionLayout source) target)++-- | Re-express a section in another global axial window. Cells outside the+-- source context are false. Packed row spans, rather than boxed coordinates,+-- are copied into the result.+reframeHexRegion :: HexLayout -> HexRegion -> HexRegion+reframeHexRegion target source =+  HexRegion target+    (U.generate (layoutWordCount target) (reframedWord target source))+{-# INLINE reframeHexRegion #-}++-- | A failed descent or overlap-compatibility obligation.+data HexGluingObstruction+  = HexGluingExtentOverflow !Integer !Integer+  | HexGluingLayoutInvalid !HexLayoutObstruction+  | HexOverlapDisagreement !HexCoord+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Glue local sections only when their truth values agree on every overlap.+-- This is deliberately distinct from set union.+glueCompatibleHexRegions :: NonEmpty HexRegion -> Either HexGluingObstruction HexRegion+glueCompatibleHexRegions regions = do+  target <- boundingLayout regions+  let firstRegion :| remainingRegions = regions+  runST $ do+    mutableValues <-+      U.unsafeThaw+        (U.generate (layoutWordCount target) (reframedWord target firstRegion))+    mutableCoverage <-+      U.unsafeThaw+        ( U.generate+            (layoutWordCount target)+            (reframedCoverageWord target (hexRegionLayout firstRegion))+        )+    obstruction <-+      descendHexSections+        target+        mutableValues+        mutableCoverage+        remainingRegions+    case obstruction of+      Just coordinate -> pure (Left (HexOverlapDisagreement coordinate))+      Nothing -> Right . HexRegion target <$> U.unsafeFreeze mutableValues++hexNeighbourCoord :: HexLayout -> HexCoord -> HexDirection -> Maybe HexCoord+hexNeighbourCoord layout coordinate direction =+  hexStepCoord coordinate direction >>= admitNeighbour+ where+  admitNeighbour candidate =+    if hexLayoutContains layout candidate then Just candidate else Nothing+{-# INLINE hexNeighbourCoord #-}++combineHexRegionsWith+  :: (Word64 -> Word64 -> Word64)+  -> HexRegion+  -> HexRegion+  -> Either HexRegionObstruction HexRegion+combineHexRegionsWith combine (HexRegion leftLayout leftWords) (HexRegion rightLayout rightWords)+  | leftLayout /= rightLayout = Left (HexRegionLayoutMismatch leftLayout rightLayout)+  | otherwise = Right (HexRegion leftLayout (U.zipWith combine leftWords rightWords))+{-# INLINE combineHexRegionsWith #-}++descendHexSections+  :: HexLayout+  -> MU.MVector s Word64+  -> MU.MVector s Word64+  -> [HexRegion]+  -> ST s (Maybe HexCoord)+descendHexSections _ _ _ [] = pure Nothing+descendHexSections target mutableValues mutableCoverage (local : remaining) = do+  obstruction <- descendHexSection target mutableValues mutableCoverage local 0+  case obstruction of+    Just coordinate -> pure (Just coordinate)+    Nothing -> descendHexSections target mutableValues mutableCoverage remaining++descendHexSection+  :: HexLayout+  -> MU.MVector s Word64+  -> MU.MVector s Word64+  -> HexRegion+  -> Int+  -> ST s (Maybe HexCoord)+descendHexSection target mutableValues mutableCoverage local !wordIndex+  | wordIndex >= layoutWordCount target = pure Nothing+  | otherwise = do+      values <- MU.unsafeRead mutableValues wordIndex+      coverage <- MU.unsafeRead mutableCoverage wordIndex+      let localValues = reframedWord target local wordIndex+          localCoverage = reframedCoverageWord target (hexRegionLayout local) wordIndex+          disagreement = (values `xor` localValues) .&. coverage .&. localCoverage+      if disagreement == 0+        then do+          MU.unsafeWrite mutableValues wordIndex (values .|. localValues)+          MU.unsafeWrite mutableCoverage wordIndex (coverage .|. localCoverage)+          descendHexSection target mutableValues mutableCoverage local (wordIndex + 1)+        else+          pure+            ( Just+                (hexCoordAtIndex target (wordIndex * 64 + countTrailingZeros disagreement))+            )++boundingLayout :: NonEmpty HexRegion -> Either HexGluingObstruction HexLayout+boundingLayout regions =+  let layouts = fmap hexRegionLayout regions+      minimumQ = minimum (fmap (toInteger . hexQ . layoutOrigin) layouts)+      minimumR = minimum (fmap (toInteger . hexR . layoutOrigin) layouts)+      maximumQ = maximum (fmap layoutMaximumQ layouts)+      maximumR = maximum (fmap layoutMaximumR layouts)+      width = maximumQ - minimumQ + 1+      height = maximumR - minimumR + 1+   in case (integerToInt minimumQ, integerToInt minimumR, integerToInt width, integerToInt height) of+        (Just originQ, Just originR, Just widthValue, Just heightValue) ->+          either (Left . HexGluingLayoutInvalid) Right+            (hexLayout (HexCoord originQ originR) widthValue heightValue)+        _ -> Left (HexGluingExtentOverflow width height)++reframedWord :: HexLayout -> HexRegion -> Int -> Word64+reframedWord target (HexRegion source sourceWords) wordIndex =+  reframedSourceWord target source (extractBits sourceWords) wordIndex+{-# INLINE reframedWord #-}++reframedCoverageWord :: HexLayout -> HexLayout -> Int -> Word64+reframedCoverageWord target source =+  reframedSourceWord target source (const lowBitMask)+{-# INLINE reframedCoverageWord #-}++reframedSourceWord+  :: HexLayout+  -> HexLayout+  -> (Int -> Int -> Word64)+  -> Int+  -> Word64+reframedSourceWord target source extract wordIndex =+  gather 0 (wordIndex * 64) 0+ where+  gather !destinationShift !targetIndex !accumulator+    | destinationShift >= 64 || targetIndex >= layoutCellCount target = accumulator+    | otherwise =+        let (targetRow, targetColumn) = targetIndex `quotRem` layoutWidth target+            rowRun = min (64 - destinationShift) (layoutWidth target - targetColumn)+            targetQ0 = hexQ (layoutOrigin target) + targetColumn+            targetR = hexR (layoutOrigin target) + targetRow+            sourceQ0 = hexQ (layoutOrigin source)+            sourceQMaximum = sourceQ0 + layoutWidth source - 1+            sourceR0 = hexR (layoutOrigin source)+            sourceRMaximum = sourceR0 + layoutHeight source - 1+            runQMaximum = targetQ0 + rowRun - 1+            overlapQ0 = max targetQ0 sourceQ0+            overlapQMaximum = min runQMaximum sourceQMaximum+            hasRow = targetR >= sourceR0 && targetR <= sourceRMaximum+            hasColumns = overlapQ0 <= overlapQMaximum+            copied =+              if hasRow && hasColumns+                then+                  let leading = overlapQ0 - targetQ0+                      copiedCount = overlapQMaximum - overlapQ0 + 1+                      sourceRow = targetR - sourceR0+                      sourceColumn = overlapQ0 - sourceQ0+                      sourceBitIndex = sourceRow * layoutWidth source + sourceColumn+                   in extract sourceBitIndex copiedCount+                        `shiftL` (destinationShift + leading)+                else 0+         in gather+              (destinationShift + rowRun)+              (targetIndex + rowRun)+              (accumulator .|. copied)+{-# INLINE reframedSourceWord #-}++extractBits :: U.Vector Word64 -> Int -> Int -> Word64+extractBits wordsValue bitIndex count+  | count <= 0 = 0+  | otherwise =+      let (wordIndex, bitOffset) = bitIndex `quotRem` 64+          low = wordsValue `U.unsafeIndex` wordIndex `shiftR` bitOffset+          high =+            if bitOffset == 0 || bitOffset + count <= 64+              then 0+              else wordsValue `U.unsafeIndex` (wordIndex + 1) `shiftL` (64 - bitOffset)+       in (low .|. high) .&. lowBitMask count+{-# INLINE extractBits #-}++hexCoordIndex :: HexLayout -> HexCoord -> Maybe Int+hexCoordIndex layout (HexCoord q r)+  | q < originQ || r < originR = Nothing+  | q > maximumQ || r > maximumR = Nothing+  | otherwise = Just ((r - originR) * layoutWidth layout + (q - originQ))+ where+  HexCoord originQ originR = layoutOrigin layout+  maximumQ = originQ + layoutWidth layout - 1+  maximumR = originR + layoutHeight layout - 1+{-# INLINE hexCoordIndex #-}++hexCoordAtIndex :: HexLayout -> Int -> HexCoord+hexCoordAtIndex layout index =+  let (row, column) = index `quotRem` layoutWidth layout+      HexCoord originQ originR = layoutOrigin layout+   in HexCoord (originQ + column) (originR + row)+{-# INLINE hexCoordAtIndex #-}++coordinateRangeFits :: HexCoord -> Int -> Int -> Bool+coordinateRangeFits (HexCoord originQ originR) width height =+  let maximumQ = toInteger originQ + toInteger width - 1+      maximumR = toInteger originR + toInteger height - 1+      lower = toInteger (minBound :: Int)+      upper = toInteger (maxBound :: Int)+   in maximumQ >= lower && maximumQ <= upper && maximumR >= lower && maximumR <= upper++layoutContainsLayout :: HexLayout -> HexLayout -> Bool+layoutContainsLayout outer inner =+  let HexCoord outerQ outerR = layoutOrigin outer+      HexCoord innerQ innerR = layoutOrigin inner+   in innerQ >= outerQ+        && innerR >= outerR+        && layoutMaximumQ inner <= layoutMaximumQ outer+        && layoutMaximumR inner <= layoutMaximumR outer++layoutMaximumQ :: HexLayout -> Integer+layoutMaximumQ layout =+  toInteger (hexQ (layoutOrigin layout)) + toInteger (layoutWidth layout) - 1++layoutMaximumR :: HexLayout -> Integer+layoutMaximumR layout =+  toInteger (hexR (layoutOrigin layout)) + toInteger (layoutHeight layout) - 1++finalWordMask :: HexLayout -> Word64+finalWordMask layout =+  lowBitMask (((layoutCellCount layout - 1) `rem` 64) + 1)+{-# INLINE finalWordMask #-}++lowBitMask :: Int -> Word64+lowBitMask count+  | count >= 64 = maxBound+  | count <= 0 = 0+  | otherwise = (1 `shiftL` count) - 1+{-# INLINE lowBitMask #-}++setBitAt :: Word64 -> Int -> Word64+setBitAt word bitIndex = word .|. (1 `shiftL` bitIndex)+{-# INLINE setBitAt #-}++integerToInt :: Integer -> Maybe Int+integerToInt value+  | value < toInteger (minBound :: Int) = Nothing+  | value > toInteger (maxBound :: Int) = Nothing+  | otherwise = Just (fromInteger value)
+ src-overlay/Moonlight/Triangulation/Embedding.hs view
@@ -0,0 +1,546 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Bounded certification that projection of a declared exact arrangement to+-- binary64 preserves its local incidence and rotation data.+module Moonlight.Triangulation.Embedding+  ( DraftId (..)+  , DraftVertexId+  , DraftSegmentId+  , DraftSourceId+  , DraftIncidence (..)+  , DraftNeighborhood (..)+  , ExactArrangementDraft (..)+  , DraftReference (..)+  , OverlayEmbeddingObstruction (..)+  , EmbeddingObligation (..)+  , EmbeddingResidual+  , residualUndischargedObligations+  , milestoneOneResidual+  , LocalEmbeddingCertificate+  , certificateRoundedVertexDistinctnessCount+  , certificateSplitOrderPreservationCount+  , certificateIncidenceRelationPreservationCount+  , certificateNeighborhoodRotationPreservationCount+  , certificateRoundedVertices+  , certificateResidual+  , certifyLocalEmbedding+  ) where++import Control.DeepSeq (NFData)+import qualified Data.List as List+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+  , exactPointToEmbeddingCandidate+  , exactSegmentRelation+  )+import Moonlight.Triangulation.Internal.BoundaryCycle+  ( cyclePairs+  , unorderedPairs+  )+import Moonlight.Triangulation.Internal.ExactRational (ExactRational)+import qualified Moonlight.Triangulation.Internal.Predicates as Admitted+  ( orient2d+  , segmentRelation+  )+import Moonlight.Triangulation.Types+  ( Point (..)+  , PointValidationError+  , QueryPoint+  , queryPointValue+  )++-- | Phantom draft kind; three incompatible identifiers share one scalar owner.+data DraftEntity = DraftVertexEntity | DraftSegmentEntity | DraftSourceEntity++newtype DraftId (entity :: DraftEntity) = DraftId Int+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++type DraftVertexId = DraftId 'DraftVertexEntity+type DraftSegmentId = DraftId 'DraftSegmentEntity+type DraftSourceId = DraftId 'DraftSourceEntity++-- | 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 retain their neighbor order.+    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+  | NeighborhoodRotationChanged+      !DraftVertexId+      !(NonEmpty DraftVertexId)+      !(NonEmpty DraftVertexId)+  | 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 rotation. 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 neighborhood rotation entries certified.+    certificateNeighborhoodRotationPreservationCount :: !Int+  , -- | The admitted candidate projection certified by the four local obligations.+    certificateRoundedVertices :: !(Map DraftVertexId QueryPoint)+  , -- | 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 :: !QueryPoint+  }++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+              , certificateNeighborhoodRotationPreservationCount = 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 =+    neighborhoodRotationObstructions+      <$> 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 (queryPointValue roundedPoint)+  | (roundedPoint, vertexIds) <- Map.toAscList verticesByRoundedPoint+  , (leftId, rightId) <- unorderedPairs (List.sort vertexIds)+  ]+ 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 =+            List.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 =+  queryPointValue+    . 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 Admitted.segmentRelation roundedProjectedPoint 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)))++neighborhoodRotationObstructions+  :: ResolvedVertex+  -> NonEmpty ResolvedVertex+  -> [OverlayEmbeddingObstruction]+neighborhoodRotationObstructions center exactRotation =+  [ NeighborhoodRotationChanged+      (resolvedVertexId center)+      exactVertexRotation+      roundedVertexRotation+  | roundedRotationDescents > 1+  ]+ where+  exactVertexRotation = fmap resolvedVertexId exactRotation+  roundedRotationDescents =+    List.foldl'+      (\descentCount (left, right) ->+         descentCount+           + if compareRoundedAround center left right == GT+               then 1+               else 0)+      (0 :: Int)+      (cyclePairs exactRotation)+  roundedVertexRotation =+    fmap resolvedVertexId+      (NonEmpty.sortBy (compareRoundedAround center) exactRotation)++compareRoundedAround+  :: ResolvedVertex+  -> ResolvedVertex+  -> ResolvedVertex+  -> Ordering+compareRoundedAround center left right =+  compareRoundedAroundWith+    ( Admitted.orient2d+        (roundedVertexPoint center)+        (roundedVertexPoint left)+        (roundedVertexPoint right)+    )+    center+    left+    right++compareRoundedAroundWith+  :: Ordering+  -> ResolvedVertex+  -> ResolvedVertex+  -> ResolvedVertex+  -> Ordering+compareRoundedAroundWith roundedOrientation center left right =+  case compare (roundedVectorHalf center left) (roundedVectorHalf center right) of+    EQ ->+      case roundedOrientation of+        GT -> LT+        LT -> GT+        EQ -> compare (roundedVertexPoint left) (roundedVertexPoint right)+    ordering -> ordering++roundedVectorHalf :: ResolvedVertex -> ResolvedVertex -> Bool+roundedVectorHalf center neighbor =+  let Point centerX centerY = roundedVertexPoint center+      Point neighborX neighborY = roundedVertexPoint neighbor+      deltaX = neighborX - centerX+      deltaY = neighborY - centerY+   in deltaY < 0 || (deltaY == 0 && deltaX < 0)++roundedVertexPoint :: ResolvedVertex -> Point+roundedVertexPoint = roundedProjectedPoint . resolvedProjectedVertex++roundedProjectedPoint :: ProjectedVertex -> Point+roundedProjectedPoint = queryPointValue . projectedRoundedPoint
+ src-overlay/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs view
@@ -0,0 +1,812 @@+{-# 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 qualified Data.List as List+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+  , exactPointFromQueryPoint+  , 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.Embedding+  ( DraftId (..)+  , DraftIncidence (..)+  , DraftNeighborhood (..)+  , DraftReference (..)+  , DraftVertexId+  , ExactArrangementDraft (..)+  , LocalEmbeddingCertificate+  , certificateRoundedVertices+  , OverlayEmbeddingObstruction (..)+  , certifyLocalEmbedding+  )+import Moonlight.Triangulation.Internal.Overlay.Types+import Moonlight.Triangulation.Internal.Types+  ( HasPosition (..)+  , Point+  , queryPointValue+  )+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))+  , certifiedInexactEmbeddingPoints :: !(Set ExactPoint)+  , 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)+  let projectedPoints = projectedExactPoints localCertificate+      inexactEmbeddingPoints =+        Set.fromList+          [ exactPoint+          | (exactPoint, vertexId) <- Map.toAscList pointIds+          , Map.lookup vertexId projectedPoints /= Just exactPoint+          ]+  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+      , certifiedInexactEmbeddingPoints = inexactEmbeddingPoints+      , 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+          (BoundaryRef componentIndex loopRef fromIndex)+          (BoundaryRef componentIndex loopRef toIndex)+          (BoundaryRef 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 ->+         List.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+        ) =+          List.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 DraftId [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 (DraftId 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 (DraftId sourceIndex, values))+        (V.toList (V.indexed sources))+  neighborhoods <- buildDraftNeighborhoods atomicEdges pointIds+  let incidences =+        [ DraftIncidence+            (DraftId leftIndex)+            (DraftId 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+  -> Map DraftVertexId ExactPoint+projectedExactPoints =+  Map.map exactPointFromQueryPoint . certificateRoundedVertices++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+               (DraftId 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 (DraftId leftId) (DraftId rightId) projected]+      (Just exact, Nothing) ->+        [GlobalRelationRemoved (DraftId leftId) (DraftId rightId) exact]+      (Just exact, Just projected)+        | exact /= projected ->+            [GlobalRelationChanged (DraftId leftId) (DraftId 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 (queryPointValue 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+       DraftId from <- requireDraftVertex pointIds (atomicEdgeFrom edge)+       DraftId 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-overlay/Moonlight/Triangulation/Internal/Overlay/Resident.hs view
@@ -0,0 +1,923 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | 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+  , faceCarriesExactArea+  , regionFaceLabels+  , vertexSupport+  , edgeSupport+  ) where++import Control.Monad (foldM)+import Data.Bifunctor (first)+import Data.Foldable (traverse_)+import Data.List (partition, sort, sortBy)+import qualified Data.List as List+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+  , faceVertices+  , imapUndirectedEdges+  , incidentFace+  , isConstraintEdge+  , numInnerFaces+  , numVertices+  , outerFace+  , undirectedEndpoints+  , vertexData+  , vertexOutgoingEdges+  )+import Moonlight.Triangulation.Exact (ExactPoint, exactOrient2d)+import Moonlight.Triangulation.FloodFillIterator+  ( FaceComponent+  , componentBoundary+  , faceComponentFaces+  , faceComponentsBy+  )+import Moonlight.Triangulation.Internal.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+  , traceOrientedBoundaryCircuits+  )+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+  (fullDimensionalFaces, collapsedFaces) <-+    if Set.null (certifiedInexactEmbeddingPoints certified)+      then+        Right+          ( Set.fromList (innerFaces scheduledResident)+          , Set.empty+          )+      else+        exactFaceDimensions+          (certifiedInexactEmbeddingPoints certified)+          scheduledResident+  componentDrafts <-+    residentComponentDrafts+      scheduledResident+      labelledFaces+      fullDimensionalFaces+  let (unboundedDrafts, boundedDrafts) =+        partitionDrafts outsidePair componentDrafts+  numberedBounded <- numberBoundedComponents boundedDrafts+  let fullCellIdByFace =+        Map.fromList+          ( [ (face, OverlayCellId 0)+            | draftComponent <- unboundedDrafts+            , face <- faceComponentFaces (componentDraftFaces draftComponent)+            ]+              <> [ (face, cellId)+                 | (cellId, draftComponent) <- numberedBounded+                 , face <- faceComponentFaces (componentDraftFaces draftComponent)+                 ]+          )+  collapsedCellIds <-+    descendCollapsedFaces+      scheduledResident+      atomicByKey+      fullCellIdByFace+      collapsedFaces+  let cellIdByFace = fullCellIdByFace <> collapsedCellIds+  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 collapsedFaces 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++exactFaceDimensions+  :: Set ExactPoint+  -> Triangulation 'Constrained OverlayVertexSeed directed undirected face+  -> Either+      (OverlayError leftLabel rightLabel)+      (Set FaceId, Set FaceId)+exactFaceDimensions inexactEmbeddingPoints triangulation = do+  orientations <-+    traverse+      ( \face ->+          (face,)+            <$> exactFaceOrientation+              inexactEmbeddingPoints+              triangulation+              face+      )+      (innerFaces triangulation)+  case [face | (face, LT) <- orientations] of+    reversed : _ ->+      Left+        ( OverlayArrangementInvalid+            (OverlayResidentFaceOrientationReversed reversed)+        )+    [] ->+      Right+        ( Set.fromList [face | (face, GT) <- orientations]+        , Set.fromList [face | (face, EQ) <- orientations]+        )++exactFaceOrientation+  :: Set ExactPoint+  -> Triangulation mode OverlayVertexSeed directed undirected face+  -> FaceId+  -> Either (OverlayError leftLabel rightLabel) Ordering+exactFaceOrientation inexactEmbeddingPoints triangulation face =+  case+    map+      (seedExactPoint . vertexData triangulation)+      (faceVertices triangulation face) of+    points@[firstPoint, secondPoint, thirdPoint]+      | any (`Set.member` inexactEmbeddingPoints) points ->+          Right (exactOrient2d firstPoint secondPoint thirdPoint)+      | otherwise -> Right GT+    vertices ->+      Left+        ( OverlayArrangementInvalid+            (OverlayResidentFaceArity face (length vertices))+        )++residentComponentDrafts+  :: forall leftLabel rightLabel.+     (Ord leftLabel, Ord rightLabel)+  => Triangulation 'Constrained OverlayVertexSeed () () ()+  -> Map FaceId (leftLabel, rightLabel)+  -> Set FaceId+  -> Either+      (OverlayError leftLabel rightLabel)+      [ComponentDraft leftLabel rightLabel]+residentComponentDrafts triangulation labels fullDimensionalFaces =+  traverse+    convert+    (faceComponentsBy triangulation labelFullDimensionalFace (const True))+ where+  exactPointAt :: VertexId -> Either RegionPublicationError ExactPoint+  exactPointAt vertex =+    Right (seedExactPoint (vertexData triangulation vertex))+  labelFullDimensionalFace :: FaceId -> Maybe (leftLabel, rightLabel)+  labelFullDimensionalFace face+    | Set.member face fullDimensionalFaces = Map.lookup face labels+    | otherwise = Nothing+  convert+    :: ((leftLabel, rightLabel), FaceComponent)+    -> Either+        (OverlayError leftLabel rightLabel)+        (ComponentDraft leftLabel rightLabel)+  convert (componentLabels, component) = do+    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)++-- | A binary64 triangle whose authoritative vertices are collinear is not an+-- exact two-cell. It may remain in the resident triangulation only when its+-- representation diagonals descend uniquely to one full-dimensional exact+-- cell; this prevents the artifact from gluing exact components through a+-- zero-area wedge.+descendCollapsedFaces+  :: forall leftLabel rightLabel.+     Triangulation 'Constrained OverlayVertexSeed () () ()+  -> Map ExactEdgeKey (AtomicEdge leftLabel rightLabel)+  -> Map FaceId OverlayCellId+  -> Set FaceId+  -> Either+      (OverlayError leftLabel rightLabel)+      (Map FaceId OverlayCellId)+descendCollapsedFaces triangulation atomicByKey fullCellIds collapsedFaces =+  Map.fromList . concat <$> traverse resolveComponent collapsedComponents+ where+  exactCellIds = Map.insert outerFace (OverlayCellId 0) fullCellIds+  collapsedComponents =+    fmap snd+      ( faceComponentsBy+          triangulation+          labelCollapsedFace+          isRepresentationDiagonal+      )++  labelCollapsedFace face+    | Set.member face collapsedFaces = Just ()+    | otherwise = Nothing++  isRepresentationDiagonal edge =+    Map.notMember (residentSeedEdgeKey triangulation edge) atomicByKey++  resolveComponent component =+    case faceComponentFaces component of+      [] ->+        Left+          ( OverlayArrangementInvalid+              OverlayFaceComponentEmpty+          )+      componentFaces@(firstFace : remainingFaces) -> do+        let componentWitness = firstFace NonEmpty.:| remainingFaces+            adjacentCellIds =+              Set.fromList+                [ cellId+                | face <- componentFaces+                , directed <- faceDirectedEdges triangulation face+                , isRepresentationDiagonal (asUndirected directed)+                , Just cellId <-+                    [Map.lookup (incidentFace triangulation (reverseEdge directed)) exactCellIds]+                ]+        cellId <-+          case Set.toAscList adjacentCellIds of+            [singleCellId] -> Right singleCellId+            [] ->+              Left+                ( OverlayArrangementInvalid+                    (OverlayCollapsedFacesUnowned componentWitness)+                )+            firstCellId : remainingCellIds ->+              Left+                ( OverlayArrangementInvalid+                    ( OverlayCollapsedFacesAmbiguous+                        componentWitness+                        (firstCellId NonEmpty.:| remainingCellIds)+                    )+                )+        pure (fmap (,cellId) componentFaces)++-- | 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 = do+  pointCycles <-+    traceOrientedBoundaryCircuits+      fst+      snd+      (\seed _ ->+         OverlayArrangementInvalid+           (uncurry OverlayCellCycleDidNotClose seed))+      outgoing+      orientedEdges+  sort+    <$> traverse+      ( first+          (OverlayRegionPublicationFailed . RegionValidationObstruction)+          . exactLoop+      )+      pointCycles+ 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)++attachFaceCells+  :: forall leftLabel rightLabel.+     Set FaceId+  -> Map FaceId OverlayCellId+  -> Triangulation 'Constrained OverlayVertexSeed () () ()+  -> Either+      (OverlayError leftLabel rightLabel)+      (Triangulation 'Constrained OverlayVertexSeed () () OverlayFace)+attachFaceCells collapsedFaces cellIdByFace triangulation = do+  payloads <- V.fromList <$> traverse facePayload (allFaces triangulation)+  let outerPayload = OverlayCellFace (OverlayCellId 0)+      defaults = triElementDefaults triangulation+  pure+    triangulation+      { triFaceData = boxedFromVector (Just outerPayload) payloads+      , triElementDefaults = defaults{defaultFaceData = outerPayload}+      }+ where+  facePayload+    :: FaceId+    -> Either (OverlayError leftLabel rightLabel) OverlayFace+  facePayload face+    | face == outerFace = Right (OverlayCellFace (OverlayCellId 0))+    | otherwise =+        case Map.lookup face cellIdByFace of+          Just cellId+            | Set.member face collapsedFaces ->+                Right (OverlayCollapsedFace cellId)+            | otherwise -> Right (OverlayCellFace 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)++-- | Whether a resident triangle has nonzero area under the authoritative+-- exact coordinate section. Binary64-only wedges are representation charts,+-- never exact two-cells.+faceCarriesExactArea+  :: OverlayResult leftLabel rightLabel+  -> FaceId+  -> Bool+faceCarriesExactArea result face =+  case faceData (overlayResultTriangulation result) face of+    OverlayCellFace {} -> True+    OverlayCollapsedFace {} -> False++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) =+        List.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-overlay/Moonlight/Triangulation/Internal/Overlay/Types.hs view
@@ -0,0 +1,274 @@+{-# 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 (..)+  , BoundaryRef (..)+  , 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.Internal.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.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++-- | Phantom source cell kind; both provenance axes share one physical payload.+data BoundaryFeature = BoundaryVertexFeature | BoundaryEdgeFeature++data BoundaryRef (feature :: BoundaryFeature) (operand :: OverlayOperand) = BoundaryRef+  { boundaryRefComponent :: !Int+  , boundaryRefLoop :: !BoundaryLoopRef+  , boundaryRefLocalIndex :: !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++type BoundaryVertexRef operand = BoundaryRef 'BoundaryVertexFeature operand+type BoundaryEdgeRef operand = BoundaryRef 'BoundaryEdgeFeature operand++-- | 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 triangle either realizes an exact two-cell or collapses under+-- the authoritative exact coordinates. A collapsed triangle descends to the+-- unique adjacent exact cell through representation diagonals, but exact+-- region operations must not mistake its binary64 area for exact area.+data OverlayFace+  = OverlayCellFace+      { overlayFaceCellId :: !OverlayCellId+      }+  | OverlayCollapsedFace+      { 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)+  | OverlayResidentFaceArity !FaceId !Int+  | OverlayResidentFaceOrientationReversed !FaceId+  | OverlayCollapsedFacesUnowned !(NonEmpty FaceId)+  | OverlayCollapsedFacesAmbiguous+      !(NonEmpty FaceId)+      !(NonEmpty OverlayCellId)+  | 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-parallel/Moonlight/Triangulation/Parallel.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++-- | Bounded concurrent interpretation of the canonical join tournament. This+-- layer owns effects only: pairing and pair-schedule semantics remain in the+-- pure build planner.+module Moonlight.Triangulation.Parallel+  ( unionsConcurrently+  ) where++import Control.Concurrent.Async (concurrently)+import Control.DeepSeq (NFData, force)+import Control.Exception (evaluate)+import Data.List.NonEmpty (NonEmpty)+import Moonlight.Triangulation.Internal.Join+  ( joinNormalForm )+import Moonlight.Triangulation.Internal.Representation (Triangulation)+import Moonlight.Triangulation.Internal.Tournament+  ( TournamentPlan (..)+  , planTournament+  )+import Moonlight.Triangulation.Internal.Types (BuildError, ConstraintMode (Unconstrained))+import Moonlight.Triangulation.JoinSemilattice (JoinSemilattice)++-- | Execute the same deterministic tournament as sequential @unions@, with+-- no more than the requested number of leaf computations live at once. A+-- non-positive request means one worker; requesting more workers than leaves+-- is harmless. Each child is fully evaluated before its parent becomes+-- runnable, so thunks do not smuggle unbounded work across the boundary.+unionsConcurrently+  :: (JoinSemilattice annotation, NFData annotation)+  => Int+  -> NonEmpty (Triangulation 'Unconstrained annotation () () ())+  -> IO (Either BuildError (Triangulation 'Unconstrained annotation () () ()))+unionsConcurrently requestedWorkers operands =+  executeTournamentConcurrently+    (max 1 requestedWorkers)+    (planTournament operands)++executeTournamentConcurrently+  :: (JoinSemilattice annotation, NFData annotation)+  => Int+  -> TournamentPlan (Triangulation 'Unconstrained annotation () () ())+  -> IO (Either BuildError (Triangulation 'Unconstrained annotation () () ()))+executeTournamentConcurrently workers tournament =+  case tournament of+    TournamentLeaf mesh -> Right <$> evaluate (force mesh)+    TournamentNode left right+      | workers <= 1 ->+            publishUnion+            =<< ((,)+                  <$> executeTournamentConcurrently 1 left+                  <*> executeTournamentConcurrently 1 right+                )+      | otherwise -> do+          let !leftLeaves = tournamentLeaves left+              !rightLeaves = tournamentLeaves right+              !available = min workers (leftLeaves + rightLeaves)+              !leftWorkers =+                max 1 (min leftLeaves (available * leftLeaves `quot` (leftLeaves + rightLeaves)))+              !rightWorkers = max 1 (available - leftWorkers)+          concurrently+            (executeTournamentConcurrently leftWorkers left)+            (executeTournamentConcurrently rightWorkers right)+            >>= publishUnion++publishUnion+  :: (JoinSemilattice annotation, NFData annotation)+  => ( Either BuildError (Triangulation 'Unconstrained annotation () () ())+     , Either BuildError (Triangulation 'Unconstrained annotation () () ())+     )+  -> IO (Either BuildError (Triangulation 'Unconstrained annotation () () ()))+publishUnion (Left failure, _) = pure (Left failure)+publishUnion (Right _, Left failure) = pure (Left failure)+publishUnion (Right leftMesh, Right rightMesh) =+  evaluate (force (joinNormalForm leftMesh rightMesh))++tournamentLeaves :: TournamentPlan mesh -> Int+tournamentLeaves tournament =+  case tournament of+    TournamentLeaf _ -> 1+    TournamentNode left right -> tournamentLeaves left + tournamentLeaves right+{-# INLINE tournamentLeaves #-}
+ src-public/Moonlight/Hex/Planar.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Exact planar interpretation of native hexagonal cells and regions.+module Moonlight.Hex.Planar+  ( HexPlanarObstruction (..)+  , hexCellExactLoop+  , hexRegionPlanarRegion+  ) where++import Control.DeepSeq (NFData)+import Data.Bifunctor (first)+import Data.Either (isRight)+import Data.Foldable (foldlM)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import GHC.Generics (Generic)+import Moonlight.Hex.Coordinate+  ( HexCoord+  , HexDirection+  , allHexDirections+  , hexStepCoord+  )+import Moonlight.Hex.Element+  ( HexVertex+  , hexBoundaryFrom+  , hexBoundaryTo+  , hexCellBoundarySide+  , hexCellVertices+  , hexVertexCoordinates+  )+import Moonlight.Hex.Region+  ( HexRegion+  , foldHexRegionCoords+  , hexRegionMember+  )+import Moonlight.Triangulation.Exact (ExactPoint, exactPoint)+import Moonlight.Triangulation.Region+  ( ExactLoop+  , PlanarRegion+  , RegionValidationError+  , emptyPlanarRegion+  , exactLoop+  , planarRegion+  , polygonComponent+  )++-- | Every typed obstruction in boundary descent and exact publication.+data HexPlanarObstruction+  = HexPlanarRegionInvalid !RegionValidationError+  | HexPlanarBoundaryOpen !HexVertex+  | HexPlanarBoundaryVectorUnexpected !HexVertex !HexVertex+  | HexPlanarBoundaryDegenerate !(NonEmpty HexVertex)+  | HexPlanarHoleUnowned !ExactLoop+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++hexCellExactLoop :: HexCoord -> Either HexPlanarObstruction ExactLoop+hexCellExactLoop =+  first HexPlanarRegionInvalid+    . exactLoop+    . fmap exactVertexPoint+    . hexCellVertices++-- | Trace the exterior sides of the selected native section, classify the+-- resulting exact loops by winding, and publish one canonical planar region.+-- Interior cell sides never enter the boundary graph.+hexRegionPlanarRegion :: HexRegion -> Either HexPlanarObstruction PlanarRegion+hexRegionPlanarRegion region+  | Set.null boundary = Right emptyPlanarRegion+  | otherwise = do+      vertexLoops <- traceBoundaryLoops boundary+      exactLoops <- traverse admitBoundaryLoop vertexLoops+      publishClassifiedLoops exactLoops+ where+  boundary = regionBoundaryEdges region++  admitBoundaryLoop+    :: NonEmpty HexVertex+    -> Either HexPlanarObstruction (Integer, ExactLoop)+  admitBoundaryLoop vertices = do+    let area = signedDoubleArea vertices+    if area == 0+      then Left (HexPlanarBoundaryDegenerate vertices)+      else+        fmap+          (\loop -> (area, loop))+          (first HexPlanarRegionInvalid (exactLoop (fmap exactVertexPoint vertices)))++-- One oriented edge with selected area on its left.+data BoundaryEdge = BoundaryEdge !HexVertex !HexVertex+  deriving stock (Eq, Ord, Show)++regionBoundaryEdges :: HexRegion -> Set BoundaryEdge+regionBoundaryEdges region =+  foldHexRegionCoords addCell Set.empty region+ where+  addCell :: Set BoundaryEdge -> HexCoord -> Set BoundaryEdge+  addCell edges coordinate =+    foldl' (addDirection coordinate) edges allHexDirections++  addDirection+    :: HexCoord+    -> Set BoundaryEdge+    -> HexDirection+    -> Set BoundaryEdge+  addDirection coordinate edges direction =+    case hexStepCoord coordinate direction of+      Just neighbour | hexRegionMember neighbour region -> edges+      _ ->+        let side = hexCellBoundarySide coordinate direction+         in Set.insert+              (BoundaryEdge (hexBoundaryFrom side) (hexBoundaryTo side))+              edges++traceBoundaryLoops :: Set BoundaryEdge -> Either HexPlanarObstruction [NonEmpty HexVertex]+traceBoundaryLoops edges = descend edges []+ where+  outgoing =+    Set.foldl'+      (\index edge@(BoundaryEdge from _) -> Map.insertWith (<>) from [edge] index)+      Map.empty+      edges++  descend+    :: Set BoundaryEdge+    -> [NonEmpty HexVertex]+    -> Either HexPlanarObstruction [NonEmpty HexVertex]+  descend remaining reversedLoops =+    case Set.lookupMin remaining of+      Nothing -> Right (reverse reversedLoops)+      Just firstEdge@(BoundaryEdge firstVertex _) -> do+        (vertices, unconsumed) <- traceCycle outgoing firstVertex firstEdge (Set.delete firstEdge remaining)+        descend unconsumed (vertices : reversedLoops)++traceCycle+  :: Map HexVertex [BoundaryEdge]+  -> HexVertex+  -> BoundaryEdge+  -> Set BoundaryEdge+  -> Either HexPlanarObstruction (NonEmpty HexVertex, Set BoundaryEdge)+traceCycle outgoing firstVertex firstEdge remaining =+  walk firstEdge (firstVertex :| []) remaining+ where+  walk+    :: BoundaryEdge+    -> NonEmpty HexVertex+    -> Set BoundaryEdge+    -> Either HexPlanarObstruction (NonEmpty HexVertex, Set BoundaryEdge)+  walk current reversedVertices unconsumed =+    let BoundaryEdge _ endpoint = current+     in if endpoint == firstVertex+          then Right (NonEmpty.reverse reversedVertices, unconsumed)+          else do+            next <- selectNextBoundaryEdge outgoing unconsumed current endpoint+            walk next (endpoint NonEmpty.<| reversedVertices) (Set.delete next unconsumed)++selectNextBoundaryEdge+  :: Map HexVertex [BoundaryEdge]+  -> Set BoundaryEdge+  -> BoundaryEdge+  -> HexVertex+  -> Either HexPlanarObstruction BoundaryEdge+selectNextBoundaryEdge outgoing remaining current endpoint =+  case NonEmpty.nonEmpty (filter (`Set.member` remaining) (Map.findWithDefault [] endpoint outgoing)) of+    Nothing -> Left (HexPlanarBoundaryOpen endpoint)+    Just candidates -> do+      currentRank <- boundaryEdgeRank current+      ranked <- traverse (rankCandidate currentRank) candidates+      pure (snd (leastRanked ranked))+ where+  rankCandidate+    :: Int+    -> BoundaryEdge+    -> Either HexPlanarObstruction (Int, BoundaryEdge)+  rankCandidate currentRank candidate = do+    candidateRank <- boundaryEdgeRank candidate+    pure ((candidateRank - currentRank) `mod` 6, candidate)++  leastRanked :: NonEmpty (Int, BoundaryEdge) -> (Int, BoundaryEdge)+  leastRanked (firstRanked :| rest) = foldl' choose firstRanked rest++  choose :: (Int, BoundaryEdge) -> (Int, BoundaryEdge) -> (Int, BoundaryEdge)+  choose left right = if fst left <= fst right then left else right++boundaryEdgeRank :: BoundaryEdge -> Either HexPlanarObstruction Int+boundaryEdgeRank (BoundaryEdge from to) =+  let (fromX, fromY) = hexVertexCoordinates from+      (toX, toY) = hexVertexCoordinates to+   in case (toX - fromX, toY - fromY) of+        (2, 0) -> Right 0+        (1, 1) -> Right 1+        (-1, 1) -> Right 2+        (-2, 0) -> Right 3+        (-1, -1) -> Right 4+        (1, -1) -> Right 5+        _ -> Left (HexPlanarBoundaryVectorUnexpected from to)++publishClassifiedLoops :: [(Integer, ExactLoop)] -> Either HexPlanarObstruction PlanarRegion+publishClassifiedLoops classified = do+  let outerLoops = [(area, loop) | (area, loop) <- classified, area > 0]+      holeLoops = [loop | (area, loop) <- classified, area < 0]+  holesByOuter <- foldlM (assignHole outerLoops) Map.empty holeLoops+  components <-+    traverse+      (\(_, outer) ->+          first HexPlanarRegionInvalid+            (polygonComponent outer (Map.findWithDefault [] outer holesByOuter))+      )+      outerLoops+  first HexPlanarRegionInvalid (planarRegion components)++assignHole+  :: [(Integer, ExactLoop)]+  -> Map ExactLoop [ExactLoop]+  -> ExactLoop+  -> Either HexPlanarObstruction (Map ExactLoop [ExactLoop])+assignHole outerLoops assignments hole =+  case filter (\(_, outer) -> isRight (polygonComponent outer [hole])) outerLoops of+    [] -> Left (HexPlanarHoleUnowned hole)+    firstOwner : remainingOwners ->+      let (_, owner) = foldl' smallerOuter firstOwner remainingOwners+       in Right (Map.insertWith (<>) owner [hole] assignments)+ where+  smallerOuter :: (Integer, ExactLoop) -> (Integer, ExactLoop) -> (Integer, ExactLoop)+  smallerOuter left right = if fst left <= fst right then left else right++signedDoubleArea :: NonEmpty HexVertex -> Integer+signedDoubleArea vertices@(firstVertex :| rest) =+  sum+    [ leftX * rightY - leftY * rightX+    | (left, right) <- zip (NonEmpty.toList vertices) (rest <> [firstVertex])+    , let (leftX, leftY) = hexVertexCoordinates left+    , let (rightX, rightY) = hexVertexCoordinates right+    ]++exactVertexPoint :: HexVertex -> ExactPoint+exactVertexPoint vertex =+  let (x, y) = hexVertexCoordinates vertex+   in exactPoint (fromInteger x) (fromInteger y)
+ src-public/Moonlight/Triangulation.hs view
@@ -0,0 +1,1239 @@+-- | The public surface for Delaunay triangulations as values of finite+-- coordinate supports. Its exports are grouped by object, generation,+-- annotations, finite-set algebra, constraints, refinement, observations and+-- validation.+--+-- Geometry-only set laws are observed after erasing vertex annotations with+-- @mapVertices (const ())@ and applying 'canonicalize'. Successful construction+-- may retain schedule-dependent resident numbering, so structural 'Eq' compares+-- stored representations rather than silently normalizing them. Annotations may+-- change independently through 'mapVertices' and 'setVertexData'; they never+-- determine geometry.+--+-- The algebra is deliberately partial. Finite arena exhaustion is returned as+-- 'BuildError', while unrealizable constrained compositions return+-- 'ConstrainedUnionError'. These typed obstructions are why the surface exposes+-- explicit operations rather than total 'Semigroup' instances. Refinement then+-- composes over any admitted result without introducing a second mesh type.+module Moonlight.Triangulation+  ( -- * The object — a triangulation is a value of its site set+    Triangulation+  , DelaunayTriangulation+  , ConstrainedDelaunayTriangulation+  , ConstraintMode (..)+  , Point (..)+  , QueryPoint+  , queryPointValue+  , PointValidationError (..)+  , mkQueryPoint+  , HasPosition (..)+  , ElementDefaults (..)+  , unitElementDefaults+  , JoinSemilattice (..)+  , Coordinate2 (..)+  , mapCoordinate2+    -- | Fixed identifiers are compact resident indices. Their observations+    -- deliberately avoid a second bounds check and therefore require the+    -- issuing mesh; use the scoped section below or owning handles whenever+    -- mesh provenance is not already carried by the surrounding type.+  , VertexId+  , unVertexId+  , FaceId+  , unFaceId+  , DirectedEdgeId+  , unDirectedEdgeId+  , UndirectedEdgeId+  , unUndirectedEdgeId+  , reverseEdge+  , asUndirected+  , normalizedDirected+  , reversedDirected+  , directedPair+  , isNormalized++    -- * Mesh-scoped observations — zero-cost nominal ownership; identifiers+    -- from distinct scopes cannot be mixed+  , ScopedTriangulation+  , ScopedVertex+  , ScopedDirectedEdge+  , ScopedUndirectedEdge+  , ScopedFace+  , withScopedTriangulation+  , scopedVertices+  , scopedDirectedEdges+  , scopedUndirectedEdges+  , scopedFaces+  , scopedInnerFaces+  , scopedOuterFace+  , scopedVertexPoint+  , scopedVertexData+  , scopedDirectedEdgeData+  , scopedUndirectedEdgeData+  , scopedFaceData+  , scopedVertexOutEdge+  , scopedAdjacentEdge+  , scopedOrigin+  , scopedDestination+  , scopedReverseEdge+  , scopedAsUndirected+  , scopedNext+  , scopedPrevious+  , scopedIncidentFace+  , scopedIsOuterDirectedEdge+  , scopedIsBoundaryEdge+  , scopedIsConstraintEdge+  , scopedUndirectedEndpoints+  , scopedFaceDirectedEdges+  , scopedFaceVertices+  , scopedVertexOutgoingEdges++    -- * Generation and editing — persistent verbs publish one new value;+    -- sessions compose many edits behind one sealed thaw/freeze boundary+  , empty+  , clear+  , delaunay+  , delaunayGeometry+  , DuplicatePayloadPolicy (..)+  , delaunayFromCoordinates+  , BuildResult+  , buildTriangulation+  , buildInputVertices+  , buildStats+  , BuildStats (..)+  , emptyBuildStats+  , InsertionDisposition (..)+  , InsertionResult+  , insertionTriangulation+  , insertionVertex+  , insertionDisposition+  , insertionStats+  , insert+  , insertAt+  , insertMany+  , RemovalOutcome (..)+  , RemovalResult (..)+  , removeVertex+  , locateAndRemove+  , Session+  , withSession+  , insertVertex+  , insertVertexAt+  , insertVertexAtNear+  , insertVertexAtNearVertex+  , removeAt+  , removeAtNear+  , removeManyAt+  , removeManyAtNear+  , refuse+  , BuildError (..)+  , PublicationStats (..)+  , ValidationClosureStats (..)+  , CoordinateError (..)+  , NonFiniteValue (..)++    -- * The annotation functor — payloads annotate geometry, never author it;+    -- the mesh is the same mesh before and after+  , mapVertices+  , mapDirectedEdges+  , mapUndirectedEdges+  , mapFaces+  , imapUndirectedEdges+  , imapFaces+  , PayloadTraversal+  , vertexPayloads+  , directedPayloads+  , undirectedPayloads+  , facePayloads+  , overPayloads+  , foldPayloads+  , payloadList+  , geometryOnlyPublication+  , vertexData+  , directedEdgeData+  , undirectedEdgeData+  , faceData+  , setVertexData+  , setDirectedEdgeData+  , setUndirectedEdgeData+  , setFaceData++    -- * Finite-set algebra and its normal form — support order is observable,+    -- intersection can combine heterogeneous annotations, and each+    -- construction returns its obstruction rather than an instance that lies+  , canonicalize+  , SiteRelation (..)+  , siteRelation+  , union+  , unions+  , intersection+  , intersectionWith+  , difference+  , symmetricDifference++    -- * The constraint layer — 'constrainedDelaunay' is the partial map from+    -- (sites, segments), defined exactly on realizable segment sets and+    -- naming the corridor that blocked it where it is not+  , constrainedDelaunay+  , constrainedDelaunayMaximal+  , fromDelaunay+  , constraintEdges+  , isConstraintEdge+  , boundedRegionFaces+  , CdtError (..)+  , CorridorObstruction (..)+  , CanonicalSegment+  , segmentStart+  , segmentEnd+  , ConstraintConflict+  , conflictFirstSegment+  , conflictSecondSegment+  , ConstrainedUnionError (..)+  , ConstraintBatchResult+  , constraintBatchTriangulation+  , constraintBatchOutcomes+  , constraintBatchStats+  , ConstrainedExtensionResult+  , constrainedExtensionConstraintBatch+  , constrainedExtensionBuildStats+  , ConstraintRecoveryResult (..)+  , ConstraintResult+  , ConstraintOutcome (..)+  , ConstraintBatchStats (..)+  , ConstraintSplitBatchResult+  , CdtBuildResult (..)+  , ConstrainedSeamSide (..)+  , ConstrainedSeamFaceEvidence+  , constrainedSeamSourceFace+  , constrainedSeamTargetFace+  , constrainedSeamFaceFirstPoint+  , constrainedSeamFaceSecondPoint+  , constrainedSeamFaceThirdPoint+  , ConstrainedSeamResult+  , constrainedSeamResultTriangulation+  , constrainedSeamLeftFaceCount+  , constrainedSeamRightFaceEvidence+  , constrainedSeamJoinFaces+  , constrainedSeamLeftConstraintCount+  , constrainedSeamConstraintStats+  , constrainedSeamBuildStats+  , constrainedSeamPublicationStats+  , constrainedSeamCachedFrontierPointReads+  , constraintSegments+  , unionConstrainedWith+  , unionConstrained+  , joinSeparatedConstrained+  , extendConstrainedWith+  , constraintStorageBytes+  , existsConstraint+  , canAddConstraint+  , intersectsConstraint+  , getConflictingEdgesBetweenPoints+  , getConflictingEdgesBetweenVertices+  , recoverConstraints+  , addConstraintEdge+  , addConstraintEdges+  , addConstraintAndSplit+  , addConstraintsAndSplit+  , removeConstraintEdge+  , outerRegionFaces++    -- * Refinement — budget-bounded, composed after any operation above rather+    -- than configured into it; 'refinementComplete' reports sufficiency, not+    -- effort+  , refine+  , refineWithinDomain+  , validateRefinementParameters+  , RefinementParameters (..)+  , defaultRefinementParameters+  , RefinementReceipt+  , RefinementDomainResult+  , RefinementResult+  , refinementDomainResult+  , refinementDomainReceipt+  , refinedTriangulation+  , refinementStats+  , refinementVisitedJoinFaces+  , refinementVisitedProtectedFaces+  , refinementCreatedFaces+  , refinementFinalPermittedFaces+  , refinementFinalInterfaceIncidence+  , refinementTouchedEdges+  , refinementRemovedEdges+  , refinementInterfaceBoundaryReads+  , refinementAttemptedBoundaryCrossings+  , refinementPublicationStats+  , refinementValidationClosureStats+  , refinementAddedVertices+  , refinementExcludedFaces+  , refinementComplete+  , withMinimumAngle+  , radiusEdgeRatioForAngle++    -- * Observations — pure functions of the value: incidence, location,+    -- interpolation and barrier parity, none of which build a second mesh+  , numVertices+  , vertices+  , foldVertices'+  , vertexPoint+  , vertexPoints+  , numFaces+  , numInnerFaces+  , allFaces+  , innerFaces+  , foldAllFaces'+  , foldInnerFaces'+  , outerFace+  , adjacentEdge+  , faceDirectedEdges+  , faceVertices+  , innerFaceDirectedEdges+  , innerFaceVertices+  , innerFaceDirectedEdgeTriples+  , innerFaceVertexTriples+  , foldFaceDirectedEdges'+  , vertexOutEdge+  , vertexOutgoingEdges+  , foldVertexOutgoingEdges'+  , numDirectedEdges+  , directedEdges+  , foldDirectedEdges'+  , numUndirectedEdges+  , undirectedEdges+  , foldUndirectedEdges'+  , hullEdges+  , hullVertices+  , undirectedEndpoints+  , origin+  , destination+  , next+  , previous+  , clockwise+  , counterClockwise+  , incidentFace+  , isOuterDirectedEdge+  , isBoundaryEdge+  , numConstraints+  , locatePoint+  , locatePointWithHint+  , Location (..)+  , nearestNeighbor+  , NearestStats (..)+  , interpolateNearest+  , interpolateBarycentric+  , LocationHint (..)+  , LocationStats (..)+  , emptyLocationStats+  , Intersection (..)+  , lineIntersections+  , lineIntersectionsBetweenVertices+  , foldCorridorBetweenPoints+  , foldCorridorBetweenVertices+  , conflictingEdges+  , segmentIntersectsNonCollinear+  , DistanceMetric (..)+  , CircleMetric+  , CircleMetricError (..)+  , RectangleMetric+  , RectangleMetricError (..)+  , circleMetric+  , rectangleMetric+  , edgesInShape+  , verticesInShape+  , edgesInCircle+  , verticesInCircle+  , edgesInRectangle+  , verticesInRectangle+  , floodFillFaces+  , outerFaceFloodFill+  , facesAtEvenBarrierDepth++    -- ** Robust planar predicates and constructions+  , orient2d+  , sideQuery+  , inCircle+  , segmentRelation+  , segmentsProperlyCross+  , segmentsIntersect+  , squaredDistance+  , distance+  , midpoint+  , centroid+  , triangleArea+  , circumcenter+  , barycentricCoordinates++    -- ** Face regions and alpha filtration+  , FaceComponent+  , faceComponentFaces+  , BoundaryOrientation (..)+  , BoundaryLoop+  , boundaryLoopOrientation+  , boundaryLoopResidentVertices+  , boundaryLoopVertices+  , RegionBoundary+  , regionBoundaryOuterLoop+  , regionBoundaryHoleLoops+  , BoundaryObstruction (..)+  , faceComponents+  , faceComponentsBy+  , labelledRegionBoundaries+  , componentBoundaryLoops+  , componentBoundary+  , componentBoundaryForFaces+  , RadiusSquared+  , RadiusSquaredError (..)+  , mkRadiusSquared+  , radiusSquaredValue+  , AlphaBirth+  , alphaBirthNumerator+  , alphaBirthDenominator+  , alphaBirthToDouble+  , alphaBirthFromRadiusSquared+  , AlphaFiltration+  , AlphaFiltrationError (..)+  , alphaFiltration+  , alphaFiltrationCellSet+  , alphaVertexBirth+  , alphaEdgeBirth+  , alphaFaceBirth+  , alphaFiltrationCriticalBirths+  , alphaComplexAtBirth+  , alphaComplexAtRadius+  , alphaShapeContainsFace++    -- * Exact planar regions — authoritative rational geometry, labelled+    -- overlay, closed cell selections, valuations, and polygonal morphology+  , ExactRational+  , ExactArithmeticError (..)+  , exactRational+  , exactRationalNumerator+  , exactRationalDenominator+  , ExactPoint+  , exactPoint+  , exactPointCoordinates+  , exactPointCross+  , ExactVector (..)+  , exactVectorFromPoints+  , addExactVectors+  , exactCross+  , compareExactVectorAngle+  , translateExactPoint+  , ExactRay+  , exactRay+  , exactRayOrigin+  , exactRayDirection+  , ExactSegment+  , ExactGeometryError (..)+  , exactSegment+  , exactSegmentEndpoints+  , exactPointFromPoint+  , exactPointFromQueryPoint+  , exactPointToEmbeddingCandidate+  , exactOrient2d+  , exactOnClosedSegment+  , SegmentRelation (..)+  , allSegmentRelations+  , exactSegmentRelation+  , ExactIntersectionError (..)+  , exactLineIntersection+  , exactSupportingLineIntersection+  , 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 (..)+  , CoverGap+  , coverGapRegion+  , LayerCoverageError (..)+  , overlayLayers+  , overlayAll+  , overlayEmbeddedTriangulation+  , overlayReceipt+  , overlayCells+  , overlayArrangementVertices+  , overlayArrangementEdges+  , overlayPlanarLayer+  , overlaySelectedRegion+  , overlayMass+  , overlayConfusion+  , layerCovers+  , overlayClosedUnion+  , overlayClosedIntersection+  , overlayRegularizedDifference+  , EulerCharacteristic+  , eulerCharacteristicValue+  , ExactArea+  , ExactPlanarMoments+  , exactAreaValue+  , exactPlanarMeasure+  , exactPlanarFirstX+  , exactPlanarFirstY+  , exactPlanarSecondXX+  , exactPlanarSecondXY+  , exactPlanarSecondYY+  , scaleExactPlanarMoments+  , polygonComponentMoments+  , polygonComponentArea+  , ExactLengthTerm+  , lengthCoefficient+  , squaredLength+  , ExactLengthExpression+  , exactLengthTerms+  , CertifiedInterval (..)+  , ExactLengthMeasurement+  , exactLengthExpression+  , exactLengthBounds+  , PlanarValuations+  , valuationEuler+  , valuationArea+  , valuationIntrinsic1+  , ValuationError (..)+  , cellValuations+  , regionValuations+  , planarValuationsPerimeter+  , cellSetPerimeter+  , regionPerimeter+  , ConvexPolygon+  , convexPolygon+  , convexPolygonPoints+  , StructuringElement+  , structuringElement+  , MinkowskiOperation (..)+  , MinkowskiError (..)+  , MinkowskiReceipt (..)+  , convexMinkowskiSum+  , reflectConvexPolygon+  , minkowskiSum+  , erodeBy+  , openWith+  , closeWith+  , polygonOffset+  , polygonInset+  , PowerWeight+  , PowerWeightError (..)+  , powerWeight+  , powerWeightFromExact+  , powerWeightExact+  , PowerSite+  , powerSite+  , powerSiteLabel+  , powerSitePosition+  , powerSiteExactPosition+  , powerSiteWeight+  , PowerCellDisposition (..)+  , RegularSiteDisposition (..)+  , RegularFace+  , regularFaceLabels+  , regularFaceDualPoint+  , PowerDualEdge (..)+  , RegularEdge+  , regularEdgeLabels+  , regularEdgeDual+  , RegularTriangulation+  , emptyRegularTriangulation+  , regularTriangulation+  , regularSite+  , regularSites+  , regularSiteCount+  , regularSiteDisposition+  , regularFaces+  , regularEdges+  , regularNeighbours+  , regularTriangulationReceipt+  , RegularTriangulationReceipt (..)+  , RegularSiteTransition (..)+  , RegularEditError (..)+  , RegularEditResult (..)+  , insertRegularSite+  , removeRegularSite+  , reweightRegularSites+  , BoundedPowerDiagram+  , boundedPowerDiagram+  , boundedPowerDiagramFromRegular+  , powerCellDisposition+  , powerCellDispositions+  , powerDiagramPlanarLayer+  , PowerDiagramError (..)+  , RegularTopologyError (..)+  , PowerDiagramReceipt (..)+  , powerDiagramInputSites+  , powerDiagramPeakIntermediateBitGrowth+  , powerDiagramFinalCoordinateBitGrowth+  , AffineForm (..)+  , UpperEnvelopeError (..)+  , upperEnvelope+  , PowerAlphaBirth+  , powerAlphaBirthExact+  , powerAlphaBirthNumerator+  , powerAlphaBirthDenominator+  , RegularAlphaFiltration+  , RegularAlphaError (..)+  , regularAlphaFiltration+  , regularAlphaComplex+  , regularAlphaBirths+  , regularAlphaSimplexBirth+  , regularAlphaCriticalBirths+  , regularAlphaComplexAtBirth++    -- * Discharge — the invariants the constructors guarantee, checkable on a+    -- value built by any route; every violation is a value carrying its witness+  , validateTopology+  , validateDelaunay+  , validateTriangulation+  , triangulationIsValid+  , faceArea+  , faceMinimumAngleDegrees+  , InvariantViolation (..)+  ) where++import Moonlight.Triangulation.BulkLoad+  ( DuplicatePayloadPolicy (..)+  , clear+  , delaunay+  , delaunayFromCoordinates+  , delaunayGeometry+  , empty+  , insert+  , insertAt+  , insertMany+  )+import Moonlight.Triangulation.CellSet+  ( CellSelectionError (..)+  , ExactCellSet+  , closeFaceCellSet+  , exactCellSet+  , exactCellSetEdgeCount+  , exactCellSetFaceCount+  , exactCellSetVertexCount+  , foldExactCellEdges+  , foldExactCellFaces+  , foldExactCellVertices+  )+import Moonlight.Triangulation.Dcel+  ( adjacentEdge+  , clockwise+  , counterClockwise+  , destination+  , directedEdgeData+  , faceData+  , faceDirectedEdges+  , faceVertices+  , foldFaceDirectedEdges'+  , foldVertexOutgoingEdges'+  , imapFaces+  , imapUndirectedEdges+  , innerFaceDirectedEdges+  , innerFaceDirectedEdgeTriples+  , innerFaceVertices+  , innerFaceVertexTriples+  , incidentFace+  , isBoundaryEdge+  , isConstraintEdge+  , isOuterDirectedEdge+  , next+  , numConstraints+  , numDirectedEdges+  , numFaces+  , numInnerFaces+  , numUndirectedEdges+  , numVertices+  , origin+  , outerFace+  , previous+  , setDirectedEdgeData+  , setFaceData+  , setUndirectedEdgeData+  , setVertexData+  , undirectedEdgeData+  , undirectedEndpoints+  , vertexData+  , vertexOutEdge+  , vertexOutgoingEdges+  , vertexPoint+  , vertexPoints+  )+import Moonlight.Triangulation.Alpha+  ( AlphaBirth+  , AlphaFiltration+  , AlphaFiltrationError (..)+  , alphaBirthDenominator+  , alphaBirthFromRadiusSquared+  , alphaBirthNumerator+  , alphaBirthToDouble+  , alphaComplexAtBirth+  , alphaComplexAtRadius+  , alphaEdgeBirth+  , alphaFaceBirth+  , alphaFiltration+  , alphaFiltrationCellSet+  , alphaFiltrationCriticalBirths+  , alphaShapeContainsFace+  , alphaVertexBirth+  )+import Moonlight.Triangulation.FloodFillIterator+  ( BoundaryLoop+  , BoundaryObstruction (..)+  , BoundaryOrientation (..)+  , CircleMetric+  , CircleMetricError (..)+  , DistanceMetric (..)+  , FaceComponent+  , RectangleMetric+  , RectangleMetricError (..)+  , RegionBoundary+  , boundaryLoopOrientation+  , boundaryLoopResidentVertices+  , boundaryLoopVertices+  , circleMetric+  , componentBoundary+  , componentBoundaryLoops+  , componentBoundaryForFaces+  , edgesInCircle+  , edgesInRectangle+  , edgesInShape+  , faceComponentFaces+  , faceComponents+  , faceComponentsBy+  , facesAtEvenBarrierDepth+  , floodFillFaces+  , labelledRegionBoundaries+  , outerFaceFloodFill+  , rectangleMetric+  , regionBoundaryHoleLoops+  , regionBoundaryOuterLoop+  , verticesInCircle+  , verticesInRectangle+  , verticesInShape+  )+import Moonlight.Triangulation.Exact+  ( ExactGeometryError (..)+  , ExactIntersectionError (..)+  , ExactPoint+  , ExactRay+  , ExactSegment+  , ExactVector (..)+  , SegmentRelation (..)+  , addExactVectors+  , allSegmentRelations+  , compareExactVectorAngle+  , exactCross+  , exactLineIntersection+  , exactOnClosedSegment+  , exactOrient2d+  , exactPoint+  , exactPointCoordinates+  , exactPointCross+  , exactPointFromPoint+  , exactPointFromQueryPoint+  , exactPointToEmbeddingCandidate+  , exactRay+  , exactRayDirection+  , exactRayOrigin+  , exactSegment+  , exactSegmentEndpoints+  , exactSegmentRelation+  , exactSupportingLineIntersection+  , exactVectorFromPoints+  , translateExactPoint+  )+import Moonlight.Triangulation.Handles.HandleDefs+  ( DirectedEdgeId+  , FaceId+  , UndirectedEdgeId+  , VertexId+  , asUndirected+  , directedPair+  , isNormalized+  , normalizedDirected+  , reverseEdge+  , reversedDirected+  , unDirectedEdgeId+  , unFaceId+  , unUndirectedEdgeId+  , unVertexId+  )+import Moonlight.Triangulation.Handles.Iterators.FixedIterators+  ( allFaces+  , directedEdges+  , foldAllFaces'+  , foldDirectedEdges'+  , foldInnerFaces'+  , foldUndirectedEdges'+  , foldVertices'+  , innerFaces+  , undirectedEdges+  , vertices+  )+import Moonlight.Triangulation.Handles.Iterators.HullIterator+  ( hullEdges+  , hullVertices+  )+import Moonlight.Triangulation.Handles.Scoped+  ( ScopedDirectedEdge+  , ScopedFace+  , ScopedTriangulation+  , ScopedUndirectedEdge+  , ScopedVertex+  , scopedAdjacentEdge+  , scopedAsUndirected+  , scopedDestination+  , scopedDirectedEdgeData+  , scopedDirectedEdges+  , scopedFaceData+  , scopedFaceDirectedEdges+  , scopedFaceVertices+  , scopedFaces+  , scopedIncidentFace+  , scopedInnerFaces+  , scopedIsBoundaryEdge+  , scopedIsConstraintEdge+  , scopedIsOuterDirectedEdge+  , scopedNext+  , scopedOrigin+  , scopedOuterFace+  , scopedPrevious+  , scopedReverseEdge+  , scopedUndirectedEdgeData+  , scopedUndirectedEdges+  , scopedUndirectedEndpoints+  , scopedVertexData+  , scopedVertexOutEdge+  , scopedVertexOutgoingEdges+  , scopedVertexPoint+  , scopedVertices+  , withScopedTriangulation+  )+import Moonlight.Triangulation.Canonical (canonicalize)+import Moonlight.Triangulation.Cdt+  ( CanonicalSegment+  , CdtBuildResult (..)+  , CdtError (..)+  , ConstrainedExtensionResult+  , ConstrainedSeamFaceEvidence+  , ConstrainedSeamResult+  , ConstrainedSeamSide (..)+  , ConstrainedUnionError (..)+  , ConstraintBatchStats (..)+  , ConstraintBatchResult+  , ConstraintConflict+  , ConstraintOutcome (..)+  , ConstraintRecoveryResult (..)+  , ConstraintResult+  , ConstraintSplitBatchResult+  , CorridorObstruction (..)+  , addConstraintAndSplit+  , addConstraintEdge+  , addConstraintEdges+  , addConstraintsAndSplit+  , boundedRegionFaces+  , canAddConstraint+  , constrainedDelaunay+  , constrainedDelaunayMaximal+  , constrainedExtensionBuildStats+  , constrainedExtensionConstraintBatch+  , constraintEdges+  , constraintBatchOutcomes+  , constraintBatchStats+  , constraintBatchTriangulation+  , constraintSegments+  , constraintStorageBytes+  , constrainedSeamBuildStats+  , constrainedSeamConstraintStats+  , constrainedSeamCachedFrontierPointReads+  , constrainedSeamFaceFirstPoint+  , constrainedSeamFaceSecondPoint+  , constrainedSeamFaceThirdPoint+  , constrainedSeamLeftConstraintCount+  , constrainedSeamLeftFaceCount+  , constrainedSeamJoinFaces+  , constrainedSeamPublicationStats+  , constrainedSeamResultTriangulation+  , constrainedSeamRightFaceEvidence+  , constrainedSeamSourceFace+  , constrainedSeamTargetFace+  , conflictFirstSegment+  , conflictSecondSegment+  , existsConstraint+  , extendConstrainedWith+  , fromDelaunay+  , getConflictingEdgesBetweenPoints+  , getConflictingEdgesBetweenVertices+  , intersectsConstraint+  , joinSeparatedConstrained+  , outerRegionFaces+  , recoverConstraints+  , removeConstraintEdge+  , segmentEnd+  , segmentStart+  , unionConstrained+  , unionConstrainedWith+  )+import Moonlight.Triangulation.Internal.Paged (PublicationStats (..))+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactArithmeticError (..)+  , ExactRational+  , exactRational+  , exactRationalDenominator+  , exactRationalNumerator+  )+import Moonlight.Triangulation.Internal.Representation (geometryOnlyPublication)+import Moonlight.Triangulation.Interop+  ( Coordinate2 (..)+  , mapCoordinate2+  )+import Moonlight.Triangulation.IntersectionIterator+  ( Intersection (..)+  , conflictingEdges+  , foldCorridorBetweenPoints+  , foldCorridorBetweenVertices+  , lineIntersections+  , lineIntersectionsBetweenVertices+  , segmentIntersectsNonCollinear+  )+import Moonlight.Triangulation.Types+  ( BuildError (..)+  , BuildResult+  , BuildStats (..)+  , ConstrainedDelaunayTriangulation+  , ConstraintMode (..)+  , CoordinateError (..)+  , DelaunayTriangulation+  , ElementDefaults (..)+  , HasPosition (..)+  , InsertionDisposition (..)+  , InsertionResult+  , InvariantViolation (..)+  , Location (..)+  , LocationHint (..)+  , LocationStats (..)+  , NearestStats (..)+  , NonFiniteValue (..)+  , Point (..)+  , PointValidationError (..)+  , QueryPoint+  , RadiusSquared+  , RadiusSquaredError (..)+  , RefinementDomainResult+  , RefinementParameters (..)+  , RefinementReceipt+  , RefinementResult+  , SiteRelation (..)+  , Triangulation+  , ValidationClosureStats (..)+  , buildInputVertices+  , buildStats+  , buildTriangulation+  , defaultRefinementParameters+  , emptyBuildStats+  , emptyLocationStats+  , insertionDisposition+  , insertionStats+  , insertionTriangulation+  , insertionVertex+  , mkRadiusSquared+  , queryPointValue+  , radiusSquaredValue+  , refinedTriangulation+  , refinementAddedVertices+  , refinementAttemptedBoundaryCrossings+  , refinementComplete+  , refinementCreatedFaces+  , refinementDomainReceipt+  , refinementDomainResult+  , refinementExcludedFaces+  , refinementFinalInterfaceIncidence+  , refinementFinalPermittedFaces+  , refinementInterfaceBoundaryReads+  , refinementPublicationStats+  , refinementRemovedEdges+  , refinementStats+  , refinementTouchedEdges+  , refinementValidationClosureStats+  , refinementVisitedJoinFaces+  , refinementVisitedProtectedFaces+  , unitElementDefaults+  )+import Moonlight.Triangulation.Interpolation+  ( interpolateBarycentric+  , interpolateNearest+  , nearestNeighbor+  )+import Moonlight.Triangulation.Minkowski+  ( ConvexPolygon+  , MinkowskiError (..)+  , MinkowskiOperation (..)+  , MinkowskiReceipt (..)+  , StructuringElement+  , closeWith+  , convexMinkowskiSum+  , reflectConvexPolygon+  , convexPolygon+  , convexPolygonPoints+  , erodeBy+  , minkowskiSum+  , openWith+  , polygonInset+  , polygonOffset+  , structuringElement+  )+import Moonlight.Triangulation.Math+  ( barycentricCoordinates+  , centroid+  , circumcenter+  , distance+  , inCircle+  , midpoint+  , mkQueryPoint+  , orient2d+  , segmentRelation+  , segmentsIntersect+  , segmentsProperlyCross+  , sideQuery+  , squaredDistance+  , triangleArea+  )+import Moonlight.Triangulation.Overlay+  ( CoverGap+  , LayerCoverageError (..)+  , OverlayError (..)+  , OverlayReceipt (..)+  , OverlayResult+  , OverlaySelectionError (..)+  , OverlaySelectionKind (..)+  , coverGapRegion+  , layerCovers+  , overlayAll+  , overlayArrangementEdges+  , overlayArrangementVertices+  , overlayCells+  , overlayClosedIntersection+  , overlayClosedUnion+  , overlayEmbeddedTriangulation+  , overlayLayers+  , overlayMass+  , overlayConfusion+  , overlayPlanarLayer+  , overlayReceipt+  , overlayRegularizedDifference+  , overlaySelectedRegion+  )+import Moonlight.Triangulation.PowerDiagram+  ( AffineForm (..)+  , BoundedPowerDiagram+  , PowerDualEdge (..)+  , PowerCellDisposition (..)+  , PowerDiagramError (..)+  , PowerDiagramReceipt (..)+  , PowerSite+  , PowerWeight+  , PowerWeightError (..)+  , RegularEdge+  , RegularEditError (..)+  , RegularEditResult (..)+  , RegularFace+  , RegularSiteDisposition (..)+  , RegularSiteTransition (..)+  , RegularTriangulation+  , RegularTriangulationReceipt (..)+  , RegularTopologyError (..)+  , UpperEnvelopeError (..)+  , boundedPowerDiagram+  , boundedPowerDiagramFromRegular+  , emptyRegularTriangulation+  , insertRegularSite+  , powerCellDisposition+  , powerCellDispositions+  , powerDiagramPlanarLayer+  , powerDiagramInputSites+  , powerDiagramPeakIntermediateBitGrowth+  , powerDiagramFinalCoordinateBitGrowth+  , powerSite+  , powerSiteLabel+  , powerSitePosition+  , powerSiteExactPosition+  , powerSiteWeight+  , powerWeight+  , powerWeightFromExact+  , powerWeightExact+  , regularEdgeDual+  , regularEdgeLabels+  , regularEdges+  , regularFaceDualPoint+  , regularFaceLabels+  , regularFaces+  , regularNeighbours+  , regularSite+  , regularSiteCount+  , regularSiteDisposition+  , regularSites+  , regularTriangulation+  , regularTriangulationReceipt+  , removeRegularSite+  , reweightRegularSites+  , upperEnvelope+  )+import Moonlight.Triangulation.RegularAlpha+  ( PowerAlphaBirth+  , RegularAlphaError (..)+  , RegularAlphaFiltration+  , powerAlphaBirthDenominator+  , powerAlphaBirthExact+  , powerAlphaBirthNumerator+  , regularAlphaBirths+  , regularAlphaComplex+  , regularAlphaComplexAtBirth+  , regularAlphaCriticalBirths+  , regularAlphaFiltration+  , regularAlphaSimplexBirth+  )+import Moonlight.Triangulation.Payload+  ( PayloadTraversal+  , directedPayloads+  , facePayloads+  , foldPayloads+  , mapDirectedEdges+  , mapFaces+  , mapUndirectedEdges+  , mapVertices+  , overPayloads+  , payloadList+  , undirectedPayloads+  , vertexPayloads+  )+import Moonlight.Triangulation.PointLocation+  ( locatePoint+  , locatePointWithHint+  )+import Moonlight.Triangulation.Removal+  ( RemovalOutcome (..)+  , RemovalResult (..)+  , locateAndRemove+  , removeVertex+  )+import Moonlight.Triangulation.JoinSemilattice (JoinSemilattice (..))+import Moonlight.Triangulation.Refinement+  ( radiusEdgeRatioForAngle+  , refine+  , refineWithinDomain+  , 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+  , intersectionWith+  , siteRelation+  , symmetricDifference+  , union+  , unions+  )+import Moonlight.Triangulation.Session+  ( Session+  , insertVertex+  , insertVertexAt+  , insertVertexAtNear+  , insertVertexAtNearVertex+  , refuse+  , removeAt+  , removeAtNear+  , removeManyAt+  , removeManyAtNear+  , withSession+  )+import Moonlight.Triangulation.Validation+  ( faceArea+  , faceMinimumAngleDegrees+  , triangulationIsValid+  , validateDelaunay+  , validateTopology+  , validateTriangulation+  )+import Moonlight.Triangulation.Valuation+  ( CertifiedInterval (..)+  , EulerCharacteristic+  , ExactArea+  , ExactPlanarMoments+  , ExactLengthExpression+  , ExactLengthMeasurement+  , ExactLengthTerm+  , PlanarValuations+  , ValuationError (..)+  , cellSetPerimeter+  , cellValuations+  , eulerCharacteristicValue+  , exactAreaValue+  , exactPlanarFirstX+  , exactPlanarFirstY+  , exactPlanarMeasure+  , exactPlanarSecondXX+  , exactPlanarSecondXY+  , exactPlanarSecondYY+  , polygonComponentArea+  , polygonComponentMoments+  , exactLengthBounds+  , exactLengthExpression+  , exactLengthTerms+  , lengthCoefficient+  , planarValuationsPerimeter+  , regionPerimeter+  , regionValuations+  , scaleExactPlanarMoments+  , squaredLength+  , valuationArea+  , valuationEuler+  , valuationIntrinsic1+  )
+ src-public/Moonlight/Triangulation/HintGenerator.hs view
@@ -0,0 +1,493 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | Reusable point-location hints and their topology-preserving maintenance.+module Moonlight.Triangulation.HintGenerator+  ( LastUsedHint+  , emptyLastUsedHint+  , lastUsedHint+  , rememberVertex+  , HierarchyHint+  , defaultHierarchyBranchFactor+  , buildHierarchyHint+  , hierarchyHint+  , hierarchyBranchFactor+  , hierarchyBaseCount+  , hierarchyLevelCount+  , hierarchyVertexCount+  , updateHierarchyAfterInsertion+  , updateHierarchyAfterRemoval+  , rebuildHierarchyHint+  , removeManyWithHierarchy+  ) where++import qualified Data.Vector as V+import Control.DeepSeq (NFData)+import Data.List (sort)+import Data.Word (Word32)+import Moonlight.Triangulation.BulkLoad (delaunay, insert)+import Moonlight.Triangulation.Dcel (numUndirectedEdges, numVertices, undirectedEndpoints, vertexPoint)+import Moonlight.Triangulation.Internal.HandleDefs+  ( UndirectedEdgeId (..)+  , VertexId (..)+  , vertexIdIndex+  )+import Moonlight.Triangulation.Interpolation (nearestNeighbor)+import Moonlight.Triangulation.Math (canonicalPoint, validatePoint)+import Moonlight.Triangulation.Removal (RemovalOutcome, removalTriangulation, removeVertex)+import Moonlight.Triangulation.Session (removeManyAtNear, withSession)+import Moonlight.Triangulation.Types+import GHC.Generics (Generic)++-- | Most recently admitted vertex, suitable as the next descent seed.+newtype LastUsedHint = LastUsedHint (Maybe VertexId)+  deriving stock (Show)+  deriving newtype (Eq, Ord)++-- | A last-used hint with no remembered vertex.+emptyLastUsedHint :: LastUsedHint+emptyLastUsedHint = LastUsedHint Nothing++-- | Project a remembered vertex into a location hint.+lastUsedHint :: LastUsedHint -> Maybe LocationHint+lastUsedHint (LastUsedHint vertex) = VertexHint <$> vertex++-- | Replace the remembered vertex.+rememberVertex :: VertexId -> LastUsedHint -> LastUsedHint+rememberVertex vertex _ = LastUsedHint (Just vertex)++-- | A Delaunay hierarchy for logarithmic expected random point location.+-- The first vector element is the finest sparse level; the final element is+-- the coarsest. The base triangulation is not duplicated.+--+-- The levels are nested by a single arithmetic law rather than by a stored+-- correspondence. Level @i@ holds every @branch^(i+1)@-th base vertex in base+-- order, so a level-local handle @j@ names handle @j * branch@ one level finer+-- — and at level 0 the finer level is the base mesh itself, under the very+-- same multiplication. Descent therefore never rediscovers a handle it has+-- already computed, and no level carries an index vector.+--+-- 'hierarchyBaseCount' is the base cardinality the levels were sampled from.+-- It is the hierarchy's claim about which triangulation it answers for, and+-- every maintenance entry is stated against it: a base whose cardinality is not+-- the one recorded here plus the movement the operation performs is not the+-- base this hierarchy describes, and is rebuilt for rather than patched.+data HierarchyHint = HierarchyHint+  { hierarchyBranchFactor :: {-# UNPACK #-} !Int+    -- ^ Sampling stride between adjacent hierarchy levels.+  , hierarchyBaseCount :: {-# UNPACK #-} !Int+    -- ^ Cardinality of the base mesh described by the hierarchy.+  , hierarchyLevels :: !(V.Vector (Triangulation 'Unconstrained (Point) () () ()))+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++instance Show (HierarchyHint) where+  showsPrec precedence hierarchy =+    showParen (precedence > 10) $+      showString "HierarchyHint "+        . shows (hierarchyBranchFactor hierarchy)+        . showString " "+        . shows (hierarchyBaseCount hierarchy)+        . showString " "+        . shows (hierarchyLevelCount hierarchy)+        . showString " "+        . shows (hierarchyVertexCount hierarchy)++instance Eq (HierarchyHint) where+  left == right =+    hierarchyBranchFactor left == hierarchyBranchFactor right+      && hierarchyBaseCount left == hierarchyBaseCount right+      && hierarchyLevelCount left == hierarchyLevelCount right+      && V.and (V.zipWith sameSparseMesh (hierarchyLevels left) (hierarchyLevels right))++-- Two sparse levels are the same hint when they carry the same points and the+-- same undirected edges. Half-edge index labelling records the order+-- construction happened to visit, so a level rebuilt from scratch and a level+-- extended in place are structurally equal while their arrays are not.+sameSparseMesh+  :: Triangulation 'Unconstrained (Point) () () ()+  -> Triangulation 'Unconstrained (Point) () () ()+  -> Bool+sameSparseMesh left right =+  numVertices left == numVertices right+    && numUndirectedEdges left == numUndirectedEdges right+    && meshPoints left == meshPoints right+    && meshEdges left == meshEdges right+ where+  meshPoints+    :: Triangulation mode vertex directed undirected face+    -> [Point]+  meshPoints triangulation =+    sort [vertexPoint triangulation (VertexId (fromIntegral index)) | index <- [0 .. numVertices triangulation - 1]]++  meshEdges+    :: Triangulation mode vertex directed undirected face+    -> [(Point, Point)]+  meshEdges triangulation =+    sort+      [ if from <= to then (from, to) else (to, from)+      | index <- [0 .. numUndirectedEdges triangulation - 1]+      , let (fromVertex, toVertex) = undirectedEndpoints triangulation (UndirectedEdgeId (fromIntegral index))+            from = vertexPoint triangulation fromVertex+            to = vertexPoint triangulation toVertex+      ]++-- | Default sampling stride between hierarchy levels.+defaultHierarchyBranchFactor :: Int+defaultHierarchyBranchFactor = 16++-- | Number of stored sparse levels.+hierarchyLevelCount :: HierarchyHint -> Int+hierarchyLevelCount = V.length . hierarchyLevels++-- | Total vertices retained across every sparse level.+hierarchyVertexCount :: HierarchyHint -> Int+hierarchyVertexCount =+  V.foldl' (\total level -> total + numVertices level) 0 . hierarchyLevels++-- | Build nested sparse Delaunay levels. A branch factor of 16 mirrors Spade's+-- default and gives O(log n) expected descent on uniformly distributed input.+--+-- Each level is bulk loaded from the sampled points in base order. Base+-- vertices carry pairwise distinct positions, so the load deduplicates nothing+-- and assigns local handle @j@ to sample @j@ — which is what makes the nesting+-- law on 'hierarchyLevels' an identity rather than a lookup.+buildHierarchyHint+  :: Int+  -> Triangulation mode vertex directed undirected face+  -> Either BuildError (HierarchyHint)+buildHierarchyHint requestedBranch triangulation =+  HierarchyHint branch count <$> V.mapM buildLevel levelDivisors+ where+  !branch = max 2 requestedBranch+  !count = numVertices triangulation+  levelDivisors =+    V.unfoldr+      (\candidate ->+         case candidate of+           Nothing -> Nothing+           Just divisor ->+             let !population = samplePopulation count divisor+                 next =+                   if population <= 1+                     then Nothing+                     else Just (safeMultiply divisor branch)+              in Just (divisor, next)+      )+      (if count <= 0 then Nothing else Just branch)++  buildLevel divisor =+    buildTriangulation+      <$> delaunay+        unitElementDefaults+        ( V.generate+            (samplePopulation count divisor)+            (\index ->+               vertexPoint+                 triangulation+                 (VertexId (fromIntegral (index * divisor)))+            )+        )++-- | Descend from the coarsest sparse triangulation. The handle a level returns+-- is carried to the next finer level by one multiplication, and the same+-- multiplication at level 0 names the base vertex. Nothing is relocated: the+-- coarse answer is not searched for again, it is computed.+hierarchyHint :: HierarchyHint -> QueryPoint -> Maybe LocationHint+hierarchyHint HierarchyHint{hierarchyBranchFactor, hierarchyLevels} query =+  VertexHint <$> descend (V.length hierarchyLevels - 1) Nothing+ where+  !branch = fromIntegral hierarchyBranchFactor :: Word32++  descend !levelIndex !coarse+    | levelIndex < 0 = Nothing+    | otherwise =+        case nearestNeighbor (hierarchyLevels V.! levelIndex) coarse query of+          Nothing -> Nothing+          Just (VertexId local, _) ->+            let !finer = VertexId (local * branch)+             in if levelIndex == 0 then Just finer else descend (levelIndex - 1) (Just finer)+++-- | Update the nested hierarchy from an insertion's own report: the point the+-- insertion was asked for, the handle it answered, and whether it created a+-- site. Only the levels selected by the branch divisibility rule are changed.+-- Unaffected levels are structurally shared.+--+-- No triangulation is named. The hierarchy walks its own levels and nothing+-- else, so a base was only ever a lookup table for three facts — its+-- cardinality, the stored position of the new vertex, and the position of+-- vertex zero — and every one of them is in the report or already in the+-- levels, because level-local handle zero is base handle zero at every level.+-- A caller maintaining the hierarchy across a run of insertions therefore+-- never has to publish a mesh to be allowed to speak to it, which is the whole+-- cost of the arrangement this replaces: one full arena copy per step, paid+-- only to name the thing that was just edited.+--+-- An insertion that found its point already present created no site, and a+-- hierarchy valid for a triangulation is valid for that same triangulation, so+-- the answer is the argument, unexamined.+updateHierarchyAfterInsertion+  :: HierarchyHint+  -> Point+  -> VertexId+  -> InsertionDisposition+  -> Either BuildError (HierarchyHint)+updateHierarchyAfterInsertion hierarchy requested vertex disposition =+  case disposition of+    AlreadyPresent -> Right hierarchy+    Inserted+      | vertexIdIndex vertex /= baseIndex ->+          Left+            ( HierarchyInsertionHandleMismatch+                (VertexId (fromIntegral baseIndex))+                vertex+            )+      | otherwise -> do+          updated <- updateLevels branch (V.toList (hierarchyLevels hierarchy))+          topped <- ensureSingletonTop updated+          pure+            hierarchy+              { hierarchyBaseCount = baseIndex + 1+              , hierarchyLevels = V.fromList topped+              }+ where+  !branch = hierarchyBranchFactor hierarchy+  !baseIndex = hierarchyBaseCount hierarchy+  -- A level holds what the mesh stores, not what the caller wrote: storage+  -- rounds a signed zero, and a level built from the unrounded point would+  -- settle a distance tie against a different handle.+  !point = canonicalPoint requested++  -- An update is the only operation that can break the nesting law, so the law+  -- is stated here as an equation rather than trusted: a level admitted to the+  -- new base vertex must already hold exactly @baseIndex / divisor@ samples,+  -- and must receive the vertex at its end.+  updateLevels !_ [] = Right []+  updateLevels !divisor levels@(level : rest)+    | baseIndex `rem` divisor /= 0 = Right levels+    | safeMultiply (numVertices level) divisor /= baseIndex =+        Left+          ( HierarchyLevelPopulationMismatch+              divisor+              (numVertices level)+              baseIndex+          )+    | otherwise = do+        inserted <- insert level point+        if vertexIdIndex (insertionVertex inserted) /= numVertices level+          then+            Left+              ( HierarchyInsertionHandleMismatch+                  (VertexId (fromIntegral (numVertices level)))+                  (insertionVertex inserted)+              )+          else (insertionTriangulation inserted :) <$> updateLevels (safeMultiply divisor branch) rest++  -- With no levels at all the base was empty, so the vertex just appended is+  -- vertex zero. Otherwise vertex zero is the finest level's local vertex+  -- zero, under the same law that makes the descent a multiplication.+  ensureSingletonTop [] = pure <$> singletonLevel point+  ensureSingletonTop levels@(finest : _) =+    case reverse levels of+      top : _+        | numVertices top <= 1 -> Right levels+        | otherwise ->+            (\first -> levels ++ [first])+              <$> singletonLevel (vertexPoint finest (VertexId 0))+      [] -> Right levels++-- | Repair the nested hierarchy from a removal's swap report — the slot+-- compaction freed and the position of the vertex it moved into that slot, or+-- 'Nothing' when the removal took the last vertex and compaction moved+-- nothing — rather than rebuilding because removal renumbers.+--+-- No triangulation is named, for the reason 'updateHierarchyAfterInsertion'+-- gives: the only base position this repair cannot find in its own levels is+-- the relocated vertex's, and that is what the report carries.+--+-- Swap compaction moves exactly one vertex — the former last one, into the slot+-- the removed vertex vacated — so a level's sample sequence changes in at most+-- one place, and which place is decided by the two divisibilities the level's+-- divisor gives the freed slot and the vacated last index:+--+-- * neither is sampled: the level, and every coarser level above it, is+--   untouched, because a divisor that divides neither index is divided by no+--   multiple of itself either;+-- * the vacated index is sampled and the freed slot is not: the level loses its+--   last sample and nothing else;+-- * both are sampled: the level loses its last sample and that sample's point+--   lands in the freed slot's local position — which is the level's own swap+--   removal, mirroring the base's;+-- * the freed slot is sampled and the vacated index is not: the level keeps its+--   population and substitutes the relocated position at an interior local+--   slot. No removal expresses a substitution, so that level is rebuilt — from+--   its own points and the reported one, never from a mesh.+--+-- The last case is the only one that pays a build, and it is the rarest: it+-- needs the freed slot to be sampled and the vacated index not to be.+updateHierarchyAfterRemoval+  :: HierarchyHint+  -> Maybe (VertexId, Point)+  -> Either BuildError (HierarchyHint)+updateHierarchyAfterRemoval hierarchy swap+  | baseCount <= 0 = Left (RemovalEmptyTriangulation (maybe (VertexId 0) fst swap))+  | otherwise = do+      repaired <- repairLevels branch (V.toList (hierarchyLevels hierarchy))+      pure+        hierarchy+          { hierarchyBaseCount = surviving+          , hierarchyLevels = V.fromList (levelsThroughSingleton repaired)+          }+ where+  !branch = hierarchyBranchFactor hierarchy+  !baseCount = hierarchyBaseCount hierarchy+  !surviving = baseCount - 1+  -- The freed slot is the removed vertex's own index, and it is where the+  -- former last vertex now stands. A removal that took the last vertex frees+  -- no slot and reports none, and its removed index is that last index.+  !freedSlot = maybe surviving (vertexIdIndex . fst) swap+  !vacatedIndex = surviving++  -- The nesting law is stated here as an equation for the same reason the+  -- insertion path states it: a repair is the other operation that can break+  -- it. A level the removal reaches must hold exactly the samples the+  -- pre-removal base owed it.+  repairLevels !_ [] = Right []+  repairLevels !divisor levels@(level : rest)+    | not freedSampled && not vacatedSampled = Right levels+    | numVertices level /= population =+        Left+          ( HierarchyLevelPopulationMismatch+              divisor+              (numVertices level)+              baseCount+          )+    | otherwise =+        case swap of+          -- The two divisibilities differ only when the two indices do, so a+          -- level reaching the substitution has a relocation to substitute:+          -- the guard cannot hold while compaction moved nothing.+          Just (_, relocated)+            | freedSampled && not vacatedSampled -> do+                substituted <- substituteSample level (freedSlot `quot` divisor) relocated+                (substituted :) <$> repairLevels (safeMultiply divisor branch) rest+          _ -> do+            shrunk <- removeVertex level (VertexId (fromIntegral localSample))+            (removalTriangulation shrunk :) <$> repairLevels (safeMultiply divisor branch) rest+   where+    !freedSampled = freedSlot `rem` divisor == 0+    !vacatedSampled = vacatedIndex `rem` divisor == 0+    !population = samplePopulation baseCount divisor+    !localSample+      | freedSampled = freedSlot `quot` divisor+      | otherwise = population - 1++  -- A build stops at the first level holding one sample, and removal only+  -- shrinks populations, so the shape a rebuild would answer with is this list+  -- cut after its first singleton.+  levelsThroughSingleton+    :: [Triangulation mode vertex directed undirected face]+    -> [Triangulation mode vertex directed undirected face]+  levelsThroughSingleton [] = []+  levelsThroughSingleton (level : rest)+    | numVertices level <= 0 = []+    | numVertices level <= 1 = [level]+    | otherwise = level : levelsThroughSingleton rest++-- | The coarsest level a growing hierarchy needs: one sample, the base's+-- vertex zero.+singletonLevel+  :: Point+  -> Either BuildError (Triangulation 'Unconstrained (Point) () () ())+singletonLevel origin =+  buildTriangulation <$> delaunay unitElementDefaults (V.singleton origin)++-- | The level a substitution asks for: the same samples in the same local+-- order, one slot carrying the relocated position instead of the one that+-- left. Stated over the level's own points, so no mesh is consulted.+substituteSample+  :: Triangulation 'Unconstrained (Point) () () ()+  -> Int+  -> Point+  -> Either BuildError (Triangulation 'Unconstrained (Point) () () ())+substituteSample level localSlot relocated =+  buildTriangulation+    <$> delaunay+      unitElementDefaults+      ( V.generate+          (numVertices level)+          (\index ->+            if index == localSlot+              then relocated+              else vertexPoint level (VertexId (fromIntegral index))+          )+      )++-- | Rebuild a hierarchy after an operation that may renumber vertices, such as+-- removal. The branch factor remains canonical.+rebuildHierarchyHint+  :: HierarchyHint+  -> Triangulation mode vertex directed undirected face+  -> Either BuildError (HierarchyHint)+rebuildHierarchyHint hierarchy = buildHierarchyHint (hierarchyBranchFactor hierarchy)++-- | Remove many points, each locate starting from the hierarchy's nearest+-- sample instead of the mesh boundary. One session publishes once; the+-- hierarchy is rebuilt against the surviving mesh and returned alongside it.+removeManyWithHierarchy+  :: HierarchyHint+  -> Triangulation mode vertex directed undirected face+  -> V.Vector (Point)+  -> Either+      BuildError+      ( V.Vector (Maybe (RemovalOutcome vertex))+      , Triangulation mode vertex directed undirected face+      , HierarchyHint+      )+removeManyWithHierarchy hierarchy triangulation points = do+  queryPoints <- traverse (validatePoint Nothing) points+  let guesses = fmap hierarchyGuess queryPoints+  (outcomes, surviving, _) <-+    withSession triangulation 0 (removeManyAtNear guesses points)+  repaired <- rebuildHierarchyHint hierarchy surviving+  pure (outcomes, surviving, repaired)+ where+  hierarchyGuess queryPoint =+    case hierarchyHint hierarchy queryPoint of+      Just (VertexHint vertex) -> Just vertex+      _ -> Nothing++safeMultiply :: Int -> Int -> Int+safeMultiply left right+  | left > maxBound `quot` right = maxBound+  | otherwise = left * right++-- | How many samples a divisor takes from a base of this size. Sampling takes+-- index zero and every @divisor@-th index after it; the direct+-- vector generator above states the same ceiling without constructing an+-- intermediate handle list.+samplePopulation :: Int -> Int -> Int+samplePopulation count divisor+  | count <= 0 = 0+  | otherwise = 1 + (count - 1) `quot` divisor++-- The hierarchy is consulted once per query from another package, so its+-- polymorphic entries expose their unfoldings for the same reason the search+-- itself does.+--+-- The two level constructors are listed for a second reason, and the list is+-- not complete without them: they are overloaded and the entries call them, so+-- an entry specialised in the consumer that reaches an unspecialised+-- constructor threads the dictionary right back into the build it was+-- specialised to avoid. Only a stable unfolding is a specialisation candidate+-- across a package boundary; the optimised one GHC publishes on its own is not.+-- These two were 'where' bindings before they were named, and a 'where' binding+-- is specialised with the function that encloses it — so naming them is what+-- put the dictionary in, and this is what takes it back out.
+ src-public/Moonlight/Triangulation/Internal/Minkowski/Convex.hs view
@@ -0,0 +1,304 @@+-- | 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+  , convexPolygonComponent+  , convexPolygonRegion+  , convexPolygonFromRetained+  , admittedConvexLoop+  , structuringElement+  , structuringElementPolygon+  , convexMinkowskiSum+  , convexMinkowskiPolygon+  , convexHullPolygon+  , reflectConvexPolygon+  , convexPolygonCentroid+  , erodeConvexBy+  , addExactPoints+  , subtractExactPoints+  ) where++import Data.Bifunctor (first)+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Set as Set+import Moonlight.Triangulation.Exact+  ( ExactClipDisposition (..)+  , ExactClipReceipt+  , ExactClosedHalfPlane+  , ExactPoint+  , ExactRetainedPolygon+  , ExactVector (..)+  , addExactVectors+  , exactClipRetainedPolygon+  , exactClosedHalfPlaneFromDirectedEdge+  , compareExactVectorAngle+  , exactVectorFromPoints+  , exactOrient2d+  , exactPoint+  , exactPointCoordinates+  , exactRetainedPolygon+  , exactRetainedPolygonPoints+  , translateExactPoint+  )+import Moonlight.Triangulation.Internal.BoundaryCycle+  ( cyclePairs+  , cyclePairsNonEmpty+  , firstNonCounterClockwiseTurn+  , 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 firstNonCounterClockwiseTurn exactOrient2d points of+    Just (index, turn) -> Left (MinkowskiNonConvexTurn index turn)+    Nothing -> Right (ConvexPolygon loop)++convexPolygonPoints :: ConvexPolygon -> NonEmpty ExactPoint+convexPolygonPoints (ConvexPolygon loop) = exactLoopPoints loop++convexPolygonComponent :: ConvexPolygon -> PolygonComponent+convexPolygonComponent (ConvexPolygon loop) = PolygonComponent loop []++convexPolygonRegion :: ConvexPolygon -> PlanarRegion+convexPolygonRegion = PlanarRegion . pure . convexPolygonComponent++-- | Total projection from the retained-line carrier. Strict convexity and+-- simplicity are already invariants of 'ExactRetainedPolygon'; only canonical+-- cycle rotation remains.+convexPolygonFromRetained :: ExactRetainedPolygon -> ConvexPolygon+convexPolygonFromRetained = admittedConvexPolygon . exactRetainedPolygonPoints++admittedConvexPolygon :: NonEmpty ExactPoint -> ConvexPolygon+admittedConvexPolygon = ConvexPolygon . ExactLoop . rotateCycleLeast++admittedConvexLoop :: ExactLoop -> Maybe ConvexPolygon+admittedConvexLoop loop =+  case firstNonCounterClockwiseTurn exactOrient2d (exactLoopPoints loop) of+    Nothing -> Just (ConvexPolygon loop)+    Just _ -> Nothing++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 admittedConvexPolygon 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 (admittedConvexPolygon hullPoints)++reflectConvexPolygon :: ConvexPolygon -> ConvexPolygon+reflectConvexPolygon =+  admittedConvexPolygon+    . fmap negateExactPoint+    . convexPolygonPoints++convexPolygonCentroid+  :: ConvexPolygon+  -> Either MinkowskiError ExactPoint+convexPolygonCentroid polygon = do+  let points = convexPolygonPoints polygon+      count = fromIntegral (NonEmpty.length points)+      (sumX, sumY) =+        List.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. The canonical sorted exact descent+-- retains those source lines; a lower-dimensional residual is represented by+-- the empty polygonal region at this two-dimensional publication boundary.+erodeConvexBy+  :: ConvexPolygon+  -> ConvexPolygon+  -> Either MinkowskiError (Maybe ConvexPolygon, ExactClipReceipt)+erodeConvexBy source kernel = do+  let sourcePoints = convexPolygonPoints source+      kernelPoints = convexPolygonPoints kernel+      firstKernel = NonEmpty.head kernelPoints+      initial =+        fmap+          (`subtractExactPoints` firstKernel)+          sourcePoints+  retained <- first MinkowskiInvalidHalfPlane (exactRetainedPolygon initial)+  halfPlanes <-+    traverse+      (uncurry (strongestHalfPlane kernelPoints))+      (cyclePairs sourcePoints)+  (disposition, clipReceipt) <-+    first MinkowskiClipFailed (exactClipRetainedPolygon retained halfPlanes)+  let eroded =+        case disposition of+          ExactClipFullDimensional clipped ->+            Just (convexPolygonFromRetained clipped)+          ExactClipLowerDimensional _ -> Nothing+          ExactClipEmpty -> Nothing+  pure (eroded, clipReceipt)++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 (List.foldl' hullStep [] ordered))+          upper = dropFinal (reverse (List.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+  -> Either MinkowskiError ExactClosedHalfPlane+strongestHalfPlane kernelPoints from to =+  let direction = exactVectorFromPoints from to+      supportPoint =+        case kernelPoints of+          initial :| remaining ->+            List.foldl'+              (\selected candidate ->+                 if directionPointCross direction candidate+                      < directionPointCross direction selected+                   then candidate+                   else selected)+              initial+              remaining+   in first MinkowskiInvalidHalfPlane+        ( exactClosedHalfPlaneFromDirectedEdge+            (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++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)
+ src-public/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+  ( ExactClipError+  , ExactHalfPlaneError+  , ExactPoint+  )+import Moonlight.Triangulation.Internal.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+  | MinkowskiInvalidHalfPlane !ExactHalfPlaneError+  | MinkowskiClipFailed !ExactClipError+  | MinkowskiNonConvexTurn !Int !Ordering+  | MinkowskiOriginOutside !RegionPointLocation+  | MinkowskiExactArithmetic !ExactArithmeticError+  | 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-public/Moonlight/Triangulation/Internal/PowerDiagram/Edit.hs view
@@ -0,0 +1,1376 @@+-- | Pure topology-changing regular edits by exact conflict-cavity descent and gluing.+module Moonlight.Triangulation.Internal.PowerDiagram.Edit where++import Control.Monad (when)+import Data.Bifunctor (first)+import qualified Data.Foldable as Foldable+import qualified Data.List as List+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Maybe (isJust)+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Vector as Vector+import Moonlight.Triangulation.Exact+  ( exactOrient2d+  , exactPoint+  )+import Moonlight.Triangulation.Internal.BoundaryCycle (orderedPair)+import Moonlight.Triangulation.Internal.ExactRational (ExactRational)+import Moonlight.Triangulation.Internal.PowerDiagram.Generator+import Moonlight.Triangulation.Internal.PowerDiagram.Hull (regularGeneratorTopology)+import Moonlight.Triangulation.Internal.PowerDiagram.Locality+import Moonlight.Triangulation.Internal.PowerDiagram.Model+import Moonlight.Triangulation.Internal.PowerDiagram.Section++-- | Insert one stable-labelled site. Repeating the identical site is+-- idempotent; reusing its label for different geometry is a typed conflict.+insertRegularSite+  :: Ord label+  => PowerSite label+  -> RegularTriangulation label+  -> Either+      (RegularEditError label)+      (RegularEditResult label)+insertRegularSite site triangulation =+  let label = powerSiteLabel site+   in case Map.lookup label (storedRegularSites triangulation) of+        Nothing ->+          withRegularEditFallback+            triangulation+            (Set.singleton label)+            ( normalizeRegularEdit+                triangulation+                (Map.insert label site (storedRegularSites triangulation))+                (Set.singleton label)+            )+            (insertRegularSiteLocally site triangulation)+        Just resident+          | resident == site ->+              Right (unchangedRegularEdit triangulation)+          | otherwise -> Left (RegularEditSiteConflict label resident site)++-- | Remove one labelled site. Absence is an idempotent successful result.+removeRegularSite+  :: Ord label+  => label+  -> RegularTriangulation label+  -> Either+      (RegularEditError label)+      (RegularEditResult label)+removeRegularSite label triangulation =+  case Map.lookup label (storedRegularSites triangulation) of+    Nothing ->+      Right (unchangedRegularEdit triangulation)+    Just _ ->+      case removeTopologyPreservingSite label triangulation of+        Just (edited, transitions) ->+          Right+            ( RegularEditResult+                edited+                (Set.singleton label)+                transitions+            )+        Nothing ->+          withRegularEditFallback+            triangulation+            (Set.singleton label)+            ( normalizeRegularEdit+                triangulation+                (Map.delete label (storedRegularSites triangulation))+                (Set.singleton label)+            )+            (removeRegularSiteLocally label triangulation)++-- | Replace many weights in one normalization. Every label must already+-- belong to the triangulation; an empty or unchanged patch is idempotent.+reweightRegularSites+  :: Ord label+  => Map label PowerWeight+  -> RegularTriangulation label+  -> Either+      (RegularEditError label)+      (RegularEditResult label)+reweightRegularSites requested triangulation =+  case NonEmpty.nonEmpty unknownLabels of+    Just unknown -> Left (RegularEditUnknownSites unknown)+    Nothing+      | Map.null changedSites ->+          Right (unchangedRegularEdit triangulation)+      | otherwise ->+          case reweightTopologyPreservingSites changedLabels changedSites reweightedSites triangulation of+            Just (edited, transitions) ->+              Right+                ( RegularEditResult+                    edited+                    changedLabels+                    transitions+                )+            Nothing ->+              case commonRegularWeightShift requested sites of+                Just shift ->+                  Right+                    ( translateRegularWeights+                        shift+                        reweightedSites+                        changedLabels+                        triangulation+                    )+                Nothing ->+                  case Map.elems changedSites of+                    [revised] ->+                      withRegularEditFallback+                        triangulation+                        changedLabels+                        normalizeGlobally+                        (reweightRegularSiteLocally revised triangulation)+                    _ -> normalizeGlobally+ where+  sites = storedRegularSites triangulation+  unknownLabels = Map.keys (Map.difference requested sites)+  changedSites =+    Map.mapMaybeWithKey+      (\label weight ->+          case Map.lookup label sites of+            Just site+              | powerSiteWeight site /= weight ->+                  Just site{powerSiteWeight = weight}+            _ -> Nothing+      )+      requested+  reweightedSites = Map.union changedSites sites+  changedLabels = Map.keysSet changedSites+  normalizeGlobally =+    normalizeRegularEdit triangulation reweightedSites changedLabels++withRegularEditFallback+  :: Ord label+  => RegularTriangulation label+  -> Set label+  -> Either (RegularEditError label) (RegularEditResult label)+  -> Either obstruction (RegularTriangulation label, Set label)+  -> Either (RegularEditError label) (RegularEditResult label)+withRegularEditFallback before changed fallback =+  either (const fallback) (Right . publishLocalRegularEdit before changed)+{-# INLINE withRegularEditFallback #-}++publishLocalRegularEdit+  :: Ord label+  => RegularTriangulation label+  -> Set label+  -> (RegularTriangulation label, Set label)+  -> RegularEditResult label+publishLocalRegularEdit before changed (edited, transitionSupport) =+  RegularEditResult+    edited+    changed+    ( dispositionTransitionsOn+        transitionSupport+        (regularDispositionSection before)+        (regularDispositionSection edited)+    )+{-# INLINE publishLocalRegularEdit #-}++insertRegularSiteLocally+  :: Ord label+  => PowerSite label+  -> RegularTriangulation label+  -> Either+      (LocalRegularEditObstruction label)+      (RegularTriangulation label, Set label)+insertRegularSiteLocally site triangulation = do+  section <-+    maybe (Left LocalRegularSectionUnavailable) Right+      (storedRegularSection triangulation)+  let (generator, _) = prepareExactPowerGenerator site+      slope = exactGeneratorSlope generator+  case Map.lookup slope (sectionSlopeRepresentatives section) of+    Just representative ->+      insertCoincidentRegularSite site generator representative section triangulation+    Nothing ->+      insertDistinctRegularSite site generator section triangulation++insertCoincidentRegularSite+  :: Ord label+  => PowerSite label+  -> ExactPowerGenerator label+  -> label+  -> RegularSection label+  -> RegularTriangulation label+  -> Either+      (LocalRegularEditObstruction label)+      (RegularTriangulation label, Set label)+insertCoincidentRegularSite site generator representativeLabel section triangulation = do+  representative <-+    requireGeneratorFromMap (sectionGenerators section) representativeLabel+  let label = powerSiteLabel site+  case+    compareCoincidentPriority+      (exactPowerGeneratorConstant generator, label)+      (exactPowerGeneratorConstant representative, representativeLabel) of+    LT ->+      let coincident = classifyCoincidentGenerator representative generator+          disposition = coincidentRegularDisposition coincident+          editedSection =+            section+              { sectionCoincidentDispositions =+                  Map.insert label coincident (sectionCoincidentDispositions section)+              , sectionRegularDispositions =+                  Map.insert label disposition (sectionRegularDispositions section)+              , sectionRegularStars =+                  Map.insert label emptyRegularSiteStar (sectionRegularStars section)+              }+       in Right+            ( replaceRegularSiteSection+                (Map.insert label site (storedRegularSites triangulation))+                editedSection+                triangulation+            , Set.singleton label+            )+    _ -> Left (LocalRegularSlopeCoincidence representativeLabel)++insertDistinctRegularSite+  :: Ord label+  => PowerSite label+  -> ExactPowerGenerator label+  -> RegularSection label+  -> RegularTriangulation label+  -> Either+      (LocalRegularEditObstruction label)+      (RegularTriangulation label, Set label)+insertDistinctRegularSite site generator section triangulation = do+  locality <-+    maybe (Left LocalRegularLocalityUnavailable) Right+      (sectionRegularLocality section)+  location <-+    maybe (Left LocalRegularSlopeLocationFailed) Right+      (locateRegularSlope (localityFaceSeed locality) section generator)+  case location of+    RegularSlopeOutside edgeKey -> Left (LocalRegularSlopeOutside edgeKey)+    RegularSlopeInside faceKey -> do+      volume <- regularFaceVolume section faceKey generator+      case compare volume 0 of+        LT -> insertHiddenRegularSite site generator faceKey locality section triangulation+        EQ -> Left (LocalRegularDegenerateFace faceKey)+        GT -> insertVisibleRegularSite site generator faceKey locality section triangulation++insertHiddenRegularSite+  :: Ord label+  => PowerSite label+  -> ExactPowerGenerator label+  -> RegularFaceKey label+  -> RegularLocality label+  -> RegularSection label+  -> RegularTriangulation label+  -> Either+      (LocalRegularEditObstruction label)+      (RegularTriangulation label, Set label)+insertHiddenRegularSite site generator supportFace locality section triangulation =+  let label = powerSiteLabel site+      receipt = sectionRegularReceipt section+      editedLocality = attachRegularHidden label supportFace locality+      editedSection =+        section+          { sectionGenerators = Map.insert label generator (sectionGenerators section)+          , sectionSlopeRepresentatives =+              Map.insert (exactGeneratorSlope generator) label (sectionSlopeRepresentatives section)+          , sectionRegularDispositions =+              Map.insert label RegularSiteHidden (sectionRegularDispositions section)+          , sectionRegularStars =+              Map.insert label emptyRegularSiteStar (sectionRegularStars section)+          , sectionRegularReceipt =+              receipt+                { generatorRegularInputSites = generatorRegularInputSites receipt + 1+                , generatorRegularHiddenSites = generatorRegularHiddenSites receipt + 1+                }+          , sectionRegularLocality = Just editedLocality+          }+   in Right+        ( replaceRegularSiteSection+            (Map.insert label site (storedRegularSites triangulation))+            editedSection+            triangulation+        , Set.singleton label+        )++insertVisibleRegularSite+  :: Ord label+  => PowerSite label+  -> ExactPowerGenerator label+  -> RegularFaceKey label+  -> RegularLocality label+  -> RegularSection label+  -> RegularTriangulation label+  -> Either+      (LocalRegularEditObstruction label)+      (RegularTriangulation label, Set label)+insertVisibleRegularSite site generator seedFace locality section triangulation = do+  conflictFaces <- regularConflictCavity section generator seedFace+  horizon <- regularConflictHorizon section conflictFaces+  when (Map.null horizon) (Left LocalRegularEmptyHorizon)+  newFaces <- traverse (regularHorizonFace section generator) (Map.elems horizon)+  let label = powerSiteLabel site+      generators = Map.insert label generator (sectionGenerators section)+  facePatch <-+    applyRegularFacePatch+      generators+      conflictFaces+      newFaces+      section+  certifyRegularFacePatch generators facePatch+  let changedTopologyLabels = Set.insert label (patchedRegularLabels facePatch)+      provisionalDispositions =+        Set.foldl'+          (publishPatchedRegularDisposition (patchedRegularStars facePatch))+          (Map.insert label RegularSiteVisible (sectionRegularDispositions section))+          changedTopologyLabels+      newlyHidden =+        Set.filter+          (becameRegularHidden (sectionRegularDispositions section) provisionalDispositions)+          changedTopologyLabels+      hiddenOnConflict =+        Set.unions+          [ Map.findWithDefault Set.empty faceKey (localitySupportHidden locality)+          | faceKey <- Set.toAscList conflictFaces+          ]+      hiddenToAttach = Set.union newlyHidden hiddenOnConflict+      receipt = sectionRegularReceipt section+      provisionalSection =+        section+          { sectionGenerators = generators+          , sectionSlopeRepresentatives =+              Map.insert (exactGeneratorSlope generator) label (sectionSlopeRepresentatives section)+          , sectionRegularDispositions = provisionalDispositions+          , sectionRegularFaces = patchedRegularFaces facePatch+          , sectionRegularEdges = patchedRegularEdges facePatch+          , sectionRegularStars = patchedRegularStars facePatch+          , sectionRegularReceipt =+              receipt+                { generatorRegularInputSites = generatorRegularInputSites receipt + 1+                , generatorRegularVisibleSites =+                    generatorRegularVisibleSites receipt + 1 - Set.size newlyHidden+                , generatorRegularHiddenSites =+                    generatorRegularHiddenSites receipt + Set.size newlyHidden+                , generatorRegularFaceCount = Map.size (patchedRegularFaces facePatch)+                , generatorRegularEdgeCount = Map.size (patchedRegularEdges facePatch)+                }+          , sectionRegularLocality = Nothing+          }+  editedLocality <-+    patchRegularLocality locality conflictFaces hiddenToAttach provisionalSection+  let editedSection = provisionalSection{sectionRegularLocality = Just editedLocality}+  pure+    ( replaceRegularSiteSection+        (Map.insert label site (storedRegularSites triangulation))+        editedSection+        triangulation+    , Set.insert label newlyHidden+    )+++regularFaceVolume+  :: Ord label+  => RegularSection label+  -> RegularFaceKey label+  -> ExactPowerGenerator label+  -> Either (LocalRegularEditObstruction label) ExactRational+regularFaceVolume section faceKey candidate = do+  face <- requireFaceFromMap (sectionRegularFaces section) faceKey+  (firstGenerator, secondGenerator, thirdGenerator) <-+    regularFaceGenerators (sectionGenerators section) face+  pure+    ( exactGeneratorLiftedVolume+        firstGenerator+        secondGenerator+        thirdGenerator+        candidate+    )++regularConflictCavity+  :: Ord label+  => RegularSection label+  -> ExactPowerGenerator label+  -> RegularFaceKey label+  -> Either+      (LocalRegularEditObstruction label)+      (Set (RegularFaceKey label))+regularConflictCavity section candidate seed =+  let initial =+        RegularConflictDescent+          { conflictPendingFaces = Set.singleton seed+          , conflictVisitedFaces = Set.empty+          , conflictVisibleFaces = Set.empty+          , conflictObstruction = Nothing+          }+      descended =+        Map.foldl'+          (\current _ -> advanceRegularConflict section candidate current)+          initial+          (sectionRegularFaces section)+   in case conflictObstruction descended of+        Just obstruction -> Left obstruction+        Nothing+          | not (Set.null (conflictPendingFaces descended)) ->+              Left LocalRegularSlopeLocationFailed+          | Set.null (conflictVisibleFaces descended) ->+              Left (LocalRegularDegenerateFace seed)+          | otherwise -> Right (conflictVisibleFaces descended)++advanceRegularConflict+  :: Ord label+  => RegularSection label+  -> ExactPowerGenerator label+  -> RegularConflictDescent label+  -> RegularConflictDescent label+advanceRegularConflict _ _ descent+  | Set.null (conflictPendingFaces descent)+      || isJust (conflictObstruction descent) = descent+advanceRegularConflict section candidate descent =+  case Set.minView (conflictPendingFaces descent) of+    Nothing -> descent+    Just (faceKey, remaining) ->+      case regularFaceVolume section faceKey candidate of+        Left obstruction ->+          descent+            { conflictPendingFaces = remaining+            , conflictObstruction = Just obstruction+            }+        Right volume ->+          let visited = Set.insert faceKey (conflictVisitedFaces descent)+           in case compare volume 0 of+                LT ->+                  descent+                    { conflictPendingFaces = remaining+                    , conflictVisitedFaces = visited+                    }+                EQ ->+                  descent+                    { conflictPendingFaces = remaining+                    , conflictVisitedFaces = visited+                    , conflictObstruction = Just (LocalRegularDegenerateFace faceKey)+                    }+                GT ->+                  case regularFaceNeighbours section faceKey of+                    Left obstruction ->+                      descent+                        { conflictPendingFaces = remaining+                        , conflictVisitedFaces = visited+                        , conflictObstruction = Just obstruction+                        }+                    Right neighbours ->+                      descent+                        { conflictPendingFaces =+                            Set.union remaining (Set.difference neighbours visited)+                        , conflictVisitedFaces = visited+                        , conflictVisibleFaces =+                            Set.insert faceKey (conflictVisibleFaces descent)+                        }+++regularConflictHorizon+  :: Ord label+  => RegularSection label+  -> Set (RegularFaceKey label)+  -> Either+      (LocalRegularEditObstruction label)+      (Map (RegularEdgeKey label) (label, label))+regularConflictHorizon section conflictFaces = do+  boundarySections <-+    traverse+      (regularConflictFaceHorizon section conflictFaces)+      (Set.toAscList conflictFaces)+  pure (Map.unions boundarySections)++regularConflictFaceHorizon+  :: Ord label+  => RegularSection label+  -> Set (RegularFaceKey label)+  -> RegularFaceKey label+  -> Either+      (LocalRegularEditObstruction label)+      (Map (RegularEdgeKey label) (label, label))+regularConflictFaceHorizon section conflictFaces faceKey = do+  face <- requireFaceFromMap (sectionRegularFaces section) faceKey+  associations <-+    traverse+      (classifyConflictEdge section conflictFaces)+      (regularFaceDirectedEdgeKeys face)+  pure (Map.fromList (concat associations))++classifyConflictEdge+  :: Ord label+  => RegularSection label+  -> Set (RegularFaceKey label)+  -> (label, label)+  -> Either+      (LocalRegularEditObstruction label)+      [(RegularEdgeKey label, (label, label))]+classifyConflictEdge section conflictFaces directed@(fromLabel, toLabel) = do+  let edgeKey = orderedPair fromLabel toLabel+  incident <- requireRegularEdgeIncidence section edgeKey+  if Set.size incident > 2+    then Left (LocalRegularNonManifoldEdge edgeKey (Set.size incident))+    else+      if Set.size (Set.intersection incident conflictFaces) == 1+        then Right [(edgeKey, directed)]+        else Right []++regularHorizonFace+  :: Ord label+  => RegularSection label+  -> ExactPowerGenerator label+  -> (label, label)+  -> Either (LocalRegularEditObstruction label) (RegularFace label)+regularHorizonFace section candidate (fromLabel, toLabel) = do+  fromGenerator <- requireGeneratorFromMap (sectionGenerators section) fromLabel+  toGenerator <- requireGeneratorFromMap (sectionGenerators section) toLabel+  let candidateLabel = exactPowerGeneratorLabel candidate+      faceKey = sortedRegularFaceLabels fromLabel toLabel candidateLabel+      fromPoint = uncurry exactPoint (exactGeneratorSlope fromGenerator)+      toPoint = uncurry exactPoint (exactGeneratorSlope toGenerator)+      candidatePoint = uncurry exactPoint (exactGeneratorSlope candidate)+  case exactOrient2d fromPoint toPoint candidatePoint of+    GT -> do+      dual <-+        first LocalRegularTopologyObstruction+          (exactGeneratorFaceDual fromGenerator toGenerator candidate)+      pure (canonicalRegularFace fromLabel toLabel candidateLabel dual)+    _ -> Left (LocalRegularDegenerateFace faceKey)++applyRegularFacePatch+  :: Ord label+  => Map label (ExactPowerGenerator label)+  -> Set (RegularFaceKey label)+  -> [RegularFace label]+  -> RegularSection label+  -> Either (LocalRegularEditObstruction label) (RegularFacePatch label)+applyRegularFacePatch generators removedFaceKeys newFaces section = do+  removedFaces <-+    traverse+      (requireFaceFromMap (sectionRegularFaces section))+      (Set.toAscList removedFaceKeys)+  let newFaceSection =+        Map.fromList [(regularFaceKey face, face) | face <- newFaces]+      faces =+        Map.union newFaceSection+          (Map.withoutKeys (sectionRegularFaces section) removedFaceKeys)+      touchedEdges =+        Set.unions+          [ Set.unions (fmap (Set.fromList . regularFaceCanonicalEdgeKeys) removedFaces)+          , Set.unions (fmap (Set.fromList . regularFaceCanonicalEdgeKeys) newFaces)+          ]+      newIncidence =+        List.foldl'+          (Map.unionWith Set.union)+          Map.empty+          (fmap regularFaceEdgeIncidence newFaces)+      affectedLabels =+        Set.unions+          [ Set.unions (fmap regularFaceLabelSet removedFaces)+          , Set.unions (fmap regularFaceLabelSet newFaces)+          ]+  edges <-+    Foldable.foldlM+      (patchRegularEdge generators faces removedFaceKeys newIncidence)+      (sectionRegularEdges section)+      touchedEdges+  let stars =+        patchRegularStars+          affectedLabels+          removedFaceKeys+          newFaceSection+          touchedEdges+          edges+          section+  pure+    RegularFacePatch+      { patchedRegularFaces = faces+      , patchedRegularEdges = edges+      , patchedRegularStars = stars+      , patchedRegularLabels = affectedLabels+      , patchedRegularTouchedEdges = touchedEdges+      }++patchRegularEdge+  :: Ord label+  => Map label (ExactPowerGenerator label)+  -> Map (RegularFaceKey label) (RegularFace label)+  -> Set (RegularFaceKey label)+  -> Map (RegularEdgeKey label) (Set (RegularFaceKey label))+  -> Map (RegularEdgeKey label) (RegularEdgeSection label)+  -> RegularEdgeKey label+  -> Either+      (LocalRegularEditObstruction label)+      (Map (RegularEdgeKey label) (RegularEdgeSection label))+patchRegularEdge generators faces removedFaceKeys newIncidence edges edgeKey =+  let oldIncidence =+        maybe Set.empty sectionRegularEdgeFaces (Map.lookup edgeKey edges)+      incidence =+        Set.union+          (Set.difference oldIncidence removedFaceKeys)+          (Map.findWithDefault Set.empty edgeKey newIncidence)+   in if Set.null incidence+        then Right (Map.delete edgeKey edges)+        else do+          edgeSection <- publishRegularEdgeSection generators faces edgeKey incidence+          pure (Map.insert edgeKey edgeSection edges)++publishRegularEdgeSection+  :: Ord label+  => Map label (ExactPowerGenerator label)+  -> Map (RegularFaceKey label) (RegularFace label)+  -> RegularEdgeKey label+  -> Set (RegularFaceKey label)+  -> Either (LocalRegularEditObstruction label) (RegularEdgeSection label)+publishRegularEdgeSection generators faces edgeKey@(firstLabel, secondLabel) incidence =+  case Set.toAscList incidence of+    [faceKey] -> do+      face <- requireFaceFromMap faces faceKey+      (fromLabel, toLabel, oppositeLabel) <-+        requireFaceEdgeWitness edgeKey face+      fromGenerator <- requireGeneratorFromMap generators fromLabel+      toGenerator <- requireGeneratorFromMap generators toLabel+      oppositeGenerator <- requireGeneratorFromMap generators oppositeLabel+      ray <-+        first LocalRegularTopologyObstruction+          ( exactGeneratorBoundaryDualRay+              (regularFaceDualPoint face)+              fromGenerator+              toGenerator+              oppositeGenerator+          )+      pure+        ( RegularEdgeSection+            (RegularEdge firstLabel secondLabel (UnboundedPowerDual ray))+            incidence+        )+    [firstFaceKey, secondFaceKey] -> do+      firstFace <- requireFaceFromMap faces firstFaceKey+      secondFace <- requireFaceFromMap faces secondFaceKey+      let firstDual = regularFaceDualPoint firstFace+          secondDual = regularFaceDualPoint secondFace+      dual <-+        fmap publishGeneratorDualGeometry+          ( first LocalRegularTopologyObstruction+              ( exactGeneratorDualBetween+                  firstLabel+                  secondLabel+                  firstDual+                  secondDual+              )+          )+      pure+        ( RegularEdgeSection+            (RegularEdge firstLabel secondLabel dual)+            incidence+        )+    incidentFaces ->+      Left (LocalRegularNonManifoldEdge edgeKey (length incidentFaces))++patchRegularStars+  :: Ord label+  => Set label+  -> Set (RegularFaceKey label)+  -> Map (RegularFaceKey label) (RegularFace label)+  -> Set (RegularEdgeKey label)+  -> Map (RegularEdgeKey label) (RegularEdgeSection label)+  -> RegularSection label+  -> Map label (RegularSiteStar label)+patchRegularStars affectedLabels removedFaceKeys newFaceSection touchedEdges edges section =+  Set.foldl' patchStar (sectionRegularStars section) affectedLabels+ where+  affectedSupport = Map.fromSet (const ()) affectedLabels+  touchedStars =+    regularSiteStars+      affectedSupport+      Map.empty+      ( Map.restrictKeys+          (Map.union edges (sectionRegularEdges section))+          touchedEdges+      )+  addedStars =+    regularSiteStars+      affectedSupport+      newFaceSection+      (Map.restrictKeys edges touchedEdges)+  patchStar stars label =+    let oldStar = Map.findWithDefault emptyRegularSiteStar label stars+        touchedStar = Map.findWithDefault emptyRegularSiteStar label touchedStars+        addedStar = Map.findWithDefault emptyRegularSiteStar label addedStars+        incidentFaces =+          Set.union+            (Set.difference (sectionIncidentFaces oldStar) removedFaceKeys)+            (sectionIncidentFaces addedStar)+        retainedNeighbours =+          Set.difference+            (sectionSiteNeighbours oldStar)+            (sectionSiteNeighbours touchedStar)+     in Map.insert+          label+          ( RegularSiteStar+              incidentFaces+              (Set.union retainedNeighbours (sectionSiteNeighbours addedStar))+          )+          stars++certifyRegularFacePatch+  :: Ord label+  => Map label (ExactPowerGenerator label)+  -> RegularFacePatch label+  -> Either (LocalRegularEditObstruction label) ()+certifyRegularFacePatch generators patch =+  Foldable.traverse_+    (\edgeKey ->+       case Map.lookup edgeKey (patchedRegularEdges patch) of+         Nothing -> Right ()+         Just edgeSection ->+           certifyRegularEdgeConvexity+             generators+             (patchedRegularFaces patch)+             (edgeKey, edgeSection))+    (patchedRegularTouchedEdges patch)++certifyRegularEdgeConvexity+  :: Ord label+  => Map label (ExactPowerGenerator label)+  -> Map (RegularFaceKey label) (RegularFace label)+  -> (RegularEdgeKey label, RegularEdgeSection label)+  -> Either (LocalRegularEditObstruction label) ()+certifyRegularEdgeConvexity generators faces (edgeKey, edgeSection) =+  case Set.toAscList (sectionRegularEdgeFaces edgeSection) of+    [_] -> Right ()+    [firstFaceKey, secondFaceKey] -> do+      firstFace <- requireFaceFromMap faces firstFaceKey+      secondFace <- requireFaceFromMap faces secondFaceKey+      (_, _, secondOpposite) <- requireFaceEdgeWitness edgeKey secondFace+      secondOppositeGenerator <- requireGeneratorFromMap generators secondOpposite+      (firstGenerator, secondGenerator, thirdGenerator) <-+        regularFaceGenerators generators firstFace+      if exactGeneratorLiftedVolume+          firstGenerator+          secondGenerator+          thirdGenerator+          secondOppositeGenerator+          < 0+        then Right ()+        else Left (LocalRegularNonConvexEdge edgeKey)+    incident -> Left (LocalRegularNonManifoldEdge edgeKey (length incident))++publishPatchedRegularDisposition+  :: Ord label+  => Map label (RegularSiteStar label)+  -> Map label (RegularSiteDisposition label)+  -> label+  -> Map label (RegularSiteDisposition label)+publishPatchedRegularDisposition stars dispositions label =+  case Map.lookup label dispositions of+    Just RegularSiteVisible+      | maybe True (Set.null . sectionIncidentFaces) (Map.lookup label stars) ->+          Map.insert label RegularSiteHidden dispositions+    _ -> dispositions++becameRegularHidden+  :: Ord label+  => Map label (RegularSiteDisposition label)+  -> Map label (RegularSiteDisposition label)+  -> label+  -> Bool+becameRegularHidden before after label =+  Map.lookup label before == Just RegularSiteVisible+    && Map.lookup label after == Just RegularSiteHidden++requireRegularEdgeIncidence+  :: Ord label+  => RegularSection label+  -> RegularEdgeKey label+  -> Either+      (LocalRegularEditObstruction label)+      (Set (RegularFaceKey label))+requireRegularEdgeIncidence section edgeKey =+  maybe+    (Left (LocalRegularNonManifoldEdge edgeKey 0))+    (Right . sectionRegularEdgeFaces)+    (Map.lookup edgeKey (sectionRegularEdges section))++regularFaceGenerators+  :: Ord label+  => Map label (ExactPowerGenerator label)+  -> RegularFace label+  -> Either+      (LocalRegularEditObstruction label)+      ( ExactPowerGenerator label+      , ExactPowerGenerator label+      , ExactPowerGenerator label+      )+regularFaceGenerators generators face = do+  let (firstLabel, secondLabel, thirdLabel) = regularFaceLabels face+  (,,)+    <$> requireGeneratorFromMap generators firstLabel+    <*> requireGeneratorFromMap generators secondLabel+    <*> requireGeneratorFromMap generators thirdLabel++removeRegularSiteLocally+  :: Ord label+  => label+  -> RegularTriangulation label+  -> Either+      (LocalRegularEditObstruction label)+      (RegularTriangulation label, Set label)+removeRegularSiteLocally label triangulation = do+  section <-+    maybe (Left LocalRegularSectionUnavailable) Right+      (storedRegularSection triangulation)+  locality <-+    maybe (Left LocalRegularLocalityUnavailable) Right+      (sectionRegularLocality section)+  disposition <-+    maybe (Left (LocalRegularGeneratorMissing label)) Right+      (Map.lookup label (sectionRegularDispositions section))+  when+    (disposition /= RegularSiteVisible || hasCoincidentAliases label section)+    (Left (LocalRegularBoundaryRemoval label))+  star <-+    maybe (Left (LocalRegularGeneratorMissing label)) Right+      (Map.lookup label (sectionRegularStars section))+  let removedFaces = sectionIncidentFaces star+  when (Set.null removedFaces) (Left (LocalRegularBoundaryRemoval label))+  Foldable.traverse_+    (requireInteriorRemovalEdge section label)+    (sectionSiteNeighbours star)+  horizon <- regularConflictHorizon section removedFaces+  when (Map.null horizon) (Left LocalRegularEmptyHorizon)+  let hiddenCandidates =+        Set.unions+          [ Map.findWithDefault Set.empty faceKey (localitySupportHidden locality)+          | faceKey <- Set.toAscList removedFaces+          ]+      horizonLabels =+        Set.fromList+          [ endpoint+          | (firstLabel, secondLabel) <- Map.keys horizon+          , endpoint <- [firstLabel, secondLabel]+          ]+      candidateLabels = Set.union horizonLabels hiddenCandidates+      generators = Map.delete label (sectionGenerators section)+  candidateGenerators <-+    traverse+      (requireGeneratorFromMap generators)+      (Set.toAscList candidateLabels)+  nonEmptyCandidates <-+    maybe (Left LocalRegularCandidateSectionEmpty) Right+      (NonEmpty.nonEmpty candidateGenerators)+  candidateTopology <-+    first LocalRegularTopologyObstruction+      (regularGeneratorTopology (DistinctSlopeGenerators nonEmptyCandidates))+  when+    ( any+        ((== RegularGeneratorLowerDimensional) . snd)+        (NonEmpty.toList (generatorRegularDispositions candidateTopology))+    )+    (Left LocalRegularCavityBoundaryMismatch)+  removedFaceValues <-+    traverse+      (requireFaceFromMap (sectionRegularFaces section))+      (Set.toAscList removedFaces)+  let proposedFaces = fmap publishGeneratorFace (generatorRegularFaces candidateTopology)+      newFaces =+        filter+          (regularFaceCentroidInside generators removedFaceValues)+          proposedFaces+      proposedBoundary = regularFaceSectionBoundary newFaces+  when+    (proposedBoundary /= Map.keysSet horizon)+    (Left LocalRegularCavityBoundaryMismatch)+  facePatch <- applyRegularFacePatch generators removedFaces newFaces section+  certifyRegularFacePatch generators facePatch+  let candidateDispositions =+        Set.foldl'+          (publishRemovalCandidateDisposition (patchedRegularStars facePatch))+          (Map.delete label (sectionRegularDispositions section))+          candidateLabels+      exposed =+        Set.filter+          (becameRegularVisible (sectionRegularDispositions section) candidateDispositions)+          candidateLabels+      stillHidden =+        Set.filter+          (\candidate -> Map.lookup candidate candidateDispositions == Just RegularSiteHidden)+          hiddenCandidates+      receipt = sectionRegularReceipt section+      provisionalSection =+        section+          { sectionGenerators = generators+          , sectionSlopeRepresentatives =+              Map.filter (/= label) (sectionSlopeRepresentatives section)+          , sectionRegularDispositions = candidateDispositions+          , sectionRegularFaces = patchedRegularFaces facePatch+          , sectionRegularEdges = patchedRegularEdges facePatch+          , sectionRegularStars = Map.delete label (patchedRegularStars facePatch)+          , sectionRegularReceipt =+              receipt+                { generatorRegularInputSites = generatorRegularInputSites receipt - 1+                , generatorRegularVisibleSites =+                    generatorRegularVisibleSites receipt - 1 + Set.size exposed+                , generatorRegularHiddenSites =+                    generatorRegularHiddenSites receipt - Set.size exposed+                , generatorRegularFaceCount = Map.size (patchedRegularFaces facePatch)+                , generatorRegularEdgeCount = Map.size (patchedRegularEdges facePatch)+                }+          , sectionRegularLocality = Nothing+          }+  editedLocality <-+    patchRegularLocality locality removedFaces stillHidden provisionalSection+  let editedSection = provisionalSection{sectionRegularLocality = Just editedLocality}+  pure+    ( replaceRegularSiteSection+        (Map.delete label (storedRegularSites triangulation))+        editedSection+        triangulation+    , Set.insert label exposed+    )++requireInteriorRemovalEdge+  :: Ord label+  => RegularSection label+  -> label+  -> label+  -> Either (LocalRegularEditObstruction label) ()+requireInteriorRemovalEdge section label neighbour = do+  let edgeKey = orderedPair label neighbour+  incidence <- requireRegularEdgeIncidence section edgeKey+  if Set.size incidence == 2+    then Right ()+    else Left (LocalRegularBoundaryRemoval label)++regularFaceCentroidInside+  :: Ord label+  => Map label (ExactPowerGenerator label)+  -> [RegularFace label]+  -> RegularFace label+  -> Bool+regularFaceCentroidInside generators domainFaces candidate =+  case regularFaceSlopeSum generators candidate of+    Left _ -> False+    Right slopeSum -> any (regularSlopeSumInsideFace generators slopeSum) domainFaces++regularFaceSlopeSum+  :: Ord label+  => Map label (ExactPowerGenerator label)+  -> RegularFace label+  -> Either+      (LocalRegularEditObstruction label)+      (ExactRational, ExactRational)+regularFaceSlopeSum generators face = do+  (firstGenerator, secondGenerator, thirdGenerator) <-+    regularFaceGenerators generators face+  let (firstX, firstY) = exactGeneratorSlope firstGenerator+      (secondX, secondY) = exactGeneratorSlope secondGenerator+      (thirdX, thirdY) = exactGeneratorSlope thirdGenerator+  pure (firstX + secondX + thirdX, firstY + secondY + thirdY)++regularSlopeSumInsideFace+  :: Ord label+  => Map label (ExactPowerGenerator label)+  -> (ExactRational, ExactRational)+  -> RegularFace label+  -> Bool+regularSlopeSumInsideFace generators slopeSum =+  not+    . any (generatorEdgeExcludesScaled 3 slopeSum generators)+    . regularFaceDirectedEdgeKeys++regularFaceSectionBoundary+  :: Ord label+  => [RegularFace label]+  -> Set (RegularEdgeKey label)+regularFaceSectionBoundary =+  Map.keysSet+    . Map.filter ((== 1) . Set.size)+    . List.foldl'+        (Map.unionWith Set.union)+        Map.empty+    . fmap regularFaceEdgeIncidence++publishRemovalCandidateDisposition+  :: Ord label+  => Map label (RegularSiteStar label)+  -> Map label (RegularSiteDisposition label)+  -> label+  -> Map label (RegularSiteDisposition label)+publishRemovalCandidateDisposition stars dispositions label =+  Map.insert+    label+    ( if maybe True (Set.null . sectionIncidentFaces) (Map.lookup label stars)+        then RegularSiteHidden+        else RegularSiteVisible+    )+    dispositions++becameRegularVisible+  :: Ord label+  => Map label (RegularSiteDisposition label)+  -> Map label (RegularSiteDisposition label)+  -> label+  -> Bool+becameRegularVisible before after label =+  Map.lookup label before == Just RegularSiteHidden+    && Map.lookup label after == Just RegularSiteVisible++reweightRegularSiteLocally+  :: Ord label+  => PowerSite label+  -> RegularTriangulation label+  -> Either+      (LocalRegularEditObstruction label)+      (RegularTriangulation label, Set label)+reweightRegularSiteLocally revised triangulation = do+  let label = powerSiteLabel revised+  (removed, removalSupport) <- removeAnyRegularSiteLocally label triangulation+  (inserted, insertionSupport) <- insertRegularSiteLocally revised removed+  pure (inserted, Set.union removalSupport insertionSupport)++commonRegularWeightShift+  :: Ord label+  => Map label PowerWeight+  -> Map label (PowerSite label)+  -> Maybe ExactRational+commonRegularWeightShift requested sites+  | Map.size requested /= Map.size sites = Nothing+  | otherwise = do+      (firstLabel, firstWeight) <- Map.lookupMin requested+      firstSite <- Map.lookup firstLabel sites+      let shift =+            powerWeightExact firstWeight+              - powerWeightExact (powerSiteWeight firstSite)+      if Map.isSubmapOfBy (powerSiteHasWeightShift shift) requested sites+        then Just shift+        else Nothing++powerSiteHasWeightShift+  :: ExactRational+  -> PowerWeight+  -> PowerSite label+  -> Bool+powerSiteHasWeightShift shift weight site =+  powerWeightExact weight+    - powerWeightExact (powerSiteWeight site)+    == shift++translateRegularWeights+  :: ExactRational+  -> Map label (PowerSite label)+  -> Set label+  -> RegularTriangulation label+  -> RegularEditResult label+translateRegularWeights shift sites changedLabels triangulation =+  let shiftedSection =+        fmap+          (\section ->+             section+               { sectionGenerators =+                   fmap+                     (translateExactPowerGenerator shift)+                     (sectionGenerators section)+               })+          (storedRegularSection triangulation)+   in RegularEditResult+        { regularEditTriangulation =+            triangulation+              { storedRegularSites = sites+              , storedRegularSection = shiftedSection+              }+        , regularEditChangedSites = changedLabels+        , regularEditTransitions = Vector.empty+        }++translateExactPowerGenerator+  :: ExactRational+  -> ExactPowerGenerator label+  -> ExactPowerGenerator label+translateExactPowerGenerator shift generator =+  generator+    { exactPowerGeneratorConstant =+        exactPowerGeneratorConstant generator + shift+    }++removeAnyRegularSiteLocally+  :: Ord label+  => label+  -> RegularTriangulation label+  -> Either+      (LocalRegularEditObstruction label)+      (RegularTriangulation label, Set label)+removeAnyRegularSiteLocally label triangulation =+  case removeTopologyPreservingSite label triangulation of+    Just (edited, _) -> Right (edited, Set.singleton label)+    Nothing -> removeRegularSiteLocally label triangulation++-- Exact topology-preserving edits descend through the existing regular+-- section. A failed classification is not an error; it selects the canonical+-- global normalization below.++classifyCoincidentSubordinate+  :: Ord label+  => PowerSite label+  -> PowerSite label+  -> Maybe (CoincidentGeneratorDisposition label)+classifyCoincidentSubordinate representative candidate =+  if powerSiteQueryPoint candidate /= powerSiteQueryPoint representative+    then Nothing+    else+      case+        compareCoincidentPriority+          (powerSiteWeight candidate, powerSiteLabel candidate)+          (powerSiteWeight representative, powerSiteLabel representative) of+        LT ->+          Just+            ( classifyCoincidentValue+                (powerSiteLabel representative)+                (powerSiteWeight representative)+                (powerSiteWeight candidate)+            )+        _ -> Nothing++removeTopologyPreservingSite+  :: Ord label+  => label+  -> RegularTriangulation label+  -> Maybe+      ( RegularTriangulation label+      , Vector.Vector (RegularSiteTransition label)+      )+removeTopologyPreservingSite label triangulation = do+  section <- storedRegularSection triangulation+  disposition <- Map.lookup label (sectionRegularDispositions section)+  editedSection <-+    case disposition of+      RegularSiteCoincidentEquivalentTo _ -> removeCoincident section+      RegularSiteCoincidentDominatedBy _ -> removeCoincident section+      RegularSiteHidden+        | not (hasCoincidentAliases label section) -> do+            generator <- Map.lookup label (sectionGenerators section)+            let receipt = sectionRegularReceipt section+            pure+              section+                { sectionGenerators = Map.delete label (sectionGenerators section)+                , sectionSlopeRepresentatives =+                    Map.delete (exactGeneratorSlope generator) (sectionSlopeRepresentatives section)+                , sectionRegularDispositions =+                    Map.delete label (sectionRegularDispositions section)+                , sectionRegularStars = Map.delete label (sectionRegularStars section)+                , sectionRegularReceipt =+                    receipt+                      { generatorRegularInputSites = generatorRegularInputSites receipt - 1+                      , generatorRegularHiddenSites = generatorRegularHiddenSites receipt - 1+                      }+                , sectionRegularLocality = fmap (detachRegularHidden label) (sectionRegularLocality section)+                }+      _ -> Nothing+  let edited =+        replaceRegularSiteSection+          (Map.delete label (storedRegularSites triangulation))+          editedSection+          triangulation+  pure+    ( edited+    , Vector.singleton (RegularSiteDisappeared label disposition)+    )+ where+  removeCoincident section = do+    _ <- Map.lookup label (sectionCoincidentDispositions section)+    pure+      section+        { sectionCoincidentDispositions =+            Map.delete label (sectionCoincidentDispositions section)+        , sectionRegularDispositions =+            Map.delete label (sectionRegularDispositions section)+        , sectionRegularStars = Map.delete label (sectionRegularStars section)+        }++data RegularReweightDescent label = RegularReweightDescent+  { descendedCoincidentDispositions :: !(Map label (CoincidentGeneratorDisposition label))+  , descendedGenerators :: !(Map label (ExactPowerGenerator label))+  , descendedRegularDispositions :: !(Map label (RegularSiteDisposition label))+  , descendedTransitions :: ![RegularSiteTransition label]+  }++reweightTopologyPreservingSites+  :: Ord label+  => Set label+  -> Map label (PowerSite label)+  -> Map label (PowerSite label)+  -> RegularTriangulation label+  -> Maybe+      ( RegularTriangulation label+      , Vector.Vector (RegularSiteTransition label)+      )+reweightTopologyPreservingSites changedLabels changedSites reweightedSites triangulation = do+  section <- storedRegularSection triangulation+  let coincidentRepresentatives =+        Map.foldl'+          (flip (Set.insert . coincidentRepresentativeLabel))+          Set.empty+          (sectionCoincidentDispositions section)+  descent <-+    Foldable.foldlM+      ( descendTopologyPreservingReweight+          changedLabels+          reweightedSites+          coincidentRepresentatives+          triangulation+      )+      RegularReweightDescent+        { descendedCoincidentDispositions = sectionCoincidentDispositions section+        , descendedGenerators = sectionGenerators section+        , descendedRegularDispositions = sectionRegularDispositions section+        , descendedTransitions = []+        }+      changedSites+  let editedSection =+        section+          { sectionCoincidentDispositions = descendedCoincidentDispositions descent+          , sectionGenerators = descendedGenerators descent+          , sectionRegularDispositions = descendedRegularDispositions descent+          }+      edited =+        replaceRegularSiteSection+          reweightedSites+          editedSection+          triangulation+  pure (edited, Vector.fromList (reverse (descendedTransitions descent)))++descendTopologyPreservingReweight+  :: Ord label+  => Set label+  -> Map label (PowerSite label)+  -> Set label+  -> RegularTriangulation label+  -> RegularReweightDescent label+  -> PowerSite label+  -> Maybe (RegularReweightDescent label)+descendTopologyPreservingReweight changedLabels reweightedSites coincidentRepresentatives triangulation descent revised = do+  resident <- Map.lookup label (storedRegularSites triangulation)+  disposition <-+    storedRegularSection triangulation+      >>= Map.lookup label . sectionRegularDispositions+  case regularCoincidentRepresentative disposition of+    Just representative+      | Set.notMember representative changedLabels -> do+          representativeSite <- Map.lookup representative reweightedSites+          coincident <- classifyCoincidentSubordinate representativeSite revised+          let after = coincidentRegularDisposition coincident+          pure+            descent+              { descendedCoincidentDispositions =+                  Map.insert label coincident (descendedCoincidentDispositions descent)+              , descendedRegularDispositions =+                  Map.insert label after (descendedRegularDispositions descent)+              , descendedTransitions =+                  if disposition == after+                    then descendedTransitions descent+                    else RegularSiteTransitioned label disposition after : descendedTransitions descent+              }+    _+      | disposition == RegularSiteHidden+          && powerSiteWeight revised < powerSiteWeight resident+          && Set.notMember label coincidentRepresentatives ->+          let (generator, _) = prepareExactPowerGenerator revised+           in Just+                descent+                  { descendedGenerators =+                      Map.insert label generator (descendedGenerators descent)+                  }+      | otherwise -> Nothing+ where+  label = powerSiteLabel revised++hasCoincidentAliases+  :: Eq label+  => label+  -> RegularSection label+  -> Bool+hasCoincidentAliases label =+  any ((== label) . coincidentRepresentativeLabel)+    . Map.elems+    . sectionCoincidentDispositions++regularCoincidentRepresentative :: RegularSiteDisposition label -> Maybe label+regularCoincidentRepresentative disposition =+  case disposition of+    RegularSiteCoincidentEquivalentTo label -> Just label+    RegularSiteCoincidentDominatedBy label -> Just label+    _ -> Nothing++coincidentRepresentativeLabel :: CoincidentGeneratorDisposition label -> label+coincidentRepresentativeLabel disposition =+  case disposition of+    CoincidentGeneratorEquivalentTo label -> label+    CoincidentGeneratorDominatedBy label -> label++normalizeRegularEdit+  :: Ord label+  => RegularTriangulation label+  -> Map label (PowerSite label)+  -> Set label+  -> Either+      (RegularEditError label)+      (RegularEditResult label)+normalizeRegularEdit previous sites changedSites = do+  triangulation <-+    first RegularEditTopologyFailed+      (constructRegularTriangulation sites)+  pure+    ( RegularEditResult+        triangulation+        changedSites+        ( dispositionTransitions+            (regularDispositionSection previous)+            (regularDispositionSection triangulation)+        )+    )++unchangedRegularEdit+  :: RegularTriangulation label+  -> RegularEditResult label+unchangedRegularEdit triangulation =+  RegularEditResult triangulation Set.empty Vector.empty+++dispositionTransitions+  :: Ord label+  => Map label (RegularSiteDisposition label)+  -> Map label (RegularSiteDisposition label)+  -> Vector.Vector (RegularSiteTransition label)+dispositionTransitions previous current =+  Vector.fromList+    ( Map.elems+        ( Map.mergeWithKey+            changedDispositionTransition+            (Map.mapWithKey RegularSiteDisappeared)+            (Map.mapWithKey RegularSiteAppeared)+            previous+            current+        )+    )++dispositionTransitionsOn+  :: Ord label+  => Set label+  -> Map label (RegularSiteDisposition label)+  -> Map label (RegularSiteDisposition label)+  -> Vector.Vector (RegularSiteTransition label)+dispositionTransitionsOn support previous current =+  dispositionTransitions+    (Map.restrictKeys previous support)+    (Map.restrictKeys current support)++changedDispositionTransition+  :: Eq label+  => label+  -> RegularSiteDisposition label+  -> RegularSiteDisposition label+  -> Maybe (RegularSiteTransition label)+changedDispositionTransition label before after+  | before == after = Nothing+  | otherwise = Just (RegularSiteTransitioned label before after)
+ src-public/Moonlight/Triangulation/Internal/PowerDiagram/Generator.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Exact affine generators and their dual geometry. This module owns the+-- algebra shared by batch hull construction, local edits, and bounded+-- projection; it does not choose a construction schedule.+module Moonlight.Triangulation.Internal.PowerDiagram.Generator+  ( ExactPowerGenerator (..)+  , DistinctSlopeGenerators (..)+  , RegularGeneratorDisposition (..)+  , GeneratorRegularFace (..)+  , GeneratorDualGeometry (..)+  , GeneratorRegularEdge (..)+  , GeneratorRegularTopology (..)+  , GeneratorRegularReceipt (..)+  , RegularTopologyError (..)+  , exactGeneratorAxis+  , exactGeneratorLiftedVolume+  , exactGeneratorFaceDual+  , exactGeneratorBoundaryDualRay+  , exactGeneratorDualBetween+  ) where++import Control.DeepSeq (NFData)+import Data.Bifunctor (first)+import Data.List.NonEmpty (NonEmpty)+import GHC.Generics (Generic)+import Moonlight.Triangulation.Exact+  ( ExactAffineLine+  , ExactGeometryError+  , ExactHalfPlaneError+  , ExactIntersectionError+  , ExactPoint+  , ExactRay+  , ExactSegment+  , ExactVector (..)+  , exactAffineLine+  , exactAffineLineCoefficients+  , exactAffineLineIntersection+  , exactRay+  , exactSegment+  )+import Moonlight.Triangulation.Internal.ExactRational (ExactRational)+import Moonlight.Triangulation.Minkowski (MinkowskiError)+data ExactPowerGenerator label = ExactPowerGenerator+  { exactPowerGeneratorLabel :: !label+  , exactPowerGeneratorXCoefficient :: !ExactRational+  , exactPowerGeneratorYCoefficient :: !ExactRational+  , exactPowerGeneratorConstant :: !ExactRational+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Package-internal witness that coincident affine slopes were resolved once.+newtype DistinctSlopeGenerators label =+  DistinctSlopeGenerators (NonEmpty (ExactPowerGenerator label))++data RegularGeneratorDisposition+  = RegularGeneratorVisible+  | RegularGeneratorLowerDimensional+  | RegularGeneratorHidden+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data GeneratorRegularFace label = GeneratorRegularFace+  { generatorRegularFaceFirst :: !label+  , generatorRegularFaceSecond :: !label+  , generatorRegularFaceThird :: !label+  , generatorRegularFaceDualPoint :: !ExactPoint+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data GeneratorDualGeometry+  = GeneratorDualSegment !ExactSegment+  | GeneratorDualRay !ExactRay+  | GeneratorDualLine !ExactAffineLine+  | GeneratorDualCollapsed !ExactPoint+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data GeneratorRegularEdge label = GeneratorRegularEdge+  { generatorRegularEdgeFirst :: !(ExactPowerGenerator label)+  , generatorRegularEdgeSecond :: !(ExactPowerGenerator label)+  , generatorRegularEdgeDual :: !GeneratorDualGeometry+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data GeneratorRegularTopology label = GeneratorRegularTopology+  { generatorRegularDispositions :: !(NonEmpty (ExactPowerGenerator label, RegularGeneratorDisposition))+  , generatorRegularFaces :: ![GeneratorRegularFace label]+  , generatorRegularEdges :: ![GeneratorRegularEdge label]+  , generatorRegularReceipt :: !GeneratorRegularReceipt+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++data GeneratorRegularReceipt = GeneratorRegularReceipt+  { generatorRegularInputSites :: !Int+  , generatorRegularVisibleSites :: !Int+  , generatorRegularLowerDimensionalSites :: !Int+  , generatorRegularHiddenSites :: !Int+  , generatorRegularFaceCount :: !Int+  , generatorRegularEdgeCount :: !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Exact slope-hull, incidence, and dual-construction obstructions.+data RegularTopologyError label+  = RegularTopologySlopeHullInvalid !MinkowskiError+  | RegularTopologySlopeVertexMissing !ExactPoint+  | RegularTopologyAxisInvalid !label !label !ExactHalfPlaneError+  | RegularTopologyDualVertexInvalid !label !label !label !ExactIntersectionError+  | RegularTopologyDualSegmentInvalid !label !label !ExactGeometryError+  | RegularTopologyDualRayInvalid !label !label !ExactGeometryError+  | RegularTopologyFlatBoundary !label !label !label+  | RegularTopologyNonManifoldEdge !label !label !Int+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++exactGeneratorAxis+  :: ExactPowerGenerator label+  -> ExactPowerGenerator label+  -> Either ExactHalfPlaneError ExactAffineLine+exactGeneratorAxis firstGenerator secondGenerator =+  exactAffineLine+    ( exactPowerGeneratorXCoefficient firstGenerator+        - exactPowerGeneratorXCoefficient secondGenerator+    )+    ( exactPowerGeneratorYCoefficient firstGenerator+        - exactPowerGeneratorYCoefficient secondGenerator+    )+    ( exactPowerGeneratorConstant firstGenerator+        - exactPowerGeneratorConstant secondGenerator+    )++-- | Signed exact lifted volume of four affine generators. For a+-- counter-clockwise slope face, a positive result lies above its supporting+-- plane and therefore belongs to the insertion conflict cavity.+exactGeneratorLiftedVolume+  :: ExactPowerGenerator label+  -> ExactPowerGenerator label+  -> ExactPowerGenerator label+  -> ExactPowerGenerator label+  -> ExactRational+exactGeneratorLiftedVolume firstGenerator secondGenerator thirdGenerator fourthGenerator =+  let (firstX, firstY, firstZ) = generatorCoordinates firstGenerator+      (secondX, secondY, secondZ) = generatorCoordinates secondGenerator+      (thirdX, thirdY, thirdZ) = generatorCoordinates thirdGenerator+      (fourthX, fourthY, fourthZ) = generatorCoordinates fourthGenerator+      secondX' = secondX - firstX+      secondY' = secondY - firstY+      secondZ' = secondZ - firstZ+      thirdX' = thirdX - firstX+      thirdY' = thirdY - firstY+      thirdZ' = thirdZ - firstZ+      fourthX' = fourthX - firstX+      fourthY' = fourthY - firstY+      fourthZ' = fourthZ - firstZ+   in secondX' * (thirdY' * fourthZ' - thirdZ' * fourthY')+        - secondY' * (thirdX' * fourthZ' - thirdZ' * fourthX')+        + secondZ' * (thirdX' * fourthY' - thirdY' * fourthX')++-- | Exact dual vertex shared by three affine generators.+exactGeneratorFaceDual+  :: ExactPowerGenerator label+  -> ExactPowerGenerator label+  -> ExactPowerGenerator label+  -> Either (RegularTopologyError label) ExactPoint+exactGeneratorFaceDual firstGenerator secondGenerator thirdGenerator = do+  firstAxis <-+    first+      (RegularTopologyAxisInvalid (exactPowerGeneratorLabel firstGenerator) (exactPowerGeneratorLabel secondGenerator))+      (exactGeneratorAxis firstGenerator secondGenerator)+  secondAxis <-+    first+      (RegularTopologyAxisInvalid (exactPowerGeneratorLabel firstGenerator) (exactPowerGeneratorLabel thirdGenerator))+      (exactGeneratorAxis firstGenerator thirdGenerator)+  first+    ( RegularTopologyDualVertexInvalid+        (exactPowerGeneratorLabel firstGenerator)+        (exactPowerGeneratorLabel secondGenerator)+        (exactPowerGeneratorLabel thirdGenerator)+    )+    (exactAffineLineIntersection firstAxis secondAxis)++-- | Exact outward dual ray of an oriented boundary edge and its incident+-- counter-clockwise face.+exactGeneratorBoundaryDualRay+  :: ExactPoint+  -> ExactPowerGenerator label+  -> ExactPowerGenerator label+  -> ExactPowerGenerator label+  -> Either (RegularTopologyError label) ExactRay+exactGeneratorBoundaryDualRay originPoint firstGenerator secondGenerator thirdGenerator = do+  axis <-+    first+      ( RegularTopologyAxisInvalid+          (exactPowerGeneratorLabel firstGenerator)+          (exactPowerGeneratorLabel secondGenerator)+      )+      (exactGeneratorAxis firstGenerator secondGenerator)+  let (axisX, axisY, _) = exactAffineLineCoefficients axis+      candidate = ExactVector axisY (negate axisX)+      advantageX =+        exactPowerGeneratorXCoefficient firstGenerator+          - exactPowerGeneratorXCoefficient thirdGenerator+      advantageY =+        exactPowerGeneratorYCoefficient firstGenerator+          - exactPowerGeneratorYCoefficient thirdGenerator+      ExactVector candidateX candidateY = candidate+      derivative = advantageX * candidateX + advantageY * candidateY+      direction =+        if derivative > 0+          then candidate+          else ExactVector (negate candidateX) (negate candidateY)+  if derivative == 0+    then+      Left+        ( RegularTopologyFlatBoundary+            (exactPowerGeneratorLabel firstGenerator)+            (exactPowerGeneratorLabel secondGenerator)+            (exactPowerGeneratorLabel thirdGenerator)+        )+    else+      first+        ( RegularTopologyDualRayInvalid+            (exactPowerGeneratorLabel firstGenerator)+            (exactPowerGeneratorLabel secondGenerator)+        )+        (exactRay originPoint direction)++-- | Canonical undirected dual geometry between two incident face vertices.+exactGeneratorDualBetween+  :: label+  -> label+  -> ExactPoint+  -> ExactPoint+  -> Either (RegularTopologyError label) GeneratorDualGeometry+exactGeneratorDualBetween firstLabel secondLabel firstPoint secondPoint+  | firstPoint == secondPoint = Right (GeneratorDualCollapsed firstPoint)+  | otherwise =+      fmap GeneratorDualSegment+        ( first+            (RegularTopologyDualSegmentInvalid firstLabel secondLabel)+            ( uncurry exactSegment+                ( if firstPoint <= secondPoint+                    then (firstPoint, secondPoint)+                    else (secondPoint, firstPoint)+                )+            )+        )++generatorCoordinates+  :: ExactPowerGenerator label+  -> (ExactRational, ExactRational, ExactRational)+generatorCoordinates generator =+  ( exactPowerGeneratorXCoefficient generator+  , exactPowerGeneratorYCoefficient generator+  , exactPowerGeneratorConstant generator+  )
+ src-public/Moonlight/Triangulation/Internal/PowerDiagram/Hull.hs view
@@ -0,0 +1,925 @@+-- | Exact upper-hull descent for affine generators. The public power owner+-- supplies admitted, distinct slopes; this module returns only topology and+-- exact dual geometry.+module Moonlight.Triangulation.Internal.PowerDiagram.Hull+  ( regularGeneratorTopology+  ) where++import Data.Bifunctor (first)+import qualified Data.Foldable as Foldable+import qualified Data.IntMap.Strict as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.List as List+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 Data.Maybe (mapMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import Moonlight.Triangulation.Exact+  ( ExactAffineLine+  , ExactPoint+  , ExactRay+  , exactPoint+  , exactPointCoordinates+  )+import Moonlight.Triangulation.Internal.BoundaryCycle (consecutivePairs)+import Moonlight.Triangulation.Internal.ExactRational (ExactRational)+import Moonlight.Triangulation.Internal.Minkowski.Convex (convexHullPolygon)+import Moonlight.Triangulation.Internal.PowerDiagram.Generator+import Moonlight.Triangulation.Minkowski (convexPolygonPoints)++-- | Construct exact regular topology from distinct affine slopes. Full-rank+-- input uses one conflict graph; collinear slopes use the one-dimensional+-- upper chain; coplanar lifted input reuses the exact planar hull owner.+regularGeneratorTopology+  :: Ord label+  => DistinctSlopeGenerators label+  -> Either (RegularTopologyError label) (GeneratorRegularTopology label)+regularGeneratorTopology (DistinctSlopeGenerators generators) =+  let points = admittedLiftedPoints generators+   in case points of+        singleton :| [] ->+          pure (topologyFromParts points (Set.singleton singleton) Set.empty [] [])+        firstPoint :| secondPoint : remaining ->+          case List.find (not . slopeCollinear firstPoint secondPoint) remaining of+            Nothing -> collinearSlopeTopology points firstPoint secondPoint+            Just thirdPoint ->+              case List.find (not . liftedCoplanar firstPoint secondPoint thirdPoint) remaining of+                Nothing -> coplanarLiftedTopology points+                Just fourthPoint -> fullRankTopology points firstPoint secondPoint thirdPoint fourthPoint++data LiftedPoint label = LiftedPoint+  { liftedPointId :: !Int+  , liftedPointGenerator :: !(ExactPowerGenerator label)+  }++instance Eq (LiftedPoint label) where+  left == right = liftedPointId left == liftedPointId right++instance Ord (LiftedPoint label) where+  compare left right = compare (liftedPointId left) (liftedPointId right)++admittedLiftedPoints+  :: Ord label+  => NonEmpty (ExactPowerGenerator label)+  -> NonEmpty (LiftedPoint label)+admittedLiftedPoints generators =+  let ordered = NonEmpty.sortWith exactPowerGeneratorLabel generators+   in NonEmpty.zipWith+        (\identifier generator -> LiftedPoint identifier generator)+        (0 :| [1 ..])+        ordered++liftedCoordinates+  :: LiftedPoint label+  -> (ExactRational, ExactRational, ExactRational)+liftedCoordinates point =+  let generator = liftedPointGenerator point+   in ( exactPowerGeneratorXCoefficient generator+      , exactPowerGeneratorYCoefficient generator+      , exactPowerGeneratorConstant generator+      )++slopePoint :: LiftedPoint label -> ExactPoint+slopePoint point =+  let (coordinateX, coordinateY, _) = liftedCoordinates point+   in exactPoint coordinateX coordinateY++slopeCollinear+  :: LiftedPoint label+  -> LiftedPoint label+  -> LiftedPoint label+  -> Bool+slopeCollinear firstPoint secondPoint thirdPoint =+  slopeOrientation firstPoint secondPoint thirdPoint == 0++slopeOrientation+  :: LiftedPoint label+  -> LiftedPoint label+  -> LiftedPoint label+  -> ExactRational+slopeOrientation firstPoint secondPoint thirdPoint =+  let (firstX, firstY, _) = liftedCoordinates firstPoint+      (secondX, secondY, _) = liftedCoordinates secondPoint+      (thirdX, thirdY, _) = liftedCoordinates thirdPoint+   in (secondX - firstX) * (thirdY - firstY)+        - (secondY - firstY) * (thirdX - firstX)++liftedCoplanar+  :: LiftedPoint label+  -> LiftedPoint label+  -> LiftedPoint label+  -> LiftedPoint label+  -> Bool+liftedCoplanar firstPoint secondPoint thirdPoint fourthPoint =+  liftedVolume firstPoint secondPoint thirdPoint fourthPoint == 0++liftedVolume+  :: LiftedPoint label+  -> LiftedPoint label+  -> LiftedPoint label+  -> LiftedPoint label+  -> ExactRational+liftedVolume firstPoint secondPoint thirdPoint fourthPoint =+  exactGeneratorLiftedVolume+    (liftedPointGenerator firstPoint)+    (liftedPointGenerator secondPoint)+    (liftedPointGenerator thirdPoint)+    (liftedPointGenerator fourthPoint)++data HullFace label = HullFace+  { hullFaceId :: !Int+  , hullFaceFirst :: !(LiftedPoint label)+  , hullFaceSecond :: !(LiftedPoint label)+  , hullFaceThird :: !(LiftedPoint label)+  , hullFaceOutside :: !(Set (LiftedPoint label))+  , hullFaceCoplanar :: !(Set (LiftedPoint label))+  }++type HullEdge = (Int, Int)++data HullState label = HullState+  { hullFaces :: !(IntMap.IntMap (HullFace label))+  , hullEdgeFaces :: !(Map HullEdge IntSet.IntSet)+  , hullConflictFaces :: !IntSet.IntSet+  , hullNextFaceId :: !Int+  }++fullRankTopology+  :: NonEmpty (LiftedPoint label)+  -> LiftedPoint label+  -> LiftedPoint label+  -> LiftedPoint label+  -> LiftedPoint label+  -> Either (RegularTopologyError label) (GeneratorRegularTopology label)+fullRankTopology points firstPoint secondPoint thirdPoint fourthPoint = do+  let interior = liftedInteriorSum firstPoint secondPoint thirdPoint fourthPoint+      simplex = Set.fromList [firstPoint, secondPoint, thirdPoint, fourthPoint]+      initialFaces =+        zipWith+          (orientedHullFace interior)+          [0 ..]+          [ (firstPoint, secondPoint, thirdPoint)+          , (firstPoint, fourthPoint, secondPoint)+          , (firstPoint, thirdPoint, fourthPoint)+          , (secondPoint, fourthPoint, thirdPoint)+          ]+      initialState =+        List.foldl'+          insertHullFace+          (HullState IntMap.empty Map.empty IntSet.empty 4)+          initialFaces+      seededState =+        Foldable.foldl'+          (flip assignPointToHull)+          initialState+          (filter (`Set.notMember` simplex) (NonEmpty.toList points))+      finalState = descendHull interior seededState+      upperFaces = filter ((> 0) . hullFaceNormalZ) (IntMap.elems (hullFaces finalState))+  (canonicalFaces, visible, lowerDimensional) <- canonicalUpperFaces upperFaces+  (faces, edges) <- topologyFromHullFaces canonicalFaces+  pure+    (topologyFromParts points visible lowerDimensional faces edges)++liftedInteriorSum+  :: LiftedPoint label+  -> LiftedPoint label+  -> LiftedPoint label+  -> LiftedPoint label+  -> (ExactRational, ExactRational, ExactRational)+liftedInteriorSum firstPoint secondPoint thirdPoint fourthPoint =+  let (firstX, firstY, firstZ) = liftedCoordinates firstPoint+      (secondX, secondY, secondZ) = liftedCoordinates secondPoint+      (thirdX, thirdY, thirdZ) = liftedCoordinates thirdPoint+      (fourthX, fourthY, fourthZ) = liftedCoordinates fourthPoint+   in ( firstX + secondX + thirdX + fourthX+      , firstY + secondY + thirdY + fourthY+      , firstZ + secondZ + thirdZ + fourthZ+      )++orientedHullFace+  :: (ExactRational, ExactRational, ExactRational)+  -> Int+  -> (LiftedPoint label, LiftedPoint label, LiftedPoint label)+  -> HullFace label+orientedHullFace interior identifier (firstPoint, secondPoint, thirdPoint) =+  let provisional = HullFace identifier firstPoint secondPoint thirdPoint Set.empty Set.empty+   in if hullFaceVolumeAtInterior interior provisional < 0+        then provisional+        else HullFace identifier firstPoint thirdPoint secondPoint Set.empty Set.empty++hullFaceVolumeAtInterior+  :: (ExactRational, ExactRational, ExactRational)+  -> HullFace label+  -> ExactRational+hullFaceVolumeAtInterior (sumX, sumY, sumZ) face =+  let (firstX, firstY, firstZ) = liftedCoordinates (hullFaceFirst face)+      (secondX, secondY, secondZ) = liftedCoordinates (hullFaceSecond face)+      (thirdX, thirdY, thirdZ) = liftedCoordinates (hullFaceThird face)+      secondX' = secondX - firstX+      secondY' = secondY - firstY+      secondZ' = secondZ - firstZ+      thirdX' = thirdX - firstX+      thirdY' = thirdY - firstY+      thirdZ' = thirdZ - firstZ+      interiorX' = sumX - 4 * firstX+      interiorY' = sumY - 4 * firstY+      interiorZ' = sumZ - 4 * firstZ+   in secondX' * (thirdY' * interiorZ' - thirdZ' * interiorY')+        - secondY' * (thirdX' * interiorZ' - thirdZ' * interiorX')+        + secondZ' * (thirdX' * interiorY' - thirdY' * interiorX')++liftedVolumeAtFace :: HullFace label -> LiftedPoint label -> ExactRational+liftedVolumeAtFace face =+  liftedVolume+    (hullFaceFirst face)+    (hullFaceSecond face)+    (hullFaceThird face)++hullFaceNormalZ :: HullFace label -> ExactRational+hullFaceNormalZ face =+  slopeOrientation+    (hullFaceFirst face)+    (hullFaceSecond face)+    (hullFaceThird face)++hullFacePoints :: HullFace label -> [LiftedPoint label]+hullFacePoints face =+  [hullFaceFirst face, hullFaceSecond face, hullFaceThird face]++hullFaceDirectedEdges+  :: HullFace label+  -> [(LiftedPoint label, LiftedPoint label)]+hullFaceDirectedEdges face =+  [ (hullFaceFirst face, hullFaceSecond face)+  , (hullFaceSecond face, hullFaceThird face)+  , (hullFaceThird face, hullFaceFirst face)+  ]++hullEdgeKey :: LiftedPoint label -> LiftedPoint label -> HullEdge+hullEdgeKey firstPoint secondPoint =+  let firstId = liftedPointId firstPoint+      secondId = liftedPointId secondPoint+   in if firstId <= secondId then (firstId, secondId) else (secondId, firstId)++insertHullFace :: HullState label -> HullFace label -> HullState label+insertHullFace state face =+  state+    { hullFaces = IntMap.insert (hullFaceId face) face (hullFaces state)+    , hullEdgeFaces =+        List.foldl'+          (\incidence (fromPoint, toPoint) ->+             Map.insertWith+               IntSet.union+               (hullEdgeKey fromPoint toPoint)+               (IntSet.singleton (hullFaceId face))+               incidence)+          (hullEdgeFaces state)+          (hullFaceDirectedEdges face)+    }++assignPointToHull :: LiftedPoint label -> HullState label -> HullState label+assignPointToHull point state =+  attachSelectedPoint point state+    (selectHullFace point (IntMap.elems (hullFaces state)))++data HullFaceSelection label+  = HullFaceInterior+  | HullFaceCoplanar !(HullFace label)+  | HullFaceVisible !(HullFace label) !ExactRational++selectHullFace+  :: LiftedPoint label+  -> [HullFace label]+  -> HullFaceSelection label+selectHullFace point = List.foldl' choose HullFaceInterior+ where+  choose selected face =+    let volume = liftedVolumeAtFace face point+     in case compare volume 0 of+          LT -> selected+          EQ ->+            case selected of+              HullFaceInterior -> HullFaceCoplanar face+              _ -> selected+          GT ->+            case selected of+              HullFaceVisible current currentVolume+                | volume < currentVolume+                    || (volume == currentVolume && hullFaceId current < hullFaceId face) ->+                    selected+              _ -> HullFaceVisible face volume++attachSelectedPoint+  :: LiftedPoint label+  -> HullState label+  -> HullFaceSelection label+  -> HullState label+attachSelectedPoint point state selection =+  case selection of+    HullFaceInterior -> state+    HullFaceCoplanar face ->+      state+        { hullFaces =+            IntMap.adjust+              (\selected -> selected{hullFaceCoplanar = Set.insert point (hullFaceCoplanar selected)})+              (hullFaceId face)+              (hullFaces state)+        }+    HullFaceVisible face _ ->+      state+        { hullFaces =+            IntMap.adjust+              (\selected -> selected{hullFaceOutside = Set.insert point (hullFaceOutside selected)})+              (hullFaceId face)+              (hullFaces state)+        , hullConflictFaces = IntSet.insert (hullFaceId face) (hullConflictFaces state)+        }++descendHull+  :: (ExactRational, ExactRational, ExactRational)+  -> HullState label+  -> HullState label+descendHull interior state =+  case nextHullExpansion state of+    Nothing -> state+    Just (seedFace, apex) ->+      let visible = visibleHullPatch state apex (IntSet.singleton (hullFaceId seedFace)) [hullFaceId seedFace]+          visibleFaces =+            mapMaybe (`IntMap.lookup` hullFaces state) (IntSet.toAscList visible)+          horizon = hullHorizon state visible visibleFaces+          candidates =+            Set.difference+              ( Set.delete apex+                  ( Set.unions+                      [ Set.unions+                          [ hullFaceOutside face+                          , hullFaceCoplanar face+                          , Set.fromList (hullFacePoints face)+                          ]+                      | face <- visibleFaces+                      ]+                  )+              )+              ( Set.fromList+                  [ point+                  | (firstPoint, secondPoint) <- Map.elems horizon+                  , point <- [firstPoint, secondPoint]+                  ]+              )+          withoutVisible = removeHullFaces visibleFaces state+          (withHorizon, newFaceIds) =+            Map.foldl'+              (insertHorizonFace interior apex)+              (withoutVisible, [])+              horizon+          redistributed =+            Foldable.foldl'+              (assignPointToFaces newFaceIds)+              withHorizon+              candidates+       in descendHull interior redistributed++nextHullExpansion+  :: HullState label+  -> Maybe (HullFace label, LiftedPoint label)+nextHullExpansion state = do+  identifier <- IntSet.lookupMin (hullConflictFaces state)+  face <- IntMap.lookup identifier (hullFaces state)+  apex <- farthestOutsidePoint face+  pure (face, apex)++farthestOutsidePoint :: HullFace label -> Maybe (LiftedPoint label)+farthestOutsidePoint face =+  case Set.minView (hullFaceOutside face) of+    Nothing -> Nothing+    Just (initial, remaining) ->+      Just+        ( fst+            ( Foldable.foldl'+                (\(selected, selectedVolume) candidate ->+                   let candidateVolume = liftedVolumeAtFace face candidate+                    in if candidateVolume > selectedVolume+                         then (candidate, candidateVolume)+                         else (selected, selectedVolume))+                (initial, liftedVolumeAtFace face initial)+                remaining+            )+        )++visibleHullPatch+  :: HullState label+  -> LiftedPoint label+  -> IntSet.IntSet+  -> [Int]+  -> IntSet.IntSet+visibleHullPatch _ _ visited [] = visited+visibleHullPatch state apex visited (identifier : remaining) =+  case IntMap.lookup identifier (hullFaces state) of+    Nothing -> visibleHullPatch state apex visited remaining+    Just face ->+      let neighbours =+            IntSet.unions+              [ Map.findWithDefault IntSet.empty (hullEdgeKey fromPoint toPoint) (hullEdgeFaces state)+              | (fromPoint, toPoint) <- hullFaceDirectedEdges face+              ]+          newlyVisible =+            IntSet.filter+              (\candidateId ->+                 IntSet.notMember candidateId visited+                   && maybe+                     False+                     ((> 0) . (`liftedVolumeAtFace` apex))+                     (IntMap.lookup candidateId (hullFaces state)))+              neighbours+       in visibleHullPatch+            state+            apex+            (IntSet.union visited newlyVisible)+            (IntSet.toList newlyVisible <> remaining)++hullHorizon+  :: HullState label+  -> IntSet.IntSet+  -> [HullFace label]+  -> Map HullEdge (LiftedPoint label, LiftedPoint label)+hullHorizon state visible visibleFaces =+  Map.fromList+    [ (hullEdgeKey fromPoint toPoint, (fromPoint, toPoint))+    | face <- visibleFaces+    , (fromPoint, toPoint) <- hullFaceDirectedEdges face+    , not+        ( IntSet.null+            ( IntSet.difference+                (Map.findWithDefault IntSet.empty (hullEdgeKey fromPoint toPoint) (hullEdgeFaces state))+                visible+            )+        )+    ]++removeHullFaces :: [HullFace label] -> HullState label -> HullState label+removeHullFaces removed state = List.foldl' removeHullFace state removed++removeHullFace :: HullState label -> HullFace label -> HullState label+removeHullFace state face =+  state+    { hullFaces = IntMap.delete identifier (hullFaces state)+    , hullEdgeFaces =+        List.foldl'+          (removeHullFaceFromEdge identifier)+          (hullEdgeFaces state)+          (hullFaceDirectedEdges face)+    , hullConflictFaces = IntSet.delete identifier (hullConflictFaces state)+    }+ where+  identifier = hullFaceId face++removeHullFaceFromEdge+  :: Int+  -> Map HullEdge IntSet.IntSet+  -> (LiftedPoint label, LiftedPoint label)+  -> Map HullEdge IntSet.IntSet+removeHullFaceFromEdge identifier incidence (fromPoint, toPoint) =+  Map.update+    (\incident ->+       let retained = IntSet.delete identifier incident+        in if IntSet.null retained then Nothing else Just retained)+    (hullEdgeKey fromPoint toPoint)+    incidence++insertHorizonFace+  :: (ExactRational, ExactRational, ExactRational)+  -> LiftedPoint label+  -> (HullState label, [Int])+  -> (LiftedPoint label, LiftedPoint label)+  -> (HullState label, [Int])+insertHorizonFace interior apex (state, identifiers) (firstPoint, secondPoint) =+  let identifier = hullNextFaceId state+      face = orientedHullFace interior identifier (firstPoint, secondPoint, apex)+      nextState =+        (insertHullFace state face)+          { hullNextFaceId = identifier + 1 }+   in (nextState, identifier : identifiers)++assignPointToFaces+  :: [Int]+  -> HullState label+  -> LiftedPoint label+  -> HullState label+assignPointToFaces identifiers state point =+  attachSelectedPoint point state+    (selectHullFace point (mapMaybe (`IntMap.lookup` hullFaces state) identifiers))++-- | Glue the triangular implementation facets on each exact supporting plane,+-- then recover only that plane's extreme slope vertices. This removes+-- simplex/horizon diagonals from the visibility decision while retaining a+-- deterministic triangulation for incidence and collapsed duals.+canonicalUpperFaces+  :: [HullFace label]+  -> Either+      (RegularTopologyError label)+      ( [(HullFace label, ExactPoint)]+      , Set (LiftedPoint label)+      , Set (LiftedPoint label)+      )+canonicalUpperFaces faces = do+  associations <- traverse upperFaceAssociation faces+  sections <-+    traverse canonicalUpperFaceGroup+      ( Map.elems+          ( List.foldl'+              (\groups (planeKey, dualFace) ->+                 Map.insertWith (<>) planeKey (dualFace :| []) groups)+              Map.empty+              associations+          )+      )+  let (sectionFaces, visible, lowerDimensional) = mconcat sections+      canonicalFaces =+        zipWith+          (\identifier (face, dualPoint) ->+             (face{hullFaceId = identifier}, dualPoint))+          [0 ..]+          sectionFaces+  pure (canonicalFaces, visible, lowerDimensional)++canonicalUpperFaceGroup+  :: NonEmpty (HullFace label, ExactPoint)+  -> Either+      (RegularTopologyError label)+      ( [(HullFace label, ExactPoint)]+      , Set (LiftedPoint label)+      , Set (LiftedPoint label)+      )+canonicalUpperFaceGroup ((face, dualPoint) :| [])+  | Set.null (hullFaceCoplanar face) =+      Right ([(face, dualPoint)], Set.fromList (hullFacePoints face), Set.empty)+canonicalUpperFaceGroup ((firstFace, dualPoint) :| remainingDualFaces) = do+  let groupFaces = firstFace : fmap fst remainingDualFaces+      groupPoints =+        Set.unions+          [ Set.union+              (Set.fromList (hullFacePoints face))+              (hullFaceCoplanar face)+          | face <- groupFaces+          ]+      initialPoint = hullFaceFirst firstFace+      points = initialPoint :| Set.toAscList (Set.delete initialPoint groupPoints)+      pointsBySlope =+        Map.fromList [(slopePoint point, point) | point <- NonEmpty.toList points]+  hull <-+    first RegularTopologySlopeHullInvalid+      (convexHullPolygon (fmap slopePoint points))+  visiblePoints <-+    traverse+      (\point ->+         maybe+           (Left (RegularTopologySlopeVertexMissing point))+           Right+           (Map.lookup point pointsBySlope))+      (NonEmpty.toList (convexPolygonPoints hull))+  let visible = Set.fromList visiblePoints+  pure+    ( fmap (\fanFace -> (fanFace, dualPoint)) (coplanarFanFaces visiblePoints)+    , visible+    , Set.difference groupPoints visible+    )++hullFacePlaneKey+  :: HullFace label+  -> ExactPoint+  -> (ExactRational, ExactRational, ExactRational)+hullFacePlaneKey face dualPoint =+  let (dualX, dualY) = exactPointCoordinates dualPoint+      generator = liftedPointGenerator (hullFaceFirst face)+      support =+        exactPowerGeneratorXCoefficient generator * dualX+          + exactPowerGeneratorYCoefficient generator * dualY+          + exactPowerGeneratorConstant generator+   in (dualX, dualY, support)++upperFaceAssociation+  :: HullFace label+  -> Either+      (RegularTopologyError label)+      ( (ExactRational, ExactRational, ExactRational)+      , (HullFace label, ExactPoint)+      )+upperFaceAssociation face = do+  (_, dualPoint) <- hullFaceDual face+  pure (hullFacePlaneKey face dualPoint, (face, dualPoint))++coplanarLiftedTopology+  :: NonEmpty (LiftedPoint label)+  -> Either (RegularTopologyError label) (GeneratorRegularTopology label)+coplanarLiftedTopology points = do+  hull <-+    first RegularTopologySlopeHullInvalid+      (convexHullPolygon (fmap slopePoint points))+  let pointsBySlope = Map.fromList [(slopePoint point, point) | point <- NonEmpty.toList points]+  hullPoints <-+    traverse+      (\point -> maybe (Left (RegularTopologySlopeVertexMissing point)) Right (Map.lookup point pointsBySlope))+      (NonEmpty.toList (convexPolygonPoints hull))+  let visible = Set.fromList hullPoints+      lowerDimensional = Set.difference (Set.fromList (NonEmpty.toList points)) visible+      hullFaces' = coplanarFanFaces hullPoints+  dualFaces <- coplanarFanDualFaces hullFaces'+  (faces, edges) <- topologyFromHullFaces dualFaces+  pure+    (topologyFromParts points visible lowerDimensional faces edges)++coplanarFanDualFaces+  :: [HullFace label]+  -> Either+      (RegularTopologyError label)+      [(HullFace label, ExactPoint)]+coplanarFanDualFaces [] = Right []+coplanarFanDualFaces faces@(firstFace : _) = do+  (_, dualPoint) <- hullFaceDual firstFace+  pure (fmap (\face -> (face, dualPoint)) faces)++coplanarFanFaces :: [LiftedPoint label] -> [HullFace label]+coplanarFanFaces (firstPoint : secondPoint : thirdPoint : remaining) =+  zipWith+    (\identifier (leftPoint, rightPoint) ->+       HullFace identifier firstPoint leftPoint rightPoint Set.empty Set.empty)+    [0 ..]+    (consecutivePairs (secondPoint : thirdPoint : remaining))+coplanarFanFaces _ = []++collinearSlopeTopology+  :: NonEmpty (LiftedPoint label)+  -> LiftedPoint label+  -> LiftedPoint label+  -> Either (RegularTopologyError label) (GeneratorRegularTopology label)+collinearSlopeTopology points firstPoint secondPoint = do+  let direction = slopeDifference firstPoint secondPoint+      ordered = List.sortOn (slopeParameter direction) (NonEmpty.toList points)+      visibleList = upperSlopeChain direction ordered+      visible = Set.fromList visibleList+      lowerDimensional =+        Set.difference+          (upperChainPointSet direction visibleList ordered)+          visible+  edges <- traverse fullLineEdge (consecutivePairs visibleList)+  pure (topologyFromParts points visible lowerDimensional [] edges)++slopeDifference+  :: LiftedPoint label+  -> LiftedPoint label+  -> (ExactRational, ExactRational)+slopeDifference firstPoint secondPoint =+  let (firstX, firstY, _) = liftedCoordinates firstPoint+      (secondX, secondY, _) = liftedCoordinates secondPoint+   in (secondX - firstX, secondY - firstY)++slopeParameter+  :: (ExactRational, ExactRational)+  -> LiftedPoint label+  -> ExactRational+slopeParameter (directionX, directionY) point =+  let (coordinateX, coordinateY, _) = liftedCoordinates point+   in directionX * coordinateX + directionY * coordinateY++upperSlopeChain+  :: (ExactRational, ExactRational)+  -> [LiftedPoint label]+  -> [LiftedPoint label]+upperSlopeChain direction = reverse . List.foldl' insertUpper []+ where+  insertUpper+    :: [LiftedPoint label]+    -> LiftedPoint label+    -> [LiftedPoint label]+  insertUpper (secondPoint : firstPoint : remaining) candidate+    | slopeChainTurn direction firstPoint secondPoint candidate >= 0 =+        insertUpper (firstPoint : remaining) candidate+  insertUpper retained candidate = candidate : retained++slopeChainTurn+  :: (ExactRational, ExactRational)+  -> LiftedPoint label+  -> LiftedPoint label+  -> LiftedPoint label+  -> ExactRational+slopeChainTurn direction firstPoint secondPoint thirdPoint =+  let firstT = slopeParameter direction firstPoint+      secondT = slopeParameter direction secondPoint+      thirdT = slopeParameter direction thirdPoint+      (_, _, firstConstant) = liftedCoordinates firstPoint+      (_, _, secondConstant) = liftedCoordinates secondPoint+      (_, _, thirdConstant) = liftedCoordinates thirdPoint+   in (secondT - firstT) * (thirdConstant - firstConstant)+        - (secondConstant - firstConstant) * (thirdT - firstT)++upperChainPointSet+  :: (ExactRational, ExactRational)+  -> [LiftedPoint label]+  -> [LiftedPoint label]+  -> Set (LiftedPoint label)+upperChainPointSet direction chain =+  snd+    . List.foldl'+        classifyPoint+        (consecutivePairs chain, Set.empty)+ where+  classifyPoint+    :: ([(LiftedPoint label, LiftedPoint label)], Set (LiftedPoint label))+    -> LiftedPoint label+    -> ([(LiftedPoint label, LiftedPoint label)], Set (LiftedPoint label))+  classifyPoint (remainingEdges, members) point =+    let pointParameter = slopeParameter direction point+        candidateEdges =+          List.dropWhile+            ((< pointParameter) . slopeParameter direction . snd)+            remainingEdges+        retainedMembers =+          case candidateEdges of+            (firstPoint, secondPoint) : _+              | slopeParameter direction firstPoint <= pointParameter+                  && slopeChainTurn direction firstPoint secondPoint point == 0 ->+                  Set.insert point members+            _ -> members+     in (candidateEdges, retainedMembers)++fullLineEdge+  :: (LiftedPoint label, LiftedPoint label)+  -> Either (RegularTopologyError label) (GeneratorRegularEdge label)+fullLineEdge (firstPoint, secondPoint) = do+  axis <- generatorAxis firstPoint secondPoint+  pure (regularEdge firstPoint secondPoint (GeneratorDualLine axis))++topologyFromHullFaces+  :: [(HullFace label, ExactPoint)]+  -> Either+      (RegularTopologyError label)+      ([GeneratorRegularFace label], [GeneratorRegularEdge label])+topologyFromHullFaces dualFaces = do+  let dualByFace = IntMap.fromList [(hullFaceId face, dual) | (face, dual) <- dualFaces]+      edgeIncidence =+        List.foldl'+          (\incidence (face, _) ->+             List.foldl'+               (\current (firstPoint, secondPoint, thirdPoint) ->+                  Map.insertWith+                    (<>)+                    (hullEdgeKey firstPoint secondPoint)+                    ((face, firstPoint, secondPoint, thirdPoint) :| [])+                    current)+               incidence+               (faceEdgesWithOpposite face))+          Map.empty+          dualFaces+  edges <- traverse (dualEdge dualByFace) (Map.elems edgeIncidence)+  pure+    ( [ GeneratorRegularFace+          (pointLabel (hullFaceFirst face))+          (pointLabel (hullFaceSecond face))+          (pointLabel (hullFaceThird face))+          dual+      | (face, dual) <- dualFaces+      ]+    , edges+    )++hullFaceDual+  :: HullFace label+  -> Either (RegularTopologyError label) (HullFace label, ExactPoint)+hullFaceDual face = do+  let firstPoint = hullFaceFirst face+      secondPoint = hullFaceSecond face+      thirdPoint = hullFaceThird face+  dual <-+    exactGeneratorFaceDual+      (liftedPointGenerator firstPoint)+      (liftedPointGenerator secondPoint)+      (liftedPointGenerator thirdPoint)+  pure (face, dual)++faceEdgesWithOpposite+  :: HullFace label+  -> [(LiftedPoint label, LiftedPoint label, LiftedPoint label)]+faceEdgesWithOpposite face =+  [ (hullFaceFirst face, hullFaceSecond face, hullFaceThird face)+  , (hullFaceSecond face, hullFaceThird face, hullFaceFirst face)+  , (hullFaceThird face, hullFaceFirst face, hullFaceSecond face)+  ]++dualEdge+  :: IntMap.IntMap ExactPoint+  -> NonEmpty (HullFace label, LiftedPoint label, LiftedPoint label, LiftedPoint label)+  -> Either (RegularTopologyError label) (GeneratorRegularEdge label)+dualEdge dualByFace incidences =+  case incidences of+    (face, firstPoint, secondPoint, thirdPoint) :| [] -> do+      dual <-+        maybe+          (Left (RegularTopologyFlatBoundary (pointLabel firstPoint) (pointLabel secondPoint) (pointLabel thirdPoint)))+          Right+          (IntMap.lookup (hullFaceId face) dualByFace)+      ray <- boundaryDualRay dual firstPoint secondPoint thirdPoint+      pure (regularEdge firstPoint secondPoint (GeneratorDualRay ray))+    (firstFace, firstPoint, secondPoint, _) :| [(secondFace, _, _, _)] -> do+        firstDual <- requiredDual firstPoint secondPoint firstFace+        secondDual <- requiredDual firstPoint secondPoint secondFace+        dual <-+          exactGeneratorDualBetween+            (pointLabel firstPoint)+            (pointLabel secondPoint)+            firstDual+            secondDual+        pure (regularEdge firstPoint secondPoint dual)+    (_, firstPoint, secondPoint, _) :| _ ->+      Left+        ( RegularTopologyNonManifoldEdge+            (pointLabel firstPoint)+            (pointLabel secondPoint)+            (NonEmpty.length incidences)+        )+ where+  requiredDual+    :: LiftedPoint label+    -> LiftedPoint label+    -> HullFace label+    -> Either (RegularTopologyError label) ExactPoint+  requiredDual firstPoint secondPoint face =+    maybe+      (Left (RegularTopologyFlatBoundary (pointLabel firstPoint) (pointLabel secondPoint) (pointLabel (hullFaceThird face))))+      Right+      (IntMap.lookup (hullFaceId face) dualByFace)++boundaryDualRay+  :: ExactPoint+  -> LiftedPoint label+  -> LiftedPoint label+  -> LiftedPoint label+  -> Either (RegularTopologyError label) ExactRay+boundaryDualRay originPoint firstPoint secondPoint thirdPoint = do+  exactGeneratorBoundaryDualRay+    originPoint+    (liftedPointGenerator firstPoint)+    (liftedPointGenerator secondPoint)+    (liftedPointGenerator thirdPoint)++generatorAxis+  :: LiftedPoint label+  -> LiftedPoint label+  -> Either (RegularTopologyError label) ExactAffineLine+generatorAxis firstPoint secondPoint =+  first+    (RegularTopologyAxisInvalid (pointLabel firstPoint) (pointLabel secondPoint))+    (exactGeneratorAxis (liftedPointGenerator firstPoint) (liftedPointGenerator secondPoint))++regularEdge+  :: LiftedPoint label+  -> LiftedPoint label+  -> GeneratorDualGeometry+  -> GeneratorRegularEdge label+regularEdge firstPoint secondPoint dual =+  if liftedPointId firstPoint <= liftedPointId secondPoint+    then GeneratorRegularEdge (liftedPointGenerator firstPoint) (liftedPointGenerator secondPoint) dual+    else GeneratorRegularEdge (liftedPointGenerator secondPoint) (liftedPointGenerator firstPoint) dual++pointLabel :: LiftedPoint label -> label+pointLabel = exactPowerGeneratorLabel . liftedPointGenerator++topologyFromParts+  :: NonEmpty (LiftedPoint label)+  -> Set (LiftedPoint label)+  -> Set (LiftedPoint label)+  -> [GeneratorRegularFace label]+  -> [GeneratorRegularEdge label]+  -> GeneratorRegularTopology label+topologyFromParts points visible lowerDimensional faces edges =+  let dispositions =+        fmap+          (\point ->+             ( liftedPointGenerator point+             , if Set.member point visible+                 then RegularGeneratorVisible+                 else+                   if Set.member point lowerDimensional+                     then RegularGeneratorLowerDimensional+                     else RegularGeneratorHidden+             ))+          points+      visibleCount = Set.size visible+      lowerCount = Set.size lowerDimensional+      inputCount = NonEmpty.length points+   in GeneratorRegularTopology+        { generatorRegularDispositions = dispositions+        , generatorRegularFaces = faces+        , generatorRegularEdges = edges+        , generatorRegularReceipt =+            GeneratorRegularReceipt+              { generatorRegularInputSites = inputCount+              , generatorRegularVisibleSites = visibleCount+              , generatorRegularLowerDimensionalSites = lowerCount+              , generatorRegularHiddenSites = inputCount - visibleCount - lowerCount+              , generatorRegularFaceCount = length faces+              , generatorRegularEdgeCount = length edges+              }+        }
+ src-public/Moonlight/Triangulation/Internal/PowerDiagram/Locality.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE BangPatterns #-}++-- | The discardable hidden-support index and exact face walk for one regular section.+module Moonlight.Triangulation.Internal.PowerDiagram.Locality where++import qualified Data.Foldable as Foldable+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import qualified Data.Set as Set+import Data.Set (Set)+import Moonlight.Triangulation.Exact+  ( ExactPoint+  , exactOrient2d+  , exactPoint+  )+import Moonlight.Triangulation.Internal.BoundaryCycle (orderedPair)+import Moonlight.Triangulation.Internal.ExactRational (ExactRational)+import Moonlight.Triangulation.Internal.PowerDiagram.Generator+  ( ExactPowerGenerator+  )+import Moonlight.Triangulation.Internal.PowerDiagram.Model++patchRegularLocality+  :: Ord label+  => RegularLocality label+  -> Set (RegularFaceKey label)+  -> Set label+  -> RegularSection label+  -> Either (LocalRegularEditObstruction label) (RegularLocality label)+patchRegularLocality locality removedFaces hiddenToAttach section = do+  seed <-+    case Map.lookupMin (sectionRegularFaces section) of+      Nothing -> Left LocalRegularLocalityUnavailable+      Just (minimumFace, _) ->+        Right+          ( if Map.member (localityFaceSeed locality) (sectionRegularFaces section)+              then localityFaceSeed locality+              else minimumFace+          )+  let detachedForFaces =+        Set.unions+          [ Map.findWithDefault Set.empty faceKey (localitySupportHidden locality)+          | faceKey <- Set.toAscList removedFaces+          ]+      detachedLabels = Set.union detachedForFaces hiddenToAttach+      detached = Set.foldl' (flip detachRegularHidden) locality detachedLabels+  attachments <-+    traverse+      (locateHiddenSupport seed section)+      (Set.toAscList hiddenToAttach)+  pure+    ( Foldable.foldl'+        (\current (label, faceKey) -> attachRegularHidden label faceKey current)+        detached{localityFaceSeed = seed}+        attachments+    )++locateHiddenSupport+  :: Ord label+  => RegularFaceKey label+  -> RegularSection label+  -> label+  -> Either (LocalRegularEditObstruction label) (label, RegularFaceKey label)+locateHiddenSupport seed section label = do+  generator <- requireGeneratorFromMap (sectionGenerators section) label+  location <-+    maybe (Left LocalRegularSlopeLocationFailed) Right+      (locateRegularSlope seed section generator)+  case location of+    RegularSlopeInside faceKey -> Right (label, faceKey)+    RegularSlopeOutside edgeKey -> Left (LocalRegularSlopeOutside edgeKey)++attachRegularHidden+  :: Ord label+  => label+  -> RegularFaceKey label+  -> RegularLocality label+  -> RegularLocality label+attachRegularHidden label faceKey locality =+  locality+    { localityHiddenSupport = Map.insert label faceKey (localityHiddenSupport locality)+    , localitySupportHidden =+        Map.insertWith Set.union faceKey (Set.singleton label) (localitySupportHidden locality)+    }++detachRegularHidden+  :: Ord label+  => label+  -> RegularLocality label+  -> RegularLocality label+detachRegularHidden label locality =+  case Map.lookup label (localityHiddenSupport locality) of+    Nothing -> locality+    Just faceKey ->+      locality+        { localityHiddenSupport = Map.delete label (localityHiddenSupport locality)+        , localitySupportHidden =+            Map.update+              (\labels ->+                 let retained = Set.delete label labels+                  in if Set.null retained then Nothing else Just retained)+              faceKey+              (localitySupportHidden locality)+        }++buildRegularLocality+  :: Ord label+  => RegularSection label+  -> Maybe (RegularLocality label)+buildRegularLocality section = do+  (seed, _) <- Map.lookupMin (sectionRegularFaces section)+  Foldable.foldlM+    (attachHiddenGenerator section)+    RegularLocality+      { localityFaceSeed = seed+      , localityHiddenSupport = Map.empty+      , localitySupportHidden = Map.empty+      }+    [ label+    | (_, label) <- Map.toAscList (sectionSlopeRepresentatives section)+    , Map.lookup label (sectionRegularDispositions section)+        == Just RegularSiteHidden+    ]++attachHiddenGenerator+  :: Ord label+  => RegularSection label+  -> RegularLocality label+  -> label+  -> Maybe (RegularLocality label)+attachHiddenGenerator section locality label = do+  generator <- Map.lookup label (sectionGenerators section)+  location <- locateRegularSlope (localityFaceSeed locality) section generator+  case location of+    RegularSlopeInside faceKey ->+      Just+        (attachRegularHidden label faceKey locality)+          { localityFaceSeed = faceKey+          }+    RegularSlopeOutside _ -> Nothing++locateRegularSlope+  :: Ord label+  => RegularFaceKey label+  -> RegularSection label+  -> ExactPowerGenerator label+  -> Maybe (RegularSlopeLocation label)+locateRegularSlope seed section generator =+  descendRegularSlope+    (exactPoint queryX queryY)+    section+    (Map.size (sectionRegularFaces section) + 1)+    seed+ where+  (queryX, queryY) = exactGeneratorSlope generator++descendRegularSlope+  :: Ord label+  => ExactPoint+  -> RegularSection label+  -> Int+  -> RegularFaceKey label+  -> Maybe (RegularSlopeLocation label)+descendRegularSlope query section !remaining faceKey+  | remaining <= 0 = Nothing+  | otherwise = do+      face <- Map.lookup faceKey (sectionRegularFaces section)+      case firstExteriorFaceEdge query section face of+        Nothing -> Just (RegularSlopeInside faceKey)+        Just edgeKey -> do+          edgeSection <- Map.lookup edgeKey (sectionRegularEdges section)+          case Set.lookupMin (Set.delete faceKey (sectionRegularEdgeFaces edgeSection)) of+            Just adjacent ->+              descendRegularSlope query section (remaining - 1) adjacent+            Nothing -> Just (RegularSlopeOutside edgeKey)++firstExteriorFaceEdge+  :: Ord label+  => ExactPoint+  -> RegularSection label+  -> RegularFace label+  -> Maybe (RegularEdgeKey label)+firstExteriorFaceEdge query section face =+  fmap+    (uncurry orderedPair)+    ( List.find+        (faceEdgeExcludes query section)+        (regularFaceDirectedEdgeKeys face)+    )++faceEdgeExcludes+  :: Ord label+  => ExactPoint+  -> RegularSection label+  -> RegularEdgeKey label+  -> Bool+faceEdgeExcludes query section (fromLabel, toLabel) =+  generatorEdgeExcludes+    query+    (sectionGenerators section)+    (fromLabel, toLabel)++generatorEdgeExcludes+  :: Ord label+  => ExactPoint+  -> Map label (ExactPowerGenerator label)+  -> RegularEdgeKey label+  -> Bool+generatorEdgeExcludes query generators (fromLabel, toLabel) =+  case (Map.lookup fromLabel generators, Map.lookup toLabel generators) of+    (Just fromGenerator, Just toGenerator) ->+      exactOrient2d+        (uncurry exactPoint (exactGeneratorSlope fromGenerator))+        (uncurry exactPoint (exactGeneratorSlope toGenerator))+        query+        == LT+    _ -> False++generatorEdgeExcludesScaled+  :: Ord label+  => ExactRational+  -> (ExactRational, ExactRational)+  -> Map label (ExactPowerGenerator label)+  -> RegularEdgeKey label+  -> Bool+generatorEdgeExcludesScaled scale (queryX, queryY) generators (fromLabel, toLabel) =+  case (Map.lookup fromLabel generators, Map.lookup toLabel generators) of+    (Just fromGenerator, Just toGenerator) ->+      let (fromX, fromY) = exactGeneratorSlope fromGenerator+          (toX, toY) = exactGeneratorSlope toGenerator+       in (toX - fromX) * (queryY - scale * fromY)+            - (toY - fromY) * (queryX - scale * fromX)+            < 0+    _ -> False
+ src-public/Moonlight/Triangulation/Internal/PowerDiagram/Model.hs view
@@ -0,0 +1,558 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Shared opaque carriers for exact power topology. This module owns+-- representation only; construction and interpretation live in sibling modules.+module Moonlight.Triangulation.Internal.PowerDiagram.Model where++import Control.DeepSeq (NFData)+import Data.Bifunctor (first)+import Data.List.NonEmpty (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 Vector+import GHC.Generics (Generic)+import Moonlight.Triangulation.Exact+  ( ExactAffineLine+  , ExactClipError+  , ExactHalfPlaneError+  , ExactPoint+  , ExactRay+  , ExactSegment+  , exactPointFromQueryPoint+  )+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactRational+  , exactRationalFromFiniteDouble+  )+import Moonlight.Triangulation.Internal.BoundaryCycle (orderedPair)+import Moonlight.Triangulation.Internal.PowerDiagram.Generator+  ( ExactPowerGenerator (..)+  , GeneratorRegularReceipt+  , GeneratorRegularTopology+  , RegularTopologyError+  )+import Moonlight.Triangulation.Math (mkQueryPoint)+import Moonlight.Triangulation.Minkowski (ConvexPolygon, MinkowskiError)+import Moonlight.Triangulation.Internal.Overlay.Types (OverlayError)+import Moonlight.Triangulation.Types+  ( NonFiniteValue+  , Point+  , PointValidationError+  , QueryPoint+  , classifyNonFinite+  , queryPointValue+  )++-- | An admitted signed additive power offset.  Power distance is+-- @||x-p||^2-w@, so negative values are lawful and this is deliberately not a+-- squared-radius refinement.+newtype PowerWeight = PowerWeight ExactRational+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | The sole obstruction to admitting a signed binary64 power offset.+data PowerWeightError+  = PowerWeightNonFinite !NonFiniteValue+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Admit a finite binary64 power offset exactly.+powerWeight :: Double -> Either PowerWeightError PowerWeight+powerWeight value =+  case classifyNonFinite value of+    Just obstruction -> Left (PowerWeightNonFinite obstruction)+    Nothing -> Right (PowerWeight (exactRationalFromFiniteDouble value))++-- | Admit an already-exact signed power offset without a binary64 round trip.+powerWeightFromExact :: ExactRational -> PowerWeight+powerWeightFromExact = PowerWeight++-- | Exact rational value of an admitted power offset.+powerWeightExact :: PowerWeight -> ExactRational+powerWeightExact (PowerWeight value) = value++-- | One labelled, admitted weighted site.  Construction validates and+-- canonicalizes the binary64 position once.+data PowerSite label = PowerSite+  { powerSiteLabel :: !label+    -- ^ Stable identity used by edits and canonical topology.+  , powerSiteQueryPoint :: !QueryPoint+  , powerSiteWeight :: !PowerWeight+    -- ^ Signed additive power offset.+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Admit one stable-labelled site at a finite position.+powerSite+  :: label+  -> Point+  -> PowerWeight+  -> Either (PowerDiagramError label) (PowerSite label)+powerSite label point weight =+  PowerSite label <$> first (PowerSitePositionInvalid label) (mkQueryPoint point) <*> pure weight++-- | Binary64 position originally admitted for the site.+powerSitePosition :: PowerSite label -> Point+powerSitePosition = queryPointValue . powerSiteQueryPoint++-- | Exact coordinates retained by an admitted site.+powerSiteExactPosition :: PowerSite label -> ExactPoint+powerSiteExactPosition = exactPointFromQueryPoint . powerSiteQueryPoint++-- | Exactly one authoritative result for each submitted label.+data PowerCellDisposition label+  = PublishedPowerCell !ConvexPolygon+  | LowerDimensionalPowerCell !(NonEmpty ExactPoint)+  | EmptyPowerCell+  | CoincidentEquivalentTo !label+  | CoincidentDominatedBy !label+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Visibility of one submitted label in the exact regular subdivision.+data RegularSiteDisposition label+  = RegularSiteVisible+  | RegularSiteLowerDimensional+  | RegularSiteHidden+  | RegularSiteCoincidentEquivalentTo !label+  | RegularSiteCoincidentDominatedBy !label+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | One oriented regular face and its exact weighted-dual vertex.+data RegularFace label = RegularFace !label !label !label !ExactPoint+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Canonically oriented labels of the face.+regularFaceLabels :: RegularFace label -> (label, label, label)+regularFaceLabels (RegularFace firstLabel secondLabel thirdLabel _) =+  (firstLabel, secondLabel, thirdLabel)++-- | Exact power vertex dual to the face.+regularFaceDualPoint :: RegularFace label -> ExactPoint+regularFaceDualPoint (RegularFace _ _ _ dualPoint) = dualPoint++-- | Exact weighted Voronoi geometry dual to one regular edge.+data PowerDualEdge+  = BoundedPowerDual !ExactSegment+  | UnboundedPowerDual !ExactRay+  | FullLinePowerDual !ExactAffineLine+  | CollapsedPowerDual !ExactPoint+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | One unordered regular edge and its exact dual geometry.+data RegularEdge label = RegularEdge !label !label !PowerDualEdge+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Ascending endpoint labels of the unordered edge.+regularEdgeLabels :: RegularEdge label -> (label, label)+regularEdgeLabels (RegularEdge firstLabel secondLabel _) =+  (firstLabel, secondLabel)++-- | Exact power-dual carrier of the edge.+regularEdgeDual :: RegularEdge label -> PowerDualEdge+regularEdgeDual (RegularEdge _ _ dual) = dual++type RegularFaceKey label = (label, label, label)+type RegularEdgeKey label = (label, label)++data RegularEdgeSection label = RegularEdgeSection+  { sectionRegularEdge :: !(RegularEdge label)+  , sectionRegularEdgeFaces :: !(Set (RegularFaceKey label))+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data RegularSiteStar label = RegularSiteStar+  { sectionIncidentFaces :: !(Set (RegularFaceKey label))+  , sectionSiteNeighbours :: !(Set label)+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data RegularLocality label = RegularLocality+  { localityFaceSeed :: !(RegularFaceKey label)+  , localityHiddenSupport :: !(Map label (RegularFaceKey label))+  , localitySupportHidden :: !(Map (RegularFaceKey label) (Set label))+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++data RegularSlopeLocation label+  = RegularSlopeInside !(RegularFaceKey label)+  | RegularSlopeOutside !(RegularEdgeKey label)++data LocalRegularEditObstruction label+  = LocalRegularSectionUnavailable+  | LocalRegularLocalityUnavailable+  | LocalRegularSlopeCoincidence !label+  | LocalRegularSlopeOutside !(RegularEdgeKey label)+  | LocalRegularSlopeLocationFailed+  | LocalRegularDegenerateFace !(RegularFaceKey label)+  | LocalRegularFaceMissing !(RegularFaceKey label)+  | LocalRegularGeneratorMissing !label+  | LocalRegularNonManifoldEdge !(RegularEdgeKey label) !Int+  | LocalRegularNonConvexEdge !(RegularEdgeKey label)+  | LocalRegularEmptyHorizon+  | LocalRegularBoundaryRemoval !label+  | LocalRegularCandidateSectionEmpty+  | LocalRegularCavityBoundaryMismatch+  | LocalRegularTopologyObstruction !(RegularTopologyError label)++data RegularConflictDescent label = RegularConflictDescent+  { conflictPendingFaces :: !(Set (RegularFaceKey label))+  , conflictVisitedFaces :: !(Set (RegularFaceKey label))+  , conflictVisibleFaces :: !(Set (RegularFaceKey label))+  , conflictObstruction :: !(Maybe (LocalRegularEditObstruction label))+  }++data RegularFacePatch label = RegularFacePatch+  { patchedRegularFaces :: !(Map (RegularFaceKey label) (RegularFace label))+  , patchedRegularEdges :: !(Map (RegularEdgeKey label) (RegularEdgeSection label))+  , patchedRegularStars :: !(Map label (RegularSiteStar label))+  , patchedRegularLabels :: !(Set label)+  , patchedRegularTouchedEdges :: !(Set (RegularEdgeKey label))+  }++data RegularSection label = RegularSection+  { sectionGenerators :: !(Map label (ExactPowerGenerator label))+  , sectionSlopeRepresentatives :: !(Map (ExactRational, ExactRational) label)+  , sectionCoincidentDispositions :: !(Map label (CoincidentGeneratorDisposition label))+  , sectionRegularDispositions :: !(Map label (RegularSiteDisposition label))+  , sectionRegularFaces :: !(Map (RegularFaceKey label) (RegularFace label))+  , sectionRegularEdges :: !(Map (RegularEdgeKey label) (RegularEdgeSection label))+  , sectionRegularStars :: !(Map label (RegularSiteStar label))+  , sectionRegularReceipt :: !GeneratorRegularReceipt+  , sectionRegularLocality :: !(Maybe (RegularLocality label))+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Exact regular subdivision. Every weighted site remains resident in this+-- opaque value; one normalized section owns all derived topology and incidence.+data RegularTriangulation label = RegularTriangulation+  { storedRegularSites :: !(Map label (PowerSite label))+  , storedRegularSection :: !(Maybe (RegularSection label))+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++-- | Semantic equality is equality of the complete weighted-site section.+-- Topology and visibility are sealed derived caches of that section.+instance Eq label => Eq (RegularTriangulation label) where+  left == right = storedRegularSites left == storedRegularSites right++instance Show label => Show (RegularTriangulation label) where+  showsPrec precedence triangulation =+    showParen (precedence > 10)+      ( showString "RegularTriangulation "+          . shows (storedRegularSites triangulation)+      )++-- | Strict cardinality receipt for one normalized regular section.+data RegularTriangulationReceipt = RegularTriangulationReceipt+  { regularTriangulationInputSites :: !Int+  , regularTriangulationRepresentativeSites :: !Int+  , regularTriangulationVisibleSites :: !Int+  , regularTriangulationLowerDimensionalSites :: !Int+  , regularTriangulationHiddenSites :: !Int+  , regularTriangulationCoincidentSites :: !Int+  , regularTriangulationFaces :: !Int+  , regularTriangulationEdges :: !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | One exact change in the exhaustive visibility section. Appearance and+-- disappearance are explicit rather than encoded with sentinel dispositions.+data RegularSiteTransition label+  = RegularSiteAppeared !label !(RegularSiteDisposition label)+  | RegularSiteDisappeared !label !(RegularSiteDisposition label)+  | RegularSiteTransitioned+      !label+      !(RegularSiteDisposition label)+      !(RegularSiteDisposition label)+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | A regular edit either conflicts with an existing stable identity, names+-- absent patch identities, or carries the exact normalization obstruction.+data RegularEditError label+  = RegularEditSiteConflict+      !label+      !(PowerSite label)+      !(PowerSite label)+  | RegularEditUnknownSites !(NonEmpty label)+  | RegularEditTopologyFailed !(RegularTopologyError label)+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | One common publication for every pure regular-site edit. The changed-site+-- support is empty precisely for an idempotent edit.+data RegularEditResult label = RegularEditResult+  { regularEditTriangulation :: !(RegularTriangulation label)+  , regularEditChangedSites :: !(Set label)+  , regularEditTransitions :: !(Vector.Vector (RegularSiteTransition label))+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Total labelled result, opaque so callers cannot omit a submitted label.+newtype BoundedPowerDiagram label =+  BoundedPowerDiagram (Map label (PowerCellDisposition label))+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Typed admission, topology, and clipping obstructions.+data PowerDiagramError label+  = PowerSitePositionInvalid !label !PointValidationError+  | DuplicatePowerSiteLabel !label+  | PowerDomainInvalid !ExactHalfPlaneError+  | PowerBisectorInvalid !label !label !ExactHalfPlaneError+  | PowerRegularTopologyFailed !(RegularTopologyError label)+  | PowerRegularDispositionMissing !label+  | PowerRegularGeneratorMissing !label+  | PowerCellClipFailed !label !ExactClipError+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Exact construction counts and rational-width evidence for a bounded diagram.+data PowerDiagramReceipt = PowerDiagramReceipt+  { powerDiagramDomainVertices :: !Int+  , powerDiagramSubmittedSiteConstraints :: !Int+  , powerDiagramActiveBoundaries :: !Int+  , powerDiagramBoundaryCompatibilityChecks :: !Int+  , powerDiagramExactIntersections :: !Int+  , powerDiagramPublishedCells :: !Int+  , powerDiagramLowerDimensionalCells :: !Int+  , powerDiagramEmptyCells :: !Int+  , powerDiagramCoincidentEquivalentCells :: !Int+  , powerDiagramCoincidentDominatedCells :: !Int+  , powerDiagramRegularFaces :: !Int+  , powerDiagramRegularEdges :: !Int+  , powerDiagramOracleCells :: !Int+  , powerDiagramMaximumCellConstraints :: !Int+  , powerDiagramMaximumInputBits :: !Int+  , powerDiagramMaximumAffineCoefficientBits :: !Int+  , powerDiagramPeakIntermediateCoordinateBits :: !Int+  , powerDiagramFinalCoordinateBits :: !Int+  , powerDiagramFinalDenominatorBits :: !Int+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Submitted sites, derived from the exhaustive disposition partition.+powerDiagramInputSites :: PowerDiagramReceipt -> Int+powerDiagramInputSites receipt =+  powerDiagramPublishedCells receipt+    + powerDiagramLowerDimensionalCells receipt+    + powerDiagramEmptyCells receipt+    + powerDiagramCoincidentEquivalentCells receipt+    + powerDiagramCoincidentDominatedCells receipt+{-# INLINE powerDiagramInputSites #-}++-- | Peak exact-coordinate width beyond the widest admitted input.+powerDiagramPeakIntermediateBitGrowth :: PowerDiagramReceipt -> Int+powerDiagramPeakIntermediateBitGrowth receipt =+  max+    0+    ( powerDiagramPeakIntermediateCoordinateBits receipt+        - powerDiagramMaximumInputBits receipt+    )+{-# INLINE powerDiagramPeakIntermediateBitGrowth #-}++-- | Published coordinate width beyond the widest admitted input.+powerDiagramFinalCoordinateBitGrowth :: PowerDiagramReceipt -> Int+powerDiagramFinalCoordinateBitGrowth receipt =+  max+    0+    ( powerDiagramFinalCoordinateBits receipt+        - powerDiagramMaximumInputBits receipt+    )+{-# INLINE powerDiagramFinalCoordinateBitGrowth #-}++-- | One exact affine form @c0 + cx*x + cy*y@.+data AffineForm = AffineForm+  { affineFormConstant :: !ExactRational+  , affineFormXCoefficient :: !ExactRational+  , affineFormYCoefficient :: !ExactRational+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Typed obstructions from exact affine argmax decomposition.  Power-cell+-- construction remains the canonical geometric owner; window restriction is+-- the only additional boundary.+data UpperEnvelopeError label+  = UpperEnvelopeEmptyForms+  | UpperEnvelopeWindowHullFailed !MinkowskiError+  | UpperEnvelopePowerConstructionFailed !(PowerDiagramError label)+  | UpperEnvelopeWindowOverlayFailed !(OverlayError (Maybe label) Bool)+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)+++data CoincidentGeneratorDisposition label+  = CoincidentGeneratorEquivalentTo !label+  | CoincidentGeneratorDominatedBy !label+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++data ResolvedGeneratorSection label = ResolvedGeneratorSection+  { resolvedCoincidentDispositions :: !(Map label (CoincidentGeneratorDisposition label))+  , resolvedRegularTopology :: !(GeneratorRegularTopology label)+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++foldRegularFaceBoundary+  :: (label -> label -> label -> result -> result)+  -> result+  -> RegularFace label+  -> result+foldRegularFaceBoundary step initial face =+  let (firstLabel, secondLabel, thirdLabel) = regularFaceLabels face+   in step firstLabel secondLabel thirdLabel+        ( step secondLabel thirdLabel firstLabel+            (step thirdLabel firstLabel secondLabel initial)+        )+{-# INLINE foldRegularFaceBoundary #-}++regularFaceDirectedEdgeKeys :: RegularFace label -> [RegularEdgeKey label]+regularFaceDirectedEdgeKeys =+  foldRegularFaceBoundary+    (\fromLabel toLabel _ -> ((fromLabel, toLabel) :))+    []++regularFaceCanonicalEdgeKeys+  :: Ord label+  => RegularFace label+  -> [RegularEdgeKey label]+regularFaceCanonicalEdgeKeys =+  foldRegularFaceBoundary+    (\fromLabel toLabel _ -> (orderedPair fromLabel toLabel :))+    []++regularFaceLabelSet :: Ord label => RegularFace label -> Set label+regularFaceLabelSet =+  foldRegularFaceBoundary (\label _ _ -> Set.insert label) Set.empty++requireFaceEdgeWitness+  :: Ord label+  => RegularEdgeKey label+  -> RegularFace label+  -> Either (LocalRegularEditObstruction label) (label, label, label)+requireFaceEdgeWitness edgeKey face =+  maybe+    (Left (LocalRegularFaceMissing (regularFaceKey face)))+    Right+    ( foldRegularFaceBoundary+        (\fromLabel toLabel oppositeLabel later ->+            if orderedPair fromLabel toLabel == edgeKey+              then Just (fromLabel, toLabel, oppositeLabel)+              else later)+        Nothing+        face+    )++regularFaceKey :: Ord label => RegularFace label -> RegularFaceKey label+regularFaceKey face =+  let (firstLabel, secondLabel, thirdLabel) = regularFaceLabels face+   in sortedRegularFaceLabels firstLabel secondLabel thirdLabel++sortedRegularFaceLabels+  :: Ord label+  => label+  -> label+  -> label+  -> RegularFaceKey label+sortedRegularFaceLabels firstLabel secondLabel thirdLabel =+  let (firstLow, firstHigh) = orderedPair firstLabel secondLabel+      (secondLow, finalHigh) = orderedPair firstHigh thirdLabel+      (finalLow, finalMiddle) = orderedPair firstLow secondLow+   in (finalLow, finalMiddle, finalHigh)++regularEdgeKey :: Ord label => RegularEdge label -> RegularEdgeKey label+regularEdgeKey = uncurry orderedPair . regularEdgeLabels++regularFaceEdgeIncidence+  :: Ord label+  => RegularFace label+  -> Map (RegularEdgeKey label) (Set (RegularFaceKey label))+regularFaceEdgeIncidence face =+  let incidentFace = Set.singleton (regularFaceKey face)+   in foldRegularFaceBoundary+        (\fromLabel toLabel _ ->+            Map.insert (orderedPair fromLabel toLabel) incidentFace)+        Map.empty+        face++emptyRegularSiteStar :: RegularSiteStar label+emptyRegularSiteStar = RegularSiteStar Set.empty Set.empty++requireFaceFromMap+  :: Ord label+  => Map (RegularFaceKey label) (RegularFace label)+  -> RegularFaceKey label+  -> Either (LocalRegularEditObstruction label) (RegularFace label)+requireFaceFromMap faces faceKey =+  maybe (Left (LocalRegularFaceMissing faceKey)) Right (Map.lookup faceKey faces)++requireGeneratorFromMap+  :: Ord label+  => Map label (ExactPowerGenerator label)+  -> label+  -> Either (LocalRegularEditObstruction label) (ExactPowerGenerator label)+requireGeneratorFromMap generators label =+  maybe (Left (LocalRegularGeneratorMissing label)) Right (Map.lookup label generators)++regularFaceNeighbours+  :: Ord label+  => RegularSection label+  -> RegularFaceKey label+  -> Either+      (LocalRegularEditObstruction label)+      (Set (RegularFaceKey label))+regularFaceNeighbours section faceKey = do+  face <- requireFaceFromMap (sectionRegularFaces section) faceKey+  incident <- traverse requireIncidence (regularFaceCanonicalEdgeKeys face)+  pure (Set.delete faceKey (Set.unions incident))+ where+  requireIncidence edgeKey =+    maybe+      (Left (LocalRegularNonManifoldEdge edgeKey 0))+      (Right . sectionRegularEdgeFaces)+      (Map.lookup edgeKey (sectionRegularEdges section))++replaceRegularSiteSection+  :: Map label (PowerSite label)+  -> RegularSection label+  -> RegularTriangulation label+  -> RegularTriangulation label+replaceRegularSiteSection sites section triangulation =+  triangulation+    { storedRegularSites = sites+    , storedRegularSection = Just section+    }++regularDispositionSection+  :: RegularTriangulation label+  -> Map label (RegularSiteDisposition label)+regularDispositionSection =+  maybe Map.empty sectionRegularDispositions . storedRegularSection++exactGeneratorSlope+  :: ExactPowerGenerator label+  -> (ExactRational, ExactRational)+exactGeneratorSlope generator =+  ( exactPowerGeneratorXCoefficient generator+  , exactPowerGeneratorYCoefficient generator+  )
+ src-public/Moonlight/Triangulation/Internal/PowerDiagram/Projection.hs view
@@ -0,0 +1,601 @@+{-# LANGUAGE BangPatterns #-}+-- | Bounded clipping and planar publication of exact regular sections.+module Moonlight.Triangulation.Internal.PowerDiagram.Projection+  ( boundedPowerDiagram+  , boundedPowerDiagramFromRegular+  , powerCellDisposition+  , powerCellDispositions+  , powerDiagramPlanarLayer+  , upperEnvelope+  ) where++import Data.Bifunctor (first)+import qualified Data.Foldable as Foldable+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.Vector as Vector+import Moonlight.Triangulation.Exact+  ( ExactClipDisposition (..)+  , ExactClipReceipt (..)+  , ExactAffineLine+  , ExactClosedHalfPlane+  , ExactRetainedPolygon+  , exactClipRetainedPolygon+  , exactClosedHalfPlane+  , exactRetainedPolygon+  , oppositeExactAffineLine+  )+import Moonlight.Triangulation.Internal.PowerDiagram.Generator+  ( ExactPowerGenerator (..)+  , GeneratorRegularEdge (..)+  , GeneratorRegularReceipt (..)+  , GeneratorRegularTopology (..)+  , RegularGeneratorDisposition (..)+  , exactGeneratorAxis+  )+import Moonlight.Triangulation.Internal.PowerDiagram.Model+import Moonlight.Triangulation.Internal.PowerDiagram.Section+import Moonlight.Triangulation.Internal.Minkowski.Convex+  ( convexHullPolygon+  , convexPolygonComponent+  , convexPolygonFromRetained+  )+import Moonlight.Triangulation.Internal.Overlay.Types+  ( OverlayCell (..)+  , OverlayCellGeometry (..)+  , OverlayResult (..)+  )+import Moonlight.Triangulation.Internal.Region.Publication+  ( planarLayerFromAdmittedComponents+  )+import Moonlight.Triangulation.Minkowski+  ( ConvexPolygon+  , convexPolygonPoints+  )+import Moonlight.Triangulation.Overlay+  ( overlayLayers )+import Moonlight.Triangulation.Region+  ( PlanarLayer+  , PolygonComponent+  , exactLoopPoints+  , polygonOuterLoop+  )++-- | Construct and clip a normalized regular subdivision to one convex domain.+boundedPowerDiagram+  :: Ord label+  => ConvexPolygon+  -> NonEmpty (PowerSite label)+  -> Either (PowerDiagramError label) (BoundedPowerDiagram label, PowerDiagramReceipt)+boundedPowerDiagram domain submitted = do+  sortedSites <- validateAndSortSites submitted+  let preparedGenerators = fmap prepareExactPowerGenerator sortedSites+      generators = fmap fst preparedGenerators+      siteInputBits =+        Foldable.foldl' (\bits preparation -> max bits (snd preparation)) 0 preparedGenerators+  (dispositions, clipReceipt, regularReceipt, maximumCellConstraints) <-+    exactGeneratorDispositionsWith (<>) mempty domain generators+  let receipt =+        aggregateReceipt+          domain+          dispositions+          siteInputBits+          clipReceipt+          regularReceipt+          maximumCellConstraints+  pure (BoundedPowerDiagram dispositions, receipt)++-- | Clip an already normalized regular value without rebuilding its lifted+-- hull. The empty regular value yields an empty labelled diagram.+boundedPowerDiagramFromRegular+  :: Ord label+  => ConvexPolygon+  -> RegularTriangulation label+  -> Either (PowerDiagramError label) (BoundedPowerDiagram label, PowerDiagramReceipt)+boundedPowerDiagramFromRegular domain triangulation =+  case storedRegularSection triangulation of+    Nothing ->+      Right+        ( BoundedPowerDiagram Map.empty+        , aggregateReceipt+            domain+            Map.empty+            0+            mempty+            emptyGeneratorRegularReceipt+            0+        )+    Just section -> do+      (dispositions, clipReceipt, generatorReceipt, maximumCellConstraints) <-+        exactRegularSectionDispositionsWith (<>) mempty domain section+      let receipt =+            aggregateReceipt+              domain+              dispositions+              (maximumPowerSiteInputBits (storedRegularSites triangulation))+              clipReceipt+              generatorReceipt+              maximumCellConstraints+      pure (BoundedPowerDiagram dispositions, receipt)++-- | Full-dimensional labelled argmax regions for affine forms+-- @c0 + cx*x + cy*y@ inside an admitted polygonal window. The result is a+-- planar projection: lower-dimensional and empty winners intentionally have+-- no region. Use 'regularTriangulation' on corresponding weighted sites when+-- those dispositions or exact unbounded duals are required. Identical forms+-- choose the least label, independent of map construction order.+upperEnvelope+  :: Ord label+  => PolygonComponent+  -> Map label AffineForm+  -> Either (UpperEnvelopeError label) (PlanarLayer (Maybe label))+upperEnvelope window forms = do+  generators <- affineFormGenerators forms+  domain <-+    first UpperEnvelopeWindowHullFailed+      (convexHullPolygon (exactLoopPoints (polygonOuterLoop window)))+  (dispositions, _, _, _) <-+    first UpperEnvelopePowerConstructionFailed+      (exactGeneratorDispositionsWith discardClipReceipt () domain generators)+  let envelopeLayer = affineDispositionLayer dispositions+  if convexPolygonComponent domain == window+    then Right envelopeLayer+    else restrictEnvelopeToWindow window envelopeLayer++-- | Look up the exhaustive bounded-cell disposition for one submitted label.+powerCellDisposition+  :: Ord label+  => label+  -> BoundedPowerDiagram label+  -> Maybe (PowerCellDisposition label)+powerCellDisposition label (BoundedPowerDiagram dispositions) =+  Map.lookup label dispositions++-- | Enumerate every submitted label and bounded-cell disposition in order.+powerCellDispositions+  :: BoundedPowerDiagram label+  -> [(label, PowerCellDisposition label)]+powerCellDispositions (BoundedPowerDiagram dispositions) = Map.toAscList dispositions++-- | Publish the full-dimensional cell layer with a canonical exterior.+powerDiagramPlanarLayer+  :: Ord label+  => BoundedPowerDiagram label+  -> PlanarLayer (Maybe label)+powerDiagramPlanarLayer (BoundedPowerDiagram dispositions) =+  affineDispositionLayer dispositions++affineDispositionLayer+  :: Ord label+  => Map label (PowerCellDisposition label)+  -> PlanarLayer (Maybe label)+affineDispositionLayer = publishedPowerLayer Nothing Just++publishedPowerLayer+  :: Ord publishedLabel+  => publishedLabel+  -> (label -> publishedLabel)+  -> Map label (PowerCellDisposition label)+  -> PlanarLayer publishedLabel+publishedPowerLayer outside publishLabel dispositions =+  planarLayerFromAdmittedComponents+    outside+    [ (publishLabel label, convexPolygonComponent polygon)+    | (label, PublishedPowerCell polygon) <- Map.toAscList dispositions+    ]++restrictEnvelopeToWindow+  :: Ord label+  => PolygonComponent+  -> PlanarLayer (Maybe label)+  -> Either (UpperEnvelopeError label) (PlanarLayer (Maybe label))+restrictEnvelopeToWindow window envelopeLayer = do+  let windowLayer = planarLayerFromAdmittedComponents False [(True, window)]+  clipped <-+    first UpperEnvelopeWindowOverlayFailed+      (overlayLayers envelopeLayer windowLayer)+  pure+    ( planarLayerFromAdmittedComponents+        Nothing+        [ (Just label, component)+        | cell <- Vector.toList (overlayResultCells clipped)+        , overlayCellRight cell+        , Just label <- [overlayCellLeft cell]+        , BoundedOverlayCell component <- [overlayCellGeometry cell]+        ]+    )+++affineFormGenerators+  :: Map label AffineForm+  -> Either (UpperEnvelopeError label) (NonEmpty (ExactPowerGenerator label))+affineFormGenerators forms =+  case Map.minViewWithKey forms of+    Nothing -> Left UpperEnvelopeEmptyForms+    Just ((firstLabel, firstForm), remaining) ->+      Right+        ( affineFormGenerator firstLabel firstForm+            :| fmap (uncurry affineFormGenerator) (Map.toAscList remaining)+        )++affineFormGenerator+  :: label+  -> AffineForm+  -> ExactPowerGenerator label+affineFormGenerator label form =+  ExactPowerGenerator+    { exactPowerGeneratorLabel = label+    , exactPowerGeneratorXCoefficient = affineFormXCoefficient form+    , exactPowerGeneratorYCoefficient = affineFormYCoefficient form+    , exactPowerGeneratorConstant = affineFormConstant form+    }++exactGeneratorDispositionsWith+  :: Ord label+  => (summary -> ExactClipReceipt -> summary)+  -> summary+  -> ConvexPolygon+  -> NonEmpty (ExactPowerGenerator label)+  -> Either+      (PowerDiagramError label)+      ( Map label (PowerCellDisposition label)+      , summary+      , GeneratorRegularReceipt+      , Int+      )+exactGeneratorDispositionsWith summarizeReceipt initialSummary domain generators = do+  section <- first PowerRegularTopologyFailed (resolvedGeneratorSection generators)+  exactResolvedGeneratorDispositionsWith+    summarizeReceipt+    initialSummary+    domain+    section++exactResolvedGeneratorDispositionsWith+  :: Ord label+  => (summary -> ExactClipReceipt -> summary)+  -> summary+  -> ConvexPolygon+  -> ResolvedGeneratorSection label+  -> Either+      (PowerDiagramError label)+      ( Map label (PowerCellDisposition label)+      , summary+      , GeneratorRegularReceipt+      , Int+      )+exactResolvedGeneratorDispositionsWith summarizeReceipt initialSummary domain section = do+  retainedDomain <-+    first PowerDomainInvalid (exactRetainedPolygon (convexPolygonPoints domain))+  let topology = resolvedRegularTopology section+  constraints <- prepareRegularConstraintSection topology+  clipped <-+    traverse+      (clipPowerCell retainedDomain section constraints)+      (generatorRegularDispositions topology)+  let (dispositions, summary, maximumCellConstraints) =+        summarizeClippedPowerCells+          summarizeReceipt+          initialSummary+          (resolvedCoincidentDispositions section)+          (NonEmpty.toList clipped)+  pure+    ( dispositions+    , summary+    , generatorRegularReceipt topology+    , maximumCellConstraints+    )++exactRegularSectionDispositionsWith+  :: Ord label+  => (summary -> ExactClipReceipt -> summary)+  -> summary+  -> ConvexPolygon+  -> RegularSection label+  -> Either+      (PowerDiagramError label)+      ( Map label (PowerCellDisposition label)+      , summary+      , GeneratorRegularReceipt+      , Int+      )+exactRegularSectionDispositionsWith summarizeReceipt initialSummary domain section = do+  retainedDomain <-+    first PowerDomainInvalid (exactRetainedPolygon (convexPolygonPoints domain))+  constraints <- preparePublishedRegularConstraints section+  representativeDispositions <-+    traverse+      (\(label, generator) -> do+         disposition <-+           maybe+             (Left (PowerRegularDispositionMissing label))+             Right+             (Map.lookup label (sectionRegularDispositions section))+         clipPublishedPowerCell+           retainedDomain+           section+           constraints+           generator+           disposition)+      (Map.toAscList (sectionGenerators section))+  let (dispositions, summary, maximumCellConstraints) =+        summarizeClippedPowerCells+          summarizeReceipt+          initialSummary+          (sectionCoincidentDispositions section)+          representativeDispositions+  pure+    ( dispositions+    , summary+    , sectionRegularReceipt section+    , maximumCellConstraints+    )++summarizeClippedPowerCells+  :: Ord label+  => (summary -> ExactClipReceipt -> summary)+  -> summary+  -> Map label (CoincidentGeneratorDisposition label)+  -> [(label, PowerCellDisposition label, ExactClipReceipt, Int)]+  -> (Map label (PowerCellDisposition label), summary, Int)+summarizeClippedPowerCells summarizeReceipt initialSummary coincident clipped =+  let (publishedAssociations, summary, maximumCellConstraints) =+        Foldable.foldl'+          (\(associations, accumulatedSummary, peak) (label, disposition, cellReceipt, cellAxes) ->+             let !combinedSummary = summarizeReceipt accumulatedSummary cellReceipt+              in ( (label, disposition) : associations+                 , combinedSummary+                 , max peak cellAxes+                 ))+          ([], initialSummary, 0)+          clipped+   in ( fmap coincidentPowerDisposition coincident+          <> Map.fromList publishedAssociations+      , summary+      , maximumCellConstraints+      )++preparePublishedRegularConstraints+  :: Ord label+  => RegularSection label+  -> Either (PowerDiagramError label) (Map label [ExactClosedHalfPlane])+preparePublishedRegularConstraints section =+  Foldable.foldlM prepare Map.empty (Map.elems (sectionRegularEdges section))+ where+  prepare constraints edgeSection = do+    let edge = sectionRegularEdge edgeSection+        (firstLabel, secondLabel) = regularEdgeLabels edge+    firstGenerator <- requireSectionGenerator section firstLabel+    secondGenerator <- requireSectionGenerator section secondLabel+    insertRegularConstraintEdge constraints firstGenerator secondGenerator++clipPublishedPowerCell+  :: Ord label+  => ExactRetainedPolygon+  -> RegularSection label+  -> Map label [ExactClosedHalfPlane]+  -> ExactPowerGenerator label+  -> RegularSiteDisposition label+  -> Either+      (PowerDiagramError label)+      (label, PowerCellDisposition label, ExactClipReceipt, Int)+clipPublishedPowerCell retainedDomain section constraints ownerGenerator disposition =+  let ownerLabel = exactPowerGeneratorLabel ownerGenerator+      competitors =+        filter+          ((/= ownerLabel) . exactPowerGeneratorLabel)+          (Map.elems (sectionGenerators section))+      clipAs =+        clipRegularGeneratorCell+          retainedDomain+          ownerGenerator+          (Map.findWithDefault [] ownerLabel constraints)+          competitors+   in case disposition of+        RegularSiteHidden -> clipAs RegularGeneratorHidden+        RegularSiteVisible -> clipAs RegularGeneratorVisible+        RegularSiteLowerDimensional -> clipAs RegularGeneratorLowerDimensional+        RegularSiteCoincidentEquivalentTo _ ->+          Left (PowerRegularDispositionMissing ownerLabel)+        RegularSiteCoincidentDominatedBy _ ->+          Left (PowerRegularDispositionMissing ownerLabel)++requireSectionGenerator+  :: Ord label+  => RegularSection label+  -> label+  -> Either (PowerDiagramError label) (ExactPowerGenerator label)+requireSectionGenerator section label =+  maybe+    (Left (PowerRegularGeneratorMissing label))+    Right+    (Map.lookup label (sectionGenerators section))++discardClipReceipt :: () -> ExactClipReceipt -> ()+discardClipReceipt _ _ = ()++prepareRadicalAxis+  :: ExactPowerGenerator label+  -> ExactPowerGenerator label+  -> Either (PowerDiagramError label) ExactAffineLine+prepareRadicalAxis firstGenerator secondGenerator =+  first+    ( PowerBisectorInvalid+        (exactPowerGeneratorLabel firstGenerator)+        (exactPowerGeneratorLabel secondGenerator)+    )+    (exactGeneratorAxis firstGenerator secondGenerator)++prepareRegularConstraintSection+  :: Ord label+  => GeneratorRegularTopology label+  -> Either (PowerDiagramError label) (Map label [ExactClosedHalfPlane])+prepareRegularConstraintSection =+  Foldable.foldlM prepareRegularConstraintEdge Map.empty . generatorRegularEdges++prepareRegularConstraintEdge+  :: Ord label+  => Map label [ExactClosedHalfPlane]+  -> GeneratorRegularEdge label+  -> Either (PowerDiagramError label) (Map label [ExactClosedHalfPlane])+prepareRegularConstraintEdge constraints edge = do+  let firstGenerator = generatorRegularEdgeFirst edge+      secondGenerator = generatorRegularEdgeSecond edge+  insertRegularConstraintEdge constraints firstGenerator secondGenerator++insertRegularConstraintEdge+  :: Ord label+  => Map label [ExactClosedHalfPlane]+  -> ExactPowerGenerator label+  -> ExactPowerGenerator label+  -> Either (PowerDiagramError label) (Map label [ExactClosedHalfPlane])+insertRegularConstraintEdge constraints firstGenerator secondGenerator = do+  let firstLabel = exactPowerGeneratorLabel firstGenerator+      secondLabel = exactPowerGeneratorLabel secondGenerator+  axis <- prepareRadicalAxis firstGenerator secondGenerator+  pure+    ( Map.insertWith (<>) secondLabel [exactClosedHalfPlane (oppositeExactAffineLine axis)]+        (Map.insertWith (<>) firstLabel [exactClosedHalfPlane axis] constraints)+    )++clipPowerCell+  :: Ord label+  => ExactRetainedPolygon+  -> ResolvedGeneratorSection label+  -> Map label [ExactClosedHalfPlane]+  -> (ExactPowerGenerator label, RegularGeneratorDisposition)+  -> Either+      (PowerDiagramError label)+      (label, PowerCellDisposition label, ExactClipReceipt, Int)+clipPowerCell retainedDomain section constraints (ownerGenerator, disposition) =+  let ownerLabel = exactPowerGeneratorLabel ownerGenerator+      topology = resolvedRegularTopology section+      competitors =+        [ generator+        | (generator, _) <-+            NonEmpty.toList (generatorRegularDispositions topology)+        , exactPowerGeneratorLabel generator /= ownerLabel+        ]+   in clipRegularGeneratorCell+        retainedDomain+        ownerGenerator+        (Map.findWithDefault [] ownerLabel constraints)+        competitors+        disposition++clipRegularGeneratorCell+  :: ExactRetainedPolygon+  -> ExactPowerGenerator label+  -> [ExactClosedHalfPlane]+  -> [ExactPowerGenerator label]+  -> RegularGeneratorDisposition+  -> Either+      (PowerDiagramError label)+      (label, PowerCellDisposition label, ExactClipReceipt, Int)+clipRegularGeneratorCell retainedDomain ownerGenerator activeConstraints competitors disposition =+  case disposition of+    RegularGeneratorHidden ->+      pure (exactPowerGeneratorLabel ownerGenerator, EmptyPowerCell, mempty, 0)+    RegularGeneratorVisible ->+      finishPowerCell retainedDomain ownerGenerator activeConstraints+    RegularGeneratorLowerDimensional -> do+      halfPlanes <- traverse (preparedDirectHalfPlane ownerGenerator) competitors+      finishPowerCell retainedDomain ownerGenerator halfPlanes++preparedDirectHalfPlane+  :: ExactPowerGenerator label+  -> ExactPowerGenerator label+  -> Either (PowerDiagramError label) ExactClosedHalfPlane+preparedDirectHalfPlane owner competitor =+  exactClosedHalfPlane <$> prepareRadicalAxis owner competitor++finishPowerCell+  :: ExactRetainedPolygon+  -> ExactPowerGenerator label+  -> [ExactClosedHalfPlane]+  -> Either+      (PowerDiagramError label)+      (label, PowerCellDisposition label, ExactClipReceipt, Int)+finishPowerCell retainedDomain ownerGenerator halfPlanes = do+  (exactDisposition, receipt) <-+    first (PowerCellClipFailed (exactPowerGeneratorLabel ownerGenerator))+      (exactClipRetainedPolygon retainedDomain halfPlanes)+  pure+    ( exactPowerGeneratorLabel ownerGenerator+    , case exactDisposition of+        ExactClipFullDimensional retained ->+          PublishedPowerCell (convexPolygonFromRetained retained)+        ExactClipLowerDimensional points -> LowerDimensionalPowerCell points+        ExactClipEmpty -> EmptyPowerCell+    , receipt+    , length halfPlanes+    )++aggregateReceipt+  :: ConvexPolygon+  -> Map label (PowerCellDisposition label)+  -> Int+  -> ExactClipReceipt+  -> GeneratorRegularReceipt+  -> Int+  -> PowerDiagramReceipt+aggregateReceipt domain dispositions siteInputBits clipReceipt regularReceipt maximumCellConstraints =+  let inputBits = max siteInputBits (exactClipInputCoordinateBits clipReceipt)+      peakBits = exactClipPeakIntermediateCoordinateBits clipReceipt+      finalBits = exactClipFinalCoordinateBits clipReceipt+      dispositionCounts = countPowerDispositions dispositions+   in PowerDiagramReceipt+        { powerDiagramDomainVertices = NonEmpty.length (convexPolygonPoints domain)+        , powerDiagramSubmittedSiteConstraints = exactClipSubmittedHalfPlanes clipReceipt+        , powerDiagramActiveBoundaries = exactClipActiveBoundaries clipReceipt+        , powerDiagramBoundaryCompatibilityChecks = exactClipBoundaryCompatibilityChecks clipReceipt+        , powerDiagramExactIntersections = exactClipExactIntersections clipReceipt+        , powerDiagramPublishedCells = countedPublishedCells dispositionCounts+        , powerDiagramLowerDimensionalCells = countedLowerDimensionalCells dispositionCounts+        , powerDiagramEmptyCells = countedEmptyCells dispositionCounts+        , powerDiagramCoincidentEquivalentCells = countedCoincidentEquivalentCells dispositionCounts+        , powerDiagramCoincidentDominatedCells = countedCoincidentDominatedCells dispositionCounts+        , powerDiagramRegularFaces = generatorRegularFaceCount regularReceipt+        , powerDiagramRegularEdges = generatorRegularEdgeCount regularReceipt+        , powerDiagramOracleCells = generatorRegularLowerDimensionalSites regularReceipt+        , powerDiagramMaximumCellConstraints = maximumCellConstraints+        , powerDiagramMaximumInputBits = inputBits+        , powerDiagramMaximumAffineCoefficientBits = exactClipMaximumAffineCoefficientBits clipReceipt+        , powerDiagramPeakIntermediateCoordinateBits = peakBits+        , powerDiagramFinalCoordinateBits = finalBits+        , powerDiagramFinalDenominatorBits = exactClipFinalDenominatorBits clipReceipt+        }++data PowerDispositionCounts = PowerDispositionCounts+  { countedPublishedCells :: !Int+  , countedLowerDimensionalCells :: !Int+  , countedEmptyCells :: !Int+  , countedCoincidentEquivalentCells :: !Int+  , countedCoincidentDominatedCells :: !Int+  }++countPowerDispositions+  :: Map label (PowerCellDisposition label)+  -> PowerDispositionCounts+countPowerDispositions =+  Map.foldl'+    (\counts disposition -> case disposition of+        PublishedPowerCell _ ->+          counts {countedPublishedCells = countedPublishedCells counts + 1}+        LowerDimensionalPowerCell _ ->+          counts {countedLowerDimensionalCells = countedLowerDimensionalCells counts + 1}+        EmptyPowerCell ->+          counts {countedEmptyCells = countedEmptyCells counts + 1}+        CoincidentEquivalentTo _ ->+          counts {countedCoincidentEquivalentCells = countedCoincidentEquivalentCells counts + 1}+        CoincidentDominatedBy _ ->+          counts {countedCoincidentDominatedCells = countedCoincidentDominatedCells counts + 1})+    PowerDispositionCounts+      { countedPublishedCells = 0+      , countedLowerDimensionalCells = 0+      , countedEmptyCells = 0+      , countedCoincidentEquivalentCells = 0+      , countedCoincidentDominatedCells = 0+      }
+ src-public/Moonlight/Triangulation/Internal/PowerDiagram/Section.hs view
@@ -0,0 +1,489 @@+-- | Batch normalization and publication of one exact regular section.+module Moonlight.Triangulation.Internal.PowerDiagram.Section where++import Data.Bifunctor (first)+import qualified Data.Foldable as Foldable+import qualified Data.List as List+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.Ord (comparing)+import qualified Data.Set as Set+import Data.Set (Set)+import Moonlight.Triangulation.Exact+  ( ExactPoint+  , exactPointBitWidth+  , exactPointCoordinates+  , exactPointFromQueryPoint+  )+import Moonlight.Triangulation.Internal.BoundaryCycle (consecutivePairs)+import Moonlight.Triangulation.Internal.ExactRational (exactRationalBitWidth)+import Moonlight.Triangulation.Internal.PowerDiagram.Generator+import Moonlight.Triangulation.Internal.PowerDiagram.Hull (regularGeneratorTopology)+import Moonlight.Triangulation.Internal.PowerDiagram.Locality (buildRegularLocality)+import Moonlight.Triangulation.Internal.PowerDiagram.Model++regularTriangulation+  :: Ord label+  => NonEmpty (PowerSite label)+  -> Either+      (PowerDiagramError label)+      (RegularTriangulation label, RegularTriangulationReceipt)+regularTriangulation submitted = do+  sortedSites <- validateAndSortSites submitted+  triangulation <-+    first PowerRegularTopologyFailed+      ( constructRegularTriangulation+          (Map.fromDistinctAscList (fmap (\site -> (powerSiteLabel site, site)) (NonEmpty.toList sortedSites)))+      )+  pure (triangulation, regularTriangulationReceipt triangulation)++-- | The empty all-site section. It is the identity for insertion and the+-- result of removing the final site.+emptyRegularTriangulation :: RegularTriangulation label+emptyRegularTriangulation =+  RegularTriangulation+    { storedRegularSites = Map.empty+    , storedRegularSection = Nothing+    }++-- | Look up one canonical site by its stable label.+regularSite+  :: Ord label+  => label+  -> RegularTriangulation label+  -> Maybe (PowerSite label)+regularSite label = Map.lookup label . storedRegularSites++-- | Enumerate every canonical site in ascending label order, including hidden+-- and coincident sites.+regularSites :: RegularTriangulation label -> [PowerSite label]+regularSites = Map.elems . storedRegularSites++-- | Number of canonical sites, independent of their visibility.+regularSiteCount :: RegularTriangulation label -> Int+regularSiteCount = Map.size . storedRegularSites++-- | Observe one site's exhaustive derived visibility disposition.+regularSiteDisposition+  :: Ord label+  => label+  -> RegularTriangulation label+  -> Maybe (RegularSiteDisposition label)+regularSiteDisposition label triangulation =+  storedRegularSection triangulation+    >>= Map.lookup label . sectionRegularDispositions++-- | Enumerate canonical visible faces in ascending key order.+regularFaces :: RegularTriangulation label -> [RegularFace label]+regularFaces =+  maybe [] (Map.elems . sectionRegularFaces) . storedRegularSection++-- | Enumerate canonical regular edges in ascending endpoint order.+regularEdges :: RegularTriangulation label -> [RegularEdge label]+regularEdges =+  maybe [] (fmap sectionRegularEdge . Map.elems . sectionRegularEdges)+    . storedRegularSection++-- | Exact neighbours of one visible site; nonvisible and absent sites have none.+regularNeighbours+  :: Ord label+  => label+  -> RegularTriangulation label+  -> Set label+regularNeighbours label =+  maybe+    Set.empty+    ( maybe Set.empty sectionSiteNeighbours+        . Map.lookup label+        . sectionRegularStars+    )+    . storedRegularSection++-- | Construction statistics derived from the sealed normalized section.+regularTriangulationReceipt+  :: RegularTriangulation label+  -> RegularTriangulationReceipt+regularTriangulationReceipt triangulation =+  case storedRegularSection triangulation of+    Nothing -> emptyRegularTriangulationReceipt+    Just section ->+      regularReceiptFromSection (regularSiteCount triangulation) section++validateAndSortSites+  :: Ord label+  => NonEmpty (PowerSite label)+  -> Either (PowerDiagramError label) (NonEmpty (PowerSite label))+validateAndSortSites submitted =+  let sorted = NonEmpty.sortBy (comparing powerSiteLabel) submitted+   in case List.find (uncurry sameLabel) (consecutivePairs (NonEmpty.toList sorted)) of+        Just (duplicate, _) -> Left (DuplicatePowerSiteLabel (powerSiteLabel duplicate))+        Nothing -> Right sorted+ where+  sameLabel :: Eq label => PowerSite label -> PowerSite label -> Bool+  sameLabel left right = powerSiteLabel left == powerSiteLabel right++maximumPowerSiteInputBits :: Map label (PowerSite label) -> Int+maximumPowerSiteInputBits =+  Map.foldl' (\bits site -> max bits (powerSiteInputBitWidth site)) 0++constructRegularTriangulation+  :: Ord label+  => Map label (PowerSite label)+  -> Either (RegularTopologyError label) (RegularTriangulation label)+constructRegularTriangulation sites =+  case NonEmpty.nonEmpty (Map.elems sites) of+    Nothing -> Right emptyRegularTriangulation+    Just sortedSites -> do+      let generators = fmap (fst . prepareExactPowerGenerator) sortedSites+      section <- resolvedGeneratorSection generators+      pure (publishRegularSection sites section)++prepareExactPowerGenerator :: PowerSite label -> (ExactPowerGenerator label, Int)+prepareExactPowerGenerator site =+  let point = exactPointFromQueryPoint (powerSiteQueryPoint site)+      (coordinateX, coordinateY) = exactPointCoordinates point+      weight = powerWeightExact (powerSiteWeight site)+   in ( ExactPowerGenerator+          { exactPowerGeneratorLabel = powerSiteLabel site+          , exactPowerGeneratorXCoefficient = 2 * coordinateX+          , exactPowerGeneratorYCoefficient = 2 * coordinateY+          , exactPowerGeneratorConstant =+              weight - coordinateX * coordinateX - coordinateY * coordinateY+          }+      , max (exactPointBitWidth point) (exactRationalBitWidth weight)+      )++powerSiteInputBitWidth :: PowerSite label -> Int+powerSiteInputBitWidth site =+  max+    (exactPointBitWidth (exactPointFromQueryPoint (powerSiteQueryPoint site)))+    (exactRationalBitWidth (powerWeightExact (powerSiteWeight site)))++groupGeneratorsBySlope+  :: NonEmpty (ExactPowerGenerator label)+  -> NonEmpty (NonEmpty (ExactPowerGenerator label))+groupGeneratorsBySlope (initial :| remaining) =+  let initialSlope = exactGeneratorSlope initial+      (sameInitialSlope, otherGenerators) =+        List.partition ((== initialSlope) . exactGeneratorSlope) remaining+      otherGroups =+        Map.fromListWith+          (<>)+          [ (exactGeneratorSlope generator, generator :| [])+          | generator <- otherGenerators+          ]+   in (initial :| sameInitialSlope) :| Map.elems otherGroups++resolveCoincidentGeneratorGroup+  :: Ord label+  => NonEmpty (ExactPowerGenerator label)+  -> (ExactPowerGenerator label, [(label, CoincidentGeneratorDisposition label)])+resolveCoincidentGeneratorGroup generators@(initial :| remaining) =+  let representative = List.foldl' chooseCoincidentRepresentative initial remaining+      representativeLabel = exactPowerGeneratorLabel representative+   in ( representative+      , [ ( exactPowerGeneratorLabel generator+          , classifyCoincidentGenerator representative generator+          )+        | generator <- NonEmpty.toList generators+        , exactPowerGeneratorLabel generator /= representativeLabel+        ]+      )++chooseCoincidentRepresentative+  :: Ord label+  => ExactPowerGenerator label+  -> ExactPowerGenerator label+  -> ExactPowerGenerator label+chooseCoincidentRepresentative selected candidate =+  case+    compareCoincidentPriority+      (exactPowerGeneratorConstant candidate, exactPowerGeneratorLabel candidate)+      (exactPowerGeneratorConstant selected, exactPowerGeneratorLabel selected) of+    GT -> candidate+    _ -> selected++compareCoincidentPriority+  :: (Ord label, Ord value)+  => (value, label)+  -> (value, label)+  -> Ordering+compareCoincidentPriority (candidateValue, candidateLabel) (selectedValue, selectedLabel) =+  compare candidateValue selectedValue <> compare selectedLabel candidateLabel++classifyCoincidentGenerator+  :: ExactPowerGenerator label+  -> ExactPowerGenerator label+  -> CoincidentGeneratorDisposition label+classifyCoincidentGenerator representative candidate =+  classifyCoincidentValue+    (exactPowerGeneratorLabel representative)+    (exactPowerGeneratorConstant representative)+    (exactPowerGeneratorConstant candidate)++classifyCoincidentValue+  :: Eq value+  => label+  -> value+  -> value+  -> CoincidentGeneratorDisposition label+classifyCoincidentValue representativeLabel representativeValue candidateValue+  | candidateValue == representativeValue =+      CoincidentGeneratorEquivalentTo representativeLabel+  | otherwise = CoincidentGeneratorDominatedBy representativeLabel+++coincidentPowerDisposition+  :: CoincidentGeneratorDisposition label+  -> PowerCellDisposition label+coincidentPowerDisposition disposition =+  case disposition of+    CoincidentGeneratorEquivalentTo label -> CoincidentEquivalentTo label+    CoincidentGeneratorDominatedBy label -> CoincidentDominatedBy label++coincidentRegularDisposition+  :: CoincidentGeneratorDisposition label+  -> RegularSiteDisposition label+coincidentRegularDisposition disposition =+  case disposition of+    CoincidentGeneratorEquivalentTo label -> RegularSiteCoincidentEquivalentTo label+    CoincidentGeneratorDominatedBy label -> RegularSiteCoincidentDominatedBy label+++resolvedGeneratorSection+  :: Ord label+  => NonEmpty (ExactPowerGenerator label)+  -> Either (RegularTopologyError label) (ResolvedGeneratorSection label)+resolvedGeneratorSection generators = do+  let resolvedGroups = fmap resolveCoincidentGeneratorGroup (groupGeneratorsBySlope generators)+      representatives = fmap fst resolvedGroups+      coincidentDispositions =+        Map.fromList (concatMap snd (NonEmpty.toList resolvedGroups))+  topology <- regularGeneratorTopology (DistinctSlopeGenerators representatives)+  pure+    ResolvedGeneratorSection+      { resolvedCoincidentDispositions = coincidentDispositions+      , resolvedRegularTopology = topology+      }++publishRegularSection+  :: Ord label+  => Map label (PowerSite label)+  -> ResolvedGeneratorSection label+  -> RegularTriangulation label+publishRegularSection sites resolvedSection =+  let topology = resolvedRegularTopology resolvedSection+      coincident = resolvedCoincidentDispositions resolvedSection+      representativeDispositions = publishRepresentativeDispositions topology+      dispositions =+        representativeDispositions <> fmap coincidentRegularDisposition coincident+      generators =+        Map.fromList+          [ (exactPowerGeneratorLabel generator, generator)+          | (generator, _) <- NonEmpty.toList (generatorRegularDispositions topology)+          ]+      faces = fmap publishGeneratorFace (generatorRegularFaces topology)+      faceSection = Map.fromList (fmap (\face -> (regularFaceKey face, face)) faces)+      edgeFaceIncidence =+        List.foldl'+          (Map.unionWith Set.union)+          Map.empty+          (fmap regularFaceEdgeIncidence faces)+      edges = fmap publishGeneratorEdge (generatorRegularEdges topology)+      edgeSection =+        Map.fromList+          [ ( key+            , RegularEdgeSection+                edge+                (Map.findWithDefault Set.empty key edgeFaceIncidence)+            )+          | edge <- edges+          , let key = regularEdgeKey edge+          ]+      stars = regularSiteStars dispositions faceSection edgeSection+      baseSection =+        RegularSection+          { sectionGenerators = generators+          , sectionSlopeRepresentatives =+              Map.fromList+                [ (exactGeneratorSlope generator, label)+                | (label, generator) <- Map.toAscList generators+                ]+          , sectionCoincidentDispositions = coincident+          , sectionRegularDispositions = dispositions+          , sectionRegularFaces = faceSection+          , sectionRegularEdges = edgeSection+          , sectionRegularStars = stars+          , sectionRegularReceipt = generatorRegularReceipt topology+          , sectionRegularLocality = Nothing+          }+      section =+        baseSection+          { sectionRegularLocality = buildRegularLocality baseSection+          }+   in RegularTriangulation+        { storedRegularSites = sites+        , storedRegularSection = Just section+        }++regularReceiptFromSection+  :: Int+  -> RegularSection label+  -> RegularTriangulationReceipt+regularReceiptFromSection inputSites section =+  let generatorReceipt = sectionRegularReceipt section+      coincidentCount = Map.size (sectionCoincidentDispositions section)+   in RegularTriangulationReceipt+        { regularTriangulationInputSites = inputSites+        , regularTriangulationRepresentativeSites =+            generatorRegularInputSites generatorReceipt+        , regularTriangulationVisibleSites =+            generatorRegularVisibleSites generatorReceipt+        , regularTriangulationLowerDimensionalSites =+            generatorRegularLowerDimensionalSites generatorReceipt+        , regularTriangulationHiddenSites =+            generatorRegularHiddenSites generatorReceipt+        , regularTriangulationCoincidentSites = coincidentCount+        , regularTriangulationFaces = generatorRegularFaceCount generatorReceipt+        , regularTriangulationEdges = generatorRegularEdgeCount generatorReceipt+        }++emptyRegularTriangulationReceipt :: RegularTriangulationReceipt+emptyRegularTriangulationReceipt =+  RegularTriangulationReceipt+    { regularTriangulationInputSites = 0+    , regularTriangulationRepresentativeSites = 0+    , regularTriangulationVisibleSites = 0+    , regularTriangulationLowerDimensionalSites = 0+    , regularTriangulationHiddenSites = 0+    , regularTriangulationCoincidentSites = 0+    , regularTriangulationFaces = 0+    , regularTriangulationEdges = 0+    }++emptyGeneratorRegularReceipt :: GeneratorRegularReceipt+emptyGeneratorRegularReceipt =+  GeneratorRegularReceipt+    { generatorRegularInputSites = 0+    , generatorRegularVisibleSites = 0+    , generatorRegularLowerDimensionalSites = 0+    , generatorRegularHiddenSites = 0+    , generatorRegularFaceCount = 0+    , generatorRegularEdgeCount = 0+    }++publishGeneratorDisposition+  :: RegularGeneratorDisposition+  -> RegularSiteDisposition label+publishGeneratorDisposition disposition =+  case disposition of+    RegularGeneratorVisible -> RegularSiteVisible+    RegularGeneratorLowerDimensional -> RegularSiteLowerDimensional+    RegularGeneratorHidden -> RegularSiteHidden++publishGeneratorFace+  :: Ord label+  => GeneratorRegularFace label+  -> RegularFace label+publishGeneratorFace face =+  canonicalRegularFace+    (generatorRegularFaceFirst face)+    (generatorRegularFaceSecond face)+    (generatorRegularFaceThird face)+    (generatorRegularFaceDualPoint face)++canonicalRegularFace+  :: Ord label+  => label+  -> label+  -> label+  -> ExactPoint+  -> RegularFace label+canonicalRegularFace firstLabel secondLabel thirdLabel dualPoint+  | firstLabel <= secondLabel && firstLabel <= thirdLabel =+      RegularFace firstLabel secondLabel thirdLabel dualPoint+  | secondLabel <= thirdLabel =+      RegularFace secondLabel thirdLabel firstLabel dualPoint+  | otherwise =+      RegularFace thirdLabel firstLabel secondLabel dualPoint++publishGeneratorEdge :: GeneratorRegularEdge label -> RegularEdge label+publishGeneratorEdge edge =+  RegularEdge+    (exactPowerGeneratorLabel (generatorRegularEdgeFirst edge))+    (exactPowerGeneratorLabel (generatorRegularEdgeSecond edge))+    (publishGeneratorDualGeometry (generatorRegularEdgeDual edge))++publishGeneratorDualGeometry :: GeneratorDualGeometry -> PowerDualEdge+publishGeneratorDualGeometry dual =+  case dual of+    GeneratorDualSegment segment -> BoundedPowerDual segment+    GeneratorDualRay ray -> UnboundedPowerDual ray+    GeneratorDualLine line -> FullLinePowerDual line+    GeneratorDualCollapsed point -> CollapsedPowerDual point++regularSiteStars+  :: Ord label+  => Map label disposition+  -> Map (RegularFaceKey label) (RegularFace label)+  -> Map (RegularEdgeKey label) (RegularEdgeSection label)+  -> Map label (RegularSiteStar label)+regularSiteStars dispositions faces =+  Map.foldl'+    insertRegularEdgeStar+    (Map.foldlWithKey' insertRegularFaceStar (emptyRegularStars dispositions) faces)++emptyRegularStars+  :: Map label disposition+  -> Map label (RegularSiteStar label)+emptyRegularStars = Map.map (const emptyRegularSiteStar)++publishRepresentativeDispositions+  :: Ord label+  => GeneratorRegularTopology label+  -> Map label (RegularSiteDisposition label)+publishRepresentativeDispositions topology =+  Map.fromList+    [ ( exactPowerGeneratorLabel generator+      , publishGeneratorDisposition disposition+      )+    | (generator, disposition) <-+        NonEmpty.toList (generatorRegularDispositions topology)+    ]++insertRegularFaceStar+  :: Ord label+  => Map label (RegularSiteStar label)+  -> RegularFaceKey label+  -> RegularFace label+  -> Map label (RegularSiteStar label)+insertRegularFaceStar stars faceKey face =+  let (firstLabel, secondLabel, thirdLabel) = regularFaceLabels face+   in Foldable.foldl'+        (\current label -> Map.adjust (addIncidentFace faceKey) label current)+        stars+        [firstLabel, secondLabel, thirdLabel]++insertRegularEdgeStar+  :: Ord label+  => Map label (RegularSiteStar label)+  -> RegularEdgeSection label+  -> Map label (RegularSiteStar label)+insertRegularEdgeStar stars edgeSection =+  let (firstLabel, secondLabel) = regularEdgeLabels (sectionRegularEdge edgeSection)+   in Map.adjust (addNeighbour secondLabel) firstLabel+        (Map.adjust (addNeighbour firstLabel) secondLabel stars)++addIncidentFace+  :: Ord label+  => RegularFaceKey label+  -> RegularSiteStar label+  -> RegularSiteStar label+addIncidentFace faceKey star =+  star{sectionIncidentFaces = Set.insert faceKey (sectionIncidentFaces star)}++addNeighbour :: Ord label => label -> RegularSiteStar label -> RegularSiteStar label+addNeighbour label star =+  star{sectionSiteNeighbours = Set.insert label (sectionSiteNeighbours star)}
+ src-public/Moonlight/Triangulation/Minkowski.hs view
@@ -0,0 +1,592 @@+{-# 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+  , reflectConvexPolygon+  , 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.List as List+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+  , exactClipExactIntersections+  , exactPointCoordinates+  )+import Moonlight.Triangulation.Internal.HandleDefs+  ( FaceId+  )+import Moonlight.Triangulation.Handles.Iterators.FixedIterators (innerFaces)+import Moonlight.Triangulation.Internal.ExactRational+  ( exactRationalBitWidth+  )+import Moonlight.Triangulation.Internal.BoundaryCycle (cyclePairs)+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+  ( faceCarriesExactArea+  , 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+      (\face ->+         if faceCarriesExactArea result face+           then+             fmap fst+               ( first MinkowskiOverlayCellWitness+                   (faceLabels result face)+               )+           else Right False)+      (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, clipReceipt) <-+    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 =+            exactClipExactIntersections clipReceipt+        , 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+    , faceCarriesExactArea result face+    ]+ 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 ->+             if faceCarriesExactArea result face+               then+                 Right+                   ( Set.member+                       (overlayFaceCellId (faceData triangulation face))+                       selected+                   )+               else Right False)+      )+  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+        - List.foldl' (\maximumBits -> max maximumBits . regionCoordinateBits) 0 inputs+    )++regionCoordinateBits :: PlanarRegion -> Int+regionCoordinateBits = List.foldl' componentBits 0 . planarRegionComponents+ where+  componentBits maximumBits component =+    List.foldl'+      loopBits+      maximumBits+      (polygonOuterLoop component : polygonHoleLoops component)+  loopBits maximumBits =+    List.foldl' pointBits maximumBits . exactLoopPoints+  pointBits maximumBits point =+    let (x, y) = exactPointCoordinates point+     in max+          maximumBits+          (max (exactRationalBitWidth x) (exactRationalBitWidth y))
+ src-public/Moonlight/Triangulation/Overlay.hs view
@@ -0,0 +1,468 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# 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+  , BoundaryRef+  , BoundaryVertexRef+  , BoundaryEdgeRef+  , boundaryRefComponent+  , boundaryRefLoop+  , boundaryRefLocalIndex+  , OverlayVertexOrigin+  , overlayOriginLeftVertices+  , overlayOriginRightVertices+  , overlayOriginLeftEdges+  , overlayOriginRightEdges+  , OverlayEdgeOrigin+  , overlayEdgeLeftSources+  , overlayEdgeRightSources+  , OverlaySupport+  , overlaySupportLabels+  , OverlayCellSupport (..)+  , OverlayCellId (..)+  , OverlayCellGeometry (..)+  , OverlayCell (..)+  , OverlayFace (..)+  , OverlayVertex (..)+  , OverlayEdge (..)+  , OverlayReceipt (..)+  , OverlayArrangementObstruction (..)+  , OverlayCellWitness (..)+  , OverlayError (..)+  , OverlayResult+  , OverlaySelectionKind (..)+  , OverlaySelectionError (..)+  , CoverGap+  , coverGapRegion+  , LayerCoverageError (..)+  , overlayLayers+  , overlayAll+  , overlayEmbeddedTriangulation+  , overlayReceipt+  , overlayCells+  , foldBoundedOverlayCells+  , overlayArrangementVertices+  , overlayArrangementEdges+  , overlayPlanarLayer+  , overlaySelectedRegion+  , overlayMass+  , overlayConfusion+  , layerCovers+  , overlayClosedUnion+  , overlayClosedIntersection+  , overlayRegularizedDifference+  ) where++import Control.DeepSeq (NFData)+import Data.Bifunctor (first)+import Control.Monad (filterM)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Map.Strict as Map+import qualified Data.Vector as V+import GHC.Generics (Generic)+import Moonlight.Triangulation.CellSet+  ( CellSelectionError+  , ExactCellSet+  )+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.Dcel (vertexData)+import Moonlight.Triangulation.Exact (ExactPoint)+import Moonlight.Triangulation.Internal.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+  , faceCarriesExactArea+  , 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.Internal.Tournament+  ( interpretTournament+  , planTournament+  )+import Moonlight.Triangulation.Region+  ( PlanarLayer+  , PlanarRegion+  , PolygonComponent+  , RegionPublicationError (..)+  , emptyPlanarRegion+  , planarLayerOutsideLabel+  , planarLayerRegions+  , planarRegionComponents+  )+import Moonlight.Triangulation.Internal.Region.Publication+  ( labelledPlanarLayerFromExactCoordinates+  , planarLayerFromAdmittedComponents+  )+import Moonlight.Triangulation.Valuation+  ( ExactArea+  , polygonComponentArea+  )++-- | Exact full-dimensional part of a requested window not owned by any+-- bounded label region in the candidate layer.+newtype CoverGap = CoverGap PlanarRegion+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++coverGapRegion :: CoverGap -> PlanarRegion+coverGapRegion (CoverGap region) = region++data LayerCoverageError label+  = LayerCoverageOverlayFailed !(OverlayError Bool label)+  | LayerCoverageGapPublicationFailed !RegionPublicationError+  | LayerCoverageGap !CoverGap+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | 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++-- | Construct the common refinement of a nonempty family in input order.+-- Adjacent layers glue in a balanced tree, so an early boundary participates+-- in logarithmically many intermediate arrangements rather than every later+-- left-associated step. Each intermediate layer is projected directly from+-- its certified binary result.+overlayAll+  :: Ord label+  => NonEmpty (PlanarLayer label)+  -> Either+      (OverlayError (NonEmpty label) (NonEmpty label))+      (PlanarLayer (NonEmpty label))+overlayAll =+  interpretTournament overlayLayerPair+    . planTournament+    . fmap singletonLabelLayer++overlayLayerPair+  :: Ord label+  => PlanarLayer (NonEmpty label)+  -> PlanarLayer (NonEmpty label)+  -> Either+      (OverlayError (NonEmpty label) (NonEmpty label))+      (PlanarLayer (NonEmpty label))+overlayLayerPair leftLayer rightLayer =+  flattenNaryOverlay <$> overlayLayers leftLayer rightLayer++singletonLabelLayer :: Ord label => PlanarLayer label -> PlanarLayer (NonEmpty label)+singletonLabelLayer layer =+  planarLayerFromAdmittedComponents+    (planarLayerOutsideLabel layer :| [])+    [ (label :| [], component)+    | (label, region) <- Map.toAscList (planarLayerRegions layer)+    , component <- planarRegionComponents region+    ]++flattenNaryOverlay+  :: Ord label+  => OverlayResult (NonEmpty label) (NonEmpty label)+  -> PlanarLayer (NonEmpty label)+flattenNaryOverlay = projectOverlayLayerWith (uncurry (<>))++projectOverlayLayerWith+  :: (Eq leftLabel, Eq rightLabel, Ord projectedLabel)+  => ((leftLabel, rightLabel) -> projectedLabel)+  -> OverlayResult leftLabel rightLabel+  -> PlanarLayer projectedLabel+projectOverlayLayerWith projectLabel result =+  planarLayerFromAdmittedComponents+    (projectLabel (overlayResultOutsideLabels result))+    [ (projectLabel (overlayCellLabels cell), component)+    | cell <- V.toList (overlayResultCells result)+    , overlayCellLabels cell /= overlayResultOutsideLabels result+    , BoundedOverlayCell component <- [overlayCellGeometry cell]+    ]++overlayCellLabels :: OverlayCell leftLabel rightLabel -> (leftLabel, rightLabel)+overlayCellLabels cell = (overlayCellLeft cell, overlayCellRight cell)+{-# INLINE overlayCellLabels #-}++-- | 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 = projectOverlayLayerWith id++-- | 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 :: VertexId -> Either RegionPublicationError ExactPoint+ exactPointAt vertex = Right (overlayExactPoint (vertexData triangulation vertex))+ labelFace face+   | faceCarriesExactArea result face =+       selected <$> regionFaceLabels result face+   | otherwise = Right False++-- | Sum selected exact bounded cells without publishing a polygonal union or+-- computing its perimeter. Selecting the unbounded outside pair is refused by+-- the same obstruction used by 'overlaySelectedRegion'.+overlayMass+  :: ((leftLabel, rightLabel) -> Bool)+  -> OverlayResult leftLabel rightLabel+  -> Either RegionPublicationError ExactArea+overlayMass selected result+  | selected (overlayResultOutsideLabels result) = Left RegionUnboundedSelection+  | otherwise =+      Right (foldBoundedOverlayCells selectedCellArea mempty result)+ where+  selectedCellArea area labels component+    | selected labels = area <> polygonComponentArea component+    | otherwise = area++-- | Exact finite confusion masses, grouped by label pair in one traversal.+-- The outside pair is absent because its complete planar cell is unbounded;+-- bounded cavities carrying that same pair are not misreported as its total.+overlayConfusion+  :: (Ord leftLabel, Ord rightLabel)+  => OverlayResult leftLabel rightLabel+  -> Map.Map (leftLabel, rightLabel) ExactArea+overlayConfusion result =+  foldBoundedOverlayCells accumulateCell Map.empty result+ where+  outsideLabels = overlayResultOutsideLabels result+  accumulateCell masses labels component+    | labels == outsideLabels = masses+    | otherwise = Map.insertWith (<>) labels (polygonComponentArea component) masses++foldBoundedOverlayCells+  :: (accumulator -> (leftLabel, rightLabel) -> PolygonComponent -> accumulator)+  -> accumulator+  -> OverlayResult leftLabel rightLabel+  -> accumulator+foldBoundedOverlayCells accumulate initial result =+  V.foldl' descend initial (overlayResultCells result)+ where+  descend accumulator cell =+    case overlayCellGeometry cell of+      BoundedOverlayCell component ->+        accumulate accumulator (overlayCellLabels cell) component+      UnboundedOverlayCell _ -> accumulator+{-# INLINE foldBoundedOverlayCells #-}++-- | Certify full-dimensional coverage of an admitted polygonal window. The+-- success path inspects certified cells only; an exact gap region is glued+-- solely when the obstruction actually exists.+layerCovers+  :: Ord label+  => PlanarLayer label+  -> PolygonComponent+  -> Either (LayerCoverageError label) ()+layerCovers layer window = do+  let outside = planarLayerOutsideLabel layer+      windowLayer = planarLayerFromAdmittedComponents False [(True, window)]+  result <- first LayerCoverageOverlayFailed (overlayLayers windowLayer layer)+  if V.any (isGapCell outside) (overlayResultCells result)+    then do+      gap <-+        first LayerCoverageGapPublicationFailed+          ( overlaySelectedRegion+              (\(insideWindow, label) ->+                 insideWindow && label == outside)+              result+          )+      Left (LayerCoverageGap (CoverGap gap))+    else Right ()++isGapCell :: Eq label => label -> OverlayCell Bool label -> Bool+isGapCell outside cell =+  overlayCellLeft cell+    && overlayCellRight cell == outside+    && case overlayCellGeometry cell of+      BoundedOverlayCell _ -> True+      UnboundedOverlayCell _ -> False++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 :: VertexId -> Either CellSelectionError ExactPoint+      exactPointAt vertex = Right (overlayExactPoint (vertexData triangulation vertex))+   in do+        selectedFaces <-+          filterM+            (\face ->+               if faceCarriesExactArea result face+                 then+                   fmap (uncurry selectFace)+                     ( first OverlaySelectionProvenance+                         (faceLabels result face)+                     )+                 else Right False)+            (innerFaces triangulation)+        first OverlaySelectionInvalid+          ( closeExactCellSetWith+              exactPointAt+              triangulation+              selectedVertices+              selectedEdges+              selectedFaces+          )++supportAny :: (label -> Bool) -> OverlaySupport label -> Bool+supportAny predicate = any predicate . overlaySupportLabels
+ src-public/Moonlight/Triangulation/PowerDiagram.hs view
@@ -0,0 +1,64 @@+-- | Exact regular topology and power cells. The complete labelled weighted-site+-- section is authoritative; visibility, incidence, and bounded planar layers+-- are derived views.+module Moonlight.Triangulation.PowerDiagram+  ( PowerWeight+  , PowerWeightError (..)+  , powerWeight+  , powerWeightFromExact+  , powerWeightExact+  , PowerSite+  , powerSite+  , powerSiteLabel+  , powerSitePosition+  , powerSiteExactPosition+  , powerSiteWeight+  , PowerCellDisposition (..)+  , RegularSiteDisposition (..)+  , RegularFace+  , regularFaceLabels+  , regularFaceDualPoint+  , PowerDualEdge (..)+  , RegularEdge+  , regularEdgeLabels+  , regularEdgeDual+  , RegularTriangulation+  , emptyRegularTriangulation+  , regularTriangulation+  , regularSite+  , regularSites+  , regularSiteCount+  , regularSiteDisposition+  , regularFaces+  , regularEdges+  , regularNeighbours+  , regularTriangulationReceipt+  , RegularTriangulationReceipt (..)+  , RegularSiteTransition (..)+  , RegularEditError (..)+  , RegularEditResult (..)+  , insertRegularSite+  , removeRegularSite+  , reweightRegularSites+  , BoundedPowerDiagram+  , boundedPowerDiagram+  , boundedPowerDiagramFromRegular+  , powerCellDisposition+  , powerCellDispositions+  , powerDiagramPlanarLayer+  , PowerDiagramError (..)+  , RegularTopologyError (..)+  , PowerDiagramReceipt (..)+  , powerDiagramInputSites+  , powerDiagramPeakIntermediateBitGrowth+  , powerDiagramFinalCoordinateBitGrowth+  , AffineForm (..)+  , UpperEnvelopeError (..)+  , upperEnvelope+  ) where++import Moonlight.Triangulation.Internal.PowerDiagram.Edit+import Moonlight.Triangulation.Internal.PowerDiagram.Generator (RegularTopologyError (..))+import Moonlight.Triangulation.Internal.PowerDiagram.Model+import Moonlight.Triangulation.Internal.PowerDiagram.Projection+import Moonlight.Triangulation.Internal.PowerDiagram.Section
+ src-public/Moonlight/Triangulation/RegularAlpha.hs view
@@ -0,0 +1,393 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Exact weighted alpha filtration of a full-dimensional regular+-- subdivision. Births are signed power radii; Homology lowering remains in+-- @moonlight-planar:cell-complex@.+module Moonlight.Triangulation.RegularAlpha+  ( PowerAlphaBirth+  , powerAlphaBirthExact+  , powerAlphaBirthNumerator+  , powerAlphaBirthDenominator+  , RegularAlphaFiltration+  , RegularAlphaError (..)+  , regularAlphaFiltration+  , regularAlphaComplex+  , regularAlphaBirths+  , regularAlphaSimplexBirth+  , regularAlphaCriticalBirths+  , regularAlphaComplexAtBirth+  )+where++import Control.DeepSeq (NFData)+import Data.Bifunctor (first)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import GHC.Generics (Generic)+import Moonlight.Triangulation.Exact+  ( ExactAffineLine+  , ExactArithmeticError+  , ExactPoint+  , ExactRational+  , ExactVector (..)+  , exactAffineLineCoefficients+  , exactDivide+  , exactPoint+  , exactPointCoordinates+  , exactRayDirection+  , exactRayOrigin+  , exactRationalDenominator+  , exactRationalNumerator+  , exactSegmentEndpoints+  )+import Moonlight.Triangulation.PowerDiagram+  ( PowerDualEdge (..)+  , PowerSite+  , RegularEdge+  , RegularFace+  , RegularSiteDisposition (..)+  , RegularTriangulation+  , powerSiteExactPosition+  , powerSiteLabel+  , powerSiteWeight+  , powerWeightExact+  , regularEdgeDual+  , regularEdgeLabels+  , regularEdges+  , regularFaceDualPoint+  , regularFaceLabels+  , regularFaces+  , regularNeighbours+  , regularSite+  , regularSiteDisposition+  , regularSites+  )+import Moonlight.Triangulation.Simplex+  ( PlanarComplex+  , PlanarComplexError+  , PlanarSimplex+  , PlanarSimplexError+  , planarComplex+  , planarEdge+  , planarFace+  , planarSimplexVertices+  , planarVertex+  )++-- | Signed exact power radius. Unlike ordinary alpha birth, negative values+-- are lawful when a positive site weight already contains the simplex at+-- negative power level.+newtype PowerAlphaBirth = PowerAlphaBirth ExactRational+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (NFData)++-- | Recover the reduced exact power radius.+powerAlphaBirthExact :: PowerAlphaBirth -> ExactRational+powerAlphaBirthExact (PowerAlphaBirth value) = value++-- | Numerator of the reduced exact power radius.+powerAlphaBirthNumerator :: PowerAlphaBirth -> Integer+powerAlphaBirthNumerator = exactRationalNumerator . powerAlphaBirthExact++-- | Positive denominator of the reduced exact power radius.+powerAlphaBirthDenominator :: PowerAlphaBirth -> Integer+powerAlphaBirthDenominator = exactRationalDenominator . powerAlphaBirthExact++-- | One admitted labelled regular complex and its total exact birth section.+data RegularAlphaFiltration label = RegularAlphaFiltration+  { regularAlphaComplex :: !(PlanarComplex label)+    -- ^ Canonical full-dimensional regular complex.+  , regularAlphaBirths :: !(Map (PlanarSimplex label) PowerAlphaBirth)+    -- ^ Total exact birth section over that complex.+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Typed topology, dual-consistency, projection, and sublevel obstructions.+data RegularAlphaError label+  = RegularAlphaSiteMissing !label+  | RegularAlphaSimplexInvalid !(PlanarSimplexError label)+  | RegularAlphaComplexInvalid !(PlanarComplexError label)+  | RegularAlphaDualMismatch+      !(PlanarSimplex label)+      !ExactRational+      !ExactRational+  | RegularAlphaProjectionFailed+      !(PlanarSimplex label)+      !ExactArithmeticError+  | RegularAlphaVertexBirthMissing !label+  | RegularAlphaSublevelInvalid !(PlanarComplexError label)+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++-- | Derive one exact weighted-alpha birth section from the resident regular dual.+regularAlphaFiltration+  :: Ord label+  => RegularTriangulation label+  -> Either (RegularAlphaError label) (RegularAlphaFiltration label)+regularAlphaFiltration triangulation = do+  let visibleLabels =+        Set.fromAscList+          [ powerSiteLabel site+          | site <- regularSites triangulation+          , regularSiteDisposition (powerSiteLabel site) triangulation+              == Just RegularSiteVisible+          ]+      visibleEdges = filter (edgeIsVisible visibleLabels) (regularEdges triangulation)+      visibleFaces = filter (faceIsVisible visibleLabels) (regularFaces triangulation)+  edgeSimplices <- traverse regularEdgeSimplex visibleEdges+  faceSimplices <- traverse regularFaceSimplex visibleFaces+  complexValue <-+    first RegularAlphaComplexInvalid+      ( planarComplex+          ( Set.unions+              [ Set.map planarVertex visibleLabels+              , Set.fromList edgeSimplices+              , Set.fromList faceSimplices+              ]+          )+      )+  faceBirthSection <-+    Map.fromList <$> traverse (regularFaceBirth triangulation) visibleFaces+  edgeBirthEntries <- traverse (regularEdgeBirth triangulation) visibleEdges+  let edgeBirthSection = Map.fromList edgeBirthEntries+      incidentEdgeBirths =+        Map.fromListWith min (edgeBirthEntries >>= incidentEdgeBirthsFor)+  vertexBirthSection <-+    Map.fromList+      <$> traverse+        (regularVertexBirth triangulation incidentEdgeBirths)+        (Set.toAscList visibleLabels)+  pure+    RegularAlphaFiltration+      { regularAlphaComplex = complexValue+      , regularAlphaBirths =+          vertexBirthSection <> edgeBirthSection <> faceBirthSection+      }++incidentEdgeBirthsFor+  :: (PlanarSimplex label, PowerAlphaBirth)+  -> [(label, PowerAlphaBirth)]+incidentEdgeBirthsFor (simplex, birthValue) =+  case NonEmpty.toList (planarSimplexVertices simplex) of+    [firstLabel, secondLabel] ->+      [ (firstLabel, birthValue)+      , (secondLabel, birthValue)+        ]+    _ -> []++-- | Look up the exact birth of one admitted simplex.+regularAlphaSimplexBirth+  :: Ord label+  => PlanarSimplex label+  -> RegularAlphaFiltration label+  -> Maybe PowerAlphaBirth+regularAlphaSimplexBirth simplex = Map.lookup simplex . regularAlphaBirths++-- | Distinct births in ascending exact order.+regularAlphaCriticalBirths+  :: RegularAlphaFiltration label+  -> [PowerAlphaBirth]+regularAlphaCriticalBirths =+  Set.toAscList . Set.fromList . Map.elems . regularAlphaBirths++-- | Reconstruct the closed subcomplex born no later than the threshold.+regularAlphaComplexAtBirth+  :: Ord label+  => PowerAlphaBirth+  -> RegularAlphaFiltration label+  -> Either (RegularAlphaError label) (PlanarComplex label)+regularAlphaComplexAtBirth threshold filtration =+  first RegularAlphaSublevelInvalid+    ( planarComplex+        ( Map.keysSet+            (Map.filter (<= threshold) (regularAlphaBirths filtration))+        )+    )++edgeIsVisible :: Ord label => Set label -> RegularEdge label -> Bool+edgeIsVisible visible edge =+  let (firstLabel, secondLabel) = regularEdgeLabels edge+   in Set.member firstLabel visible && Set.member secondLabel visible++faceIsVisible :: Ord label => Set label -> RegularFace label -> Bool+faceIsVisible visible face =+  let (firstLabel, secondLabel, thirdLabel) = regularFaceLabels face+   in all (`Set.member` visible) [firstLabel, secondLabel, thirdLabel]++regularEdgeSimplex+  :: Ord label+  => RegularEdge label+  -> Either (RegularAlphaError label) (PlanarSimplex label)+regularEdgeSimplex edge =+  let (firstLabel, secondLabel) = regularEdgeLabels edge+   in first RegularAlphaSimplexInvalid (planarEdge firstLabel secondLabel)++regularFaceSimplex+  :: Ord label+  => RegularFace label+  -> Either (RegularAlphaError label) (PlanarSimplex label)+regularFaceSimplex face =+  let (firstLabel, secondLabel, thirdLabel) = regularFaceLabels face+   in first RegularAlphaSimplexInvalid+        (planarFace firstLabel secondLabel thirdLabel)++regularFaceBirth+  :: Ord label+  => RegularTriangulation label+  -> RegularFace label+  -> Either (RegularAlphaError label) (PlanarSimplex label, PowerAlphaBirth)+regularFaceBirth triangulation face = do+  simplex <- regularFaceSimplex face+  let (firstLabel, secondLabel, thirdLabel) = regularFaceLabels face+      dualPoint = regularFaceDualPoint face+  firstSite <- requireRegularSite triangulation firstLabel+  secondSite <- requireRegularSite triangulation secondLabel+  thirdSite <- requireRegularSite triangulation thirdLabel+  let firstBirth = powerDistance firstSite dualPoint+      secondBirth = powerDistance secondSite dualPoint+      thirdBirth = powerDistance thirdSite dualPoint+  requireEqualDual simplex firstBirth secondBirth+  requireEqualDual simplex firstBirth thirdBirth+  pure (simplex, PowerAlphaBirth firstBirth)++regularEdgeBirth+  :: Ord label+  => RegularTriangulation label+  -> RegularEdge label+  -> Either (RegularAlphaError label) (PlanarSimplex label, PowerAlphaBirth)+regularEdgeBirth triangulation edge = do+  simplex <- regularEdgeSimplex edge+  let (firstLabel, secondLabel) = regularEdgeLabels edge+  firstSite <- requireRegularSite triangulation firstLabel+  secondSite <- requireRegularSite triangulation secondLabel+  minimizingPoint <- minimizePowerOnDual simplex firstSite (regularEdgeDual edge)+  let firstBirth = powerDistance firstSite minimizingPoint+      secondBirth = powerDistance secondSite minimizingPoint+  requireEqualDual simplex firstBirth secondBirth+  pure (simplex, PowerAlphaBirth firstBirth)++regularVertexBirth+  :: Ord label+  => RegularTriangulation label+  -> Map label PowerAlphaBirth+  -> label+  -> Either (RegularAlphaError label) (PlanarSimplex label, PowerAlphaBirth)+regularVertexBirth triangulation incidentBirths label = do+  owner <- requireRegularSite triangulation label+  competitors <-+    traverse (requireRegularSite triangulation) (Set.toAscList (regularNeighbours label triangulation))+  let ownerPoint = powerSiteExactPosition owner+      ownerBirth = powerDistance owner ownerPoint+  if all ((ownerBirth <=) . (`powerDistance` ownerPoint)) competitors+    then Right (planarVertex label, PowerAlphaBirth ownerBirth)+    else+      case Map.lookup label incidentBirths of+        Just birthValue -> Right (planarVertex label, birthValue)+        Nothing -> Left (RegularAlphaVertexBirthMissing label)++minimizePowerOnDual+  :: PlanarSimplex label+  -> PowerSite label+  -> PowerDualEdge+  -> Either (RegularAlphaError label) ExactPoint+minimizePowerOnDual simplex site dual =+  case dual of+    BoundedPowerDual segment -> do+      let (origin, terminal) = exactSegmentEndpoints segment+      projected <- projectAlong simplex (powerSiteExactPosition site) origin (differenceVector origin terminal)+      pure (pointAtClampedParameter 0 1 origin (differenceVector origin terminal) projected)+    UnboundedPowerDual ray -> do+      let origin = exactRayOrigin ray+          direction = exactRayDirection ray+      projected <- projectAlong simplex (powerSiteExactPosition site) origin direction+      pure (pointAtParameter origin direction (max 0 projected))+    FullLinePowerDual line -> projectOntoLine simplex (powerSiteExactPosition site) line+    CollapsedPowerDual point -> Right point++projectAlong+  :: PlanarSimplex label+  -> ExactPoint+  -> ExactPoint+  -> ExactVector+  -> Either (RegularAlphaError label) ExactRational+projectAlong simplex query origin direction =+  let (queryX, queryY) = exactPointCoordinates query+      (originX, originY) = exactPointCoordinates origin+      ExactVector directionX directionY = direction+      numerator = (queryX - originX) * directionX + (queryY - originY) * directionY+      denominator = directionX * directionX + directionY * directionY+   in first (RegularAlphaProjectionFailed simplex)+        (exactDivide numerator denominator)++pointAtClampedParameter+  :: ExactRational+  -> ExactRational+  -> ExactPoint+  -> ExactVector+  -> ExactRational+  -> ExactPoint+pointAtClampedParameter lower upper origin direction parameter =+  pointAtParameter origin direction (max lower (min upper parameter))++pointAtParameter :: ExactPoint -> ExactVector -> ExactRational -> ExactPoint+pointAtParameter origin (ExactVector directionX directionY) parameter =+  let (originX, originY) = exactPointCoordinates origin+   in exactPoint+        (originX + parameter * directionX)+        (originY + parameter * directionY)++projectOntoLine+  :: PlanarSimplex label+  -> ExactPoint+  -> ExactAffineLine+  -> Either (RegularAlphaError label) ExactPoint+projectOntoLine simplex query line = do+  let (normalX, normalY, constant) = exactAffineLineCoefficients line+      (queryX, queryY) = exactPointCoordinates query+      lineValue = normalX * queryX + normalY * queryY + constant+      squaredNormal = normalX * normalX + normalY * normalY+  displacement <-+    first (RegularAlphaProjectionFailed simplex)+      (exactDivide lineValue squaredNormal)+  pure+    ( exactPoint+        (queryX - displacement * normalX)+        (queryY - displacement * normalY)+    )++powerDistance :: PowerSite label -> ExactPoint -> ExactRational+powerDistance site point =+  let (pointX, pointY) = exactPointCoordinates point+      (siteX, siteY) = exactPointCoordinates (powerSiteExactPosition site)+      deltaX = pointX - siteX+      deltaY = pointY - siteY+   in deltaX * deltaX + deltaY * deltaY - powerWeightExact (powerSiteWeight site)++differenceVector :: ExactPoint -> ExactPoint -> ExactVector+differenceVector from to =+  let (fromX, fromY) = exactPointCoordinates from+      (toX, toY) = exactPointCoordinates to+   in ExactVector (toX - fromX) (toY - fromY)++requireRegularSite+  :: Ord label+  => RegularTriangulation label+  -> label+  -> Either (RegularAlphaError label) (PowerSite label)+requireRegularSite triangulation label =+  maybe (Left (RegularAlphaSiteMissing label)) Right (regularSite label triangulation)++requireEqualDual+  :: PlanarSimplex label+  -> ExactRational+  -> ExactRational+  -> Either (RegularAlphaError label) ()+requireEqualDual simplex expected actual+  | expected == actual = Right ()+  | otherwise = Left (RegularAlphaDualMismatch simplex expected actual)
+ src-serialize/Moonlight/Hex/Serialization.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Versioned canonical bytes for native packed hexagonal regions.+module Moonlight.Hex.Serialization+  ( HexDecodingBudget (..)+  , HexSerializationError (..)+  , hexSerializationVersion+  , encodeHexRegion+  , decodeHexRegion+  ) where++import Control.DeepSeq (NFData)+import Control.Monad (replicateM)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)+import Data.Binary.Get+  ( Get+  , getInt64be+  , getWord16be+  , getWord64be+  , runGetOrFail+  )+import Data.Binary.Put+  ( putInt64be+  , putWord16be+  , putWord64be+  , runPut+  )+import Data.Bits ((.&.), complement, shiftL)+import Data.ByteString.Lazy qualified as BL+import Data.Int (Int64)+import Data.Vector.Unboxed qualified as U+import Data.Word (Word16, Word64)+import GHC.Generics (Generic)+import Moonlight.Hex.Coordinate (HexCoord (..))+import Moonlight.Hex.Region+  ( HexLayout+  , HexLayoutObstruction+  , HexRegion+  , hexLayout+  , hexLayoutCellCount+  , hexLayoutHeight+  , hexLayoutOrigin+  , hexLayoutWidth+  , hexLayoutWordCount+  , foldHexRegionPackedWords+  , hexRegionGenerate+  , hexRegionLayout+  )++-- | Bounds checked before any payload-sized allocation.+data HexDecodingBudget = HexDecodingBudget+  { hexDecodingMaximumInputBytes :: !Word64+  , hexDecodingMaximumCells :: !Word64+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++data HexSerializationError+  = HexBinaryDecodeFailure !Int64 !String+  | HexTrailingBytes !Word64+  | HexInvalidFormatMagic !Word64+  | HexUnsupportedFormatVersion !Word16+  | HexInputByteBudgetExceeded !Word64 !Word64+  | HexCellBudgetExceeded !Word64 !Word64+  | HexCoordinateOutsideInt !Int64 !Int64+  | HexExtentOutsideInt !Word64 !Word64+  | HexSerializedLayoutInvalid !HexLayoutObstruction+  | HexNonCanonicalPadding !Word64+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++hexSerializationVersion :: Word16+hexSerializationVersion = 1++formatMagic :: Word64+formatMagic = 0x4d4f4f4e48455801 -- "MOONHEX" + format family 1++encodeHexRegion :: HexRegion -> BL.ByteString+encodeHexRegion region = runPut $ do+  let layout = hexRegionLayout region+      HexCoord originQ originR = hexLayoutOrigin layout+  putWord64be formatMagic+  putWord16be hexSerializationVersion+  putInt64be (fromIntegral originQ)+  putInt64be (fromIntegral originR)+  putWord64be (fromIntegral (hexLayoutWidth layout))+  putWord64be (fromIntegral (hexLayoutHeight layout))+  foldHexRegionPackedWords+    (\writeWords word -> writeWords *> putWord64be word)+    (pure ())+    region++decodeHexRegion+  :: HexDecodingBudget+  -> BL.ByteString+  -> Either HexSerializationError HexRegion+decodeHexRegion budget bytes+  | inputBytes > hexDecodingMaximumInputBytes budget =+      Left (HexInputByteBudgetExceeded inputBytes (hexDecodingMaximumInputBytes budget))+  | otherwise =+      case runGetOrFail (runExceptT (getHexRegion budget)) bytes of+        Left (_, offset, message) -> Left (HexBinaryDecodeFailure offset message)+        Right (_, _, Left obstruction) -> Left obstruction+        Right (trailing, _, Right region)+          | BL.null trailing -> Right region+          | otherwise -> Left (HexTrailingBytes (fromIntegral (BL.length trailing)))+ where+  inputBytes = fromIntegral (BL.length bytes)++type HexDecoder = ExceptT HexSerializationError Get++getHexRegion :: HexDecodingBudget -> HexDecoder HexRegion+getHexRegion budget = do+  magic <- lift getWord64be+  if magic == formatMagic+    then pure ()+    else throwE (HexInvalidFormatMagic magic)+  version <- lift getWord16be+  if version == hexSerializationVersion+    then pure ()+    else throwE (HexUnsupportedFormatVersion version)+  q64 <- lift getInt64be+  r64 <- lift getInt64be+  width64 <- lift getWord64be+  height64 <- lift getWord64be+  (origin, width, height) <-+    case (int64PairToCoord q64 r64, word64ToInt width64, word64ToInt height64) of+      (Just coordinate, Just widthValue, Just heightValue) ->+        pure (coordinate, widthValue, heightValue)+      (Nothing, _, _) -> throwE (HexCoordinateOutsideInt q64 r64)+      (_, Nothing, _) -> throwE (HexExtentOutsideInt width64 height64)+      (_, _, Nothing) -> throwE (HexExtentOutsideInt width64 height64)+  layout <- either (throwE . HexSerializedLayoutInvalid) pure (hexLayout origin width height)+  let cellCount = fromIntegral (hexLayoutCellCount layout)+  if cellCount > hexDecodingMaximumCells budget+    then throwE (HexCellBudgetExceeded cellCount (hexDecodingMaximumCells budget))+    else pure ()+  serializedWords <- U.fromList <$> lift (replicateM (hexLayoutWordCount layout) getWord64be)+  validatePadding layout serializedWords+  pure (hexRegionGenerate layout (serializedMember layout serializedWords))++validatePadding :: HexLayout -> U.Vector Word64 -> HexDecoder ()+validatePadding layout wordsValue =+  let mask = finalWordMask layout+      canonical =+        U.ifoldl'+          (\valid index word ->+              valid+                && ( index + 1 < hexLayoutWordCount layout+                       || word .&. complement mask == 0+                   )+          )+          True+          wordsValue+   in if canonical+        then pure ()+        else+          let padding = U.foldl' (\_ word -> word .&. complement mask) 0 wordsValue+           in throwE (HexNonCanonicalPadding padding)++serializedMember :: HexLayout -> U.Vector Word64 -> HexCoord -> Bool+serializedMember layout wordsValue (HexCoord q r) =+  let HexCoord originQ originR = hexLayoutOrigin layout+      index = (r - originR) * hexLayoutWidth layout + (q - originQ)+      (wordIndex, bitIndex) = index `quotRem` 64+   in wordsValue `U.unsafeIndex` wordIndex .&. (1 `shiftL` bitIndex) /= 0+{-# INLINE serializedMember #-}++finalWordMask :: HexLayout -> Word64+finalWordMask layout = lowBitMask (((hexLayoutCellCount layout - 1) `rem` 64) + 1)++lowBitMask :: Int -> Word64+lowBitMask count+  | count >= 64 = maxBound+  | count <= 0 = 0+  | otherwise = (1 `shiftL` count) - 1++int64PairToCoord :: Int64 -> Int64 -> Maybe HexCoord+int64PairToCoord q r = HexCoord <$> int64ToInt q <*> int64ToInt r++int64ToInt :: Int64 -> Maybe Int+int64ToInt value+  | toInteger value < toInteger (minBound :: Int) = Nothing+  | toInteger value > toInteger (maxBound :: Int) = Nothing+  | otherwise = Just (fromIntegral value)++word64ToInt :: Word64 -> Maybe Int+word64ToInt value+  | toInteger value > toInteger (maxBound :: Int) = Nothing+  | otherwise = Just (fromIntegral value)
+ src-serialize/Moonlight/Triangulation/Serialization.hs view
@@ -0,0 +1,443 @@+{-# 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+  ( DecodingBudget (..)+  , TrustedPayloadDecoders+  , trustedBinaryPayloadDecoders+  , SerializedCountKind (..)+  , SerializationError (..)+  , serializationVersion+  , encodeTriangulation+  , decodeTriangulation+  ) where++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+  , getWord64be+  , getWord8+  , runGetOrFail+  )+import Data.Binary.Put+  ( putDoublebe+  , putWord16be+  , putWord32be+  , putWord64be+  , putWord8+  , runPut+  )+import qualified Data.ByteString.Lazy as BL+import Data.Foldable (traverse_)+import qualified Data.IntSet as IntSet+import Data.Int (Int64)+import Data.List.NonEmpty (NonEmpty (..))+import 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+  ( 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.Internal.HandleDefs+import Moonlight.Triangulation.Internal.Representation+import Moonlight.Triangulation.Internal.Types+import Moonlight.Triangulation.Math (canonicalCoordinate, mkQueryPoint)+import Moonlight.Triangulation.Validation (validateTriangulation)++instance Binary (Point) where+  put (Point x y) = putDoublebe x >> putDoublebe y+  get = Point <$> getDoublebe <*> getDoublebe++-- | 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+  | TrailingBytes !Int64+  | InvalidFormatMagic !Word64+  | UnsupportedFormatVersion !Word16+  | ConstraintModeTagMismatch !Word8 !Word8+  | CoordinateEncodingTagMismatch !Word8 !Word8+  | 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+  | InvalidSerializedPoint {-# UNPACK #-} !Int !PointValidationError+  | NonCanonicalSerializedConstraintFlag !UndirectedEdgeId !Word8+  | SerializedConstraintCountMismatch {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | UnconstrainedSerializedConstraints {-# UNPACK #-} !Int+  | DuplicateSerializedCoordinates {-# UNPACK #-} !Int {-# UNPACK #-} !Int+  | DecodedInvariantViolations !(NonEmpty InvariantViolation)+  deriving stock (Eq, Show)++type Decoder = ExceptT SerializationError Get++-- | The envelope version this module writes.+serializationVersion :: Word16+serializationVersion = 6++formatMagic :: Word64+formatMagic = 0x5350414445485307 -- "SPADEHS" + canonical geometry-owned format family++binary64EncodingTag :: Word8+binary64EncodingTag = 2++-- | Write the versioned binary envelope.+encodeTriangulation+  :: forall mode vertex directed undirected face. (KnownConstraintMode mode, Binary vertex, Binary directed, Binary undirected, Binary face)+  => Triangulation mode vertex directed undirected face+  -> BL.ByteString+encodeTriangulation triangulation = runPut $ do+  putWord64be formatMagic+  putWord16be serializationVersion+  putWord8 (modeTag (constraintModeValue (modeProxy triangulation)))+  putWord8 binary64EncodingTag+  let ElementDefaults directedDefault undirectedDefault faceDefault = triElementDefaults triangulation+      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.+  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 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 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+  => DecodingBudget+  -> TrustedPayloadDecoders vertex directed undirected face+  -> BL.ByteString+  -> Either SerializationError (Triangulation mode vertex directed undirected face)+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+    unless (magic == formatMagic) (throwE (InvalidFormatMagic magic))+    version <- lift getWord16be+    unless (version == serializationVersion) (throwE (UnsupportedFormatVersion version))+    encodedMode <- lift getWord8+    let expectedMode = modeTag (constraintModeValue (Proxy :: Proxy mode))+    unless (encodedMode == expectedMode) (throwE (ConstraintModeTagMismatch expectedMode encodedMode))+    encodedScalar <- lift getWord8+    let expectedScalar = binary64EncodingTag+    unless (encodedScalar == expectedScalar) (throwE (CoordinateEncodingTagMismatch expectedScalar encodedScalar))+    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 = fromIntegral encodedVertexCount+        halfCount = fromIntegral encodedDirectedEdgeCount+        edgeCount = halfCount `quot` 2+        faceCount = fromIntegral encodedFaceCount+        cachedConstraintCount = fromIntegral encodedConstraintCount+    defaults <- ElementDefaults <$> lift get <*> lift get <*> lift get+    pointXs <- U.replicateM vertexCount (canonicalCoordinate <$> lift getDoublebe)+    pointYs <- U.replicateM vertexCount (canonicalCoordinate <$> 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) ->+        throwE+          ( NonCanonicalSerializedConstraintFlag+              (UndirectedEdgeId (fromIntegral index))+              flag+          )+    let actualConstraintCount = U.foldl' (\count flag -> if flag == 1 then count + 1 else count) 0 constraints+    unless (cachedConstraintCount == actualConstraintCount) (throwE (SerializedConstraintCountMismatch cachedConstraintCount actualConstraintCount))+    when (expectedMode == 0 && actualConstraintCount /= 0) (throwE (UnconstrainedSerializedConstraints actualConstraintCount))++    let distinctPointCount = Set.size (V.foldl' (flip Set.insert) Set.empty points)+    unless (distinctPointCount == vertexCount) (throwE (DuplicateSerializedCoordinates vertexCount distinctPointCount))++    let pointXStore = fromLocalVector 0 pointXs+        pointYStore = fromLocalVector 0 pointYs+        topologyStore =+          fromVector maxBound $+            U.generate (4 * halfCount) $ \slot ->+              let (edge, field) = slot `quotRem` 4+               in case field of+                    0 -> halfOrigin U.! edge+                    1 -> halfNext U.! edge+                    2 -> halfPrev U.! edge+                    _ -> halfFace U.! edge+        constraintEdgeIndex =+          U.ifoldl'+            (\edges index flag ->+               if flag == 1 then IntSet.insert index edges else edges+            )+            IntSet.empty+            constraints+    pure+      Triangulation+        { triPointX = pointXStore+        , triPointY = pointYStore+        , triPointIndex = buildPointIndex pointXStore pointYStore+        , triVertexOut = fromLocalVector maxBound vertexOut+        , triVertexData = boxedFromVector vertexDefault vertexDataVector+        , triHalfTopology = topologyStore+        , triDirectedData = boxedFromVector (Just (defaultDirectedEdgeData defaults)) directedDataVector+        , triUndirectedData = boxedFromVector (Just (defaultUndirectedEdgeData defaults)) undirectedDataVector+        , triFaceEdge = fromLocalVector maxBound faceEdge+        , triFaceData = boxedFromVector (Just (defaultFaceData defaults)) faceDataVector+        , triConstraint = fromVector 0 constraints+        , triConstraintCount = cachedConstraintCount+        , triConstraintEdges = constraintEdgeIndex+        , triSeamFrontier = Nothing+        , triElementDefaults = defaults+        }++validateStoredPoint :: Int -> Point -> Decoder ()+validateStoredPoint index point =+  case mkQueryPoint point of+    Left failure -> throwE (InvalidSerializedPoint index failure)+    Right _ -> pure ()++modeProxy :: Triangulation mode vertex directed undirected face -> Proxy mode+modeProxy _ = Proxy++modeTag :: ConstraintMode -> Word8+modeTag Unconstrained = 0+modeTag Constrained = 1++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)++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+      )++-- 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++-- 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)++-- 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
+ src-zigzag/Moonlight/Triangulation/Zigzag.hs view
@@ -0,0 +1,454 @@+-- | Exact alpha-complex persistence across non-nested activation depths.+--+-- Each observed depth is rebuilt independently from stable labelled points.+-- Consecutive complexes are compared through the canonical union cospan+-- @K_i -> K_i union K_(i+1) <- K_(i+1)@.  Stable simplex labels, never DCEL+-- handles, own cross-mesh identity.  Homology remains the sole owner of the+-- zigzag interval decomposition.+module Moonlight.Triangulation.Zigzag+  ( ActivationPoint (..),+    ActivationSlice (..),+    ActivationStage (..),+    ActivationZigzagError (..),+    ActivationComplex,+    activationComplexStage,+    activationComplexCells,+    activationComplexBasisAt,+    activationComplexChainComplex,+    AdjacentUnionWitness,+    adjacentUnionStage,+    adjacentCommonCells,+    adjacentUnionComplex,+    adjacentLeftInclusion,+    adjacentRightInclusion,+    ActivationZigzag,+    activationZigzagStages,+    activationZigzagComplexes,+    activationZigzagCorrespondences,+    activationZigzagDiagram,+    ZigzagInterval (..),+    ActivationInterval,+    activationAlphaZigzag,+    activationZigzagIntervals,+    activationAlphaPersistence,+  )+where++import Data.Bifunctor (first)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import Moonlight.Core (firstDuplicate)+import Moonlight.Homology.Boundary+  ( BoundaryIncidence,+    FiniteChainComplex,+    overlapBoundaryIncidence,+  )+import Moonlight.Homology.Chain+  ( HomologicalDegree (..),+  )+import Moonlight.Homology.Persistence+  ( FiniteChainMap,+    FiniteChainZigzag,+    ZigzagArrow (..),+    ZigzagFailure,+    ZigzagInterval (..),+    mkFiniteChainMapChecked,+    mkFiniteChainZigzag,+    rationalZigzagIntervals,+  )+import Moonlight.Homology.Topology qualified as CellComplex+import Moonlight.Triangulation.Alpha+  ( AlphaFiltrationError,+    alphaComplexAtRadius,+    alphaFiltration,+  )+import Moonlight.Triangulation.BulkLoad+  ( DuplicatePayloadPolicy (KeepFirstPayload),+    delaunayFromCoordinates,+  )+import Moonlight.Triangulation.CellSet (CellSelectionError)+import Moonlight.Triangulation.CellComplex+  ( DCELComplex,+    fromExactCellSet,+  )+import Moonlight.Triangulation.LabelledComplex+  ( PlanarComplexInterpretationError,+    finitePlanarComplex,+  )+import Moonlight.Triangulation.Simplex+  ( PlanarComplex,+    PlanarComplexError,+    PlanarSimplex,+    PlanarSimplexError,+    SimplexDimension (..),+    intersectPlanarComplex,+    planarComplex,+    planarComplexBasisAt,+    planarComplexCells,+    planarEdge,+    planarFace,+    planarVertex,+    unionPlanarComplex,+  )+import Moonlight.Triangulation.Dcel qualified as Dcel+import Moonlight.Triangulation.Handles.HandleDefs+  ( FaceId,+    UndirectedEdgeId,+  )+import Moonlight.Triangulation.Types+  ( BuildError,+    BuildResult (..),+    BuildStats (..),+    DelaunayTriangulation,+    Point,+    RadiusSquared,+    unitElementDefaults,+  )++-- | One stable observation identity and its two-dimensional embedding.  The+-- coordinates may change at every depth; the label is the correspondence.+data ActivationPoint label = ActivationPoint+  { activationPointLabel :: !label,+    activationPointCoordinates :: !Point+  }+  deriving stock (Eq, Show)++-- | One independently sampled depth and the exact squared-radius alpha+-- threshold to observe there.+data ActivationSlice depth label = ActivationSlice+  { activationSliceDepth :: !depth,+    activationSliceRadiusSquared :: !RadiusSquared,+    activationSlicePoints :: !(Vector (ActivationPoint label))+  }+  deriving stock (Eq, Show)++-- | Vertices of the expanded zigzag alternate between observed depths and+-- their adjacent common ambient unions.+data ActivationStage depth+  = ObservedDepth !depth+  | AdjacentDepthUnion !depth !depth+  deriving stock (Eq, Ord, Show)++data ActivationZigzagError depth label+  = ActivationDuplicateDepth !depth+  | ActivationDuplicateLabel !depth !label+  | ActivationCoordinateCollapse !depth !Int !Int+  | ActivationBuildFailed !depth !BuildError+  | ActivationFiltrationFailed !depth !AlphaFiltrationError+  | ActivationSelectionFailed !depth !CellSelectionError+  | ActivationInnerFaceInvalid !(ActivationStage depth) !FaceId+  | ActivationSimplexInvalid !(ActivationStage depth) !(PlanarSimplexError label)+  | ActivationComplexInvalid !(ActivationStage depth) !(PlanarComplexError label)+  | ActivationChainComplexFailed+      !(ActivationStage depth)+      !(PlanarComplexInterpretationError label)+  | ActivationZigzagFailed !ZigzagFailure+  | ActivationStageIndexMissing !Int+  deriving stock (Eq, Show)++-- | A checked, canonically labelled simplicial interpretation of one observed+-- alpha complex or adjacent union.+data ActivationComplex depth label = ActivationComplex+  { activationComplexStage :: !(ActivationStage depth),+    storedActivationPlanarComplex :: !(PlanarComplex label),+    activationComplexChainComplex :: !(FiniteChainComplex Int)+  }++activationComplexCells+  :: ActivationComplex depth label+  -> Set (PlanarSimplex label)+activationComplexCells = planarComplexCells . storedActivationPlanarComplex++-- | The canonical labelled basis corresponding to the numeric basis of+-- 'activationComplexChainComplex' at one degree.+activationComplexBasisAt ::+  ActivationComplex depth label ->+  HomologicalDegree ->+  [PlanarSimplex label]+activationComplexBasisAt complexValue degreeValue =+  maybe+    []+    (Vector.toList . (`planarComplexBasisAt` storedActivationPlanarComplex complexValue))+    (simplexDimensionAt degreeValue)++-- | The two checked inclusion legs proving how adjacent observations meet in+-- their union.  The common-cell set is a derived inspection surface.+data AdjacentUnionWitness depth label = AdjacentUnionWitness+  { adjacentCommonCells :: !(Set (PlanarSimplex label)),+    adjacentUnionComplex :: !(ActivationComplex depth label),+    adjacentLeftInclusion :: !(FiniteChainMap Int),+    adjacentRightInclusion :: !(FiniteChainMap Int)+  }++adjacentUnionStage :: AdjacentUnionWitness depth label -> ActivationStage depth+adjacentUnionStage = activationComplexStage . adjacentUnionComplex++-- | The expanded stages, admitted observations, correspondence witnesses, and+-- authoritative Homology diagram travel together.+data ActivationZigzag depth label = ActivationZigzag+  { activationZigzagComplexes :: !(NonEmpty (ActivationComplex depth label)),+    activationZigzagCorrespondences :: !(Vector (AdjacentUnionWitness depth label)),+    activationZigzagDiagram :: !(FiniteChainZigzag Int)+  }++-- | The labelled view of the Homology diagram.  It is derived from the+-- admitted observations and their union witnesses rather than stored as a+-- second sequence that could disagree with them.+activationZigzagStages :: ActivationZigzag depth label -> Vector (ActivationStage depth)+activationZigzagStages zigzag =+  let firstComplex :| remainingComplexes = activationZigzagComplexes zigzag+   in Vector.fromList+        ( activationComplexStage firstComplex+            : concat+              ( zipWith+                  (\witness rightComplex ->+                      [adjacentUnionStage witness, activationComplexStage rightComplex]+                  )+                  (Vector.toList (activationZigzagCorrespondences zigzag))+                  remainingComplexes+              )+        )++-- | The Homology interval carrier with endpoints resolved into the activation+-- stage vocabulary.  This is a specialization, not a parallel record.+type ActivationInterval depth = ZigzagInterval (ActivationStage depth)++activationAlphaZigzag ::+  (Ord depth, Ord label) =>+  NonEmpty (ActivationSlice depth label) ->+  Either (ActivationZigzagError depth label) (ActivationZigzag depth label)+activationAlphaZigzag slices = do+  case firstDuplicate (fmap activationSliceDepth (NonEmpty.toList slices)) of+    Just duplicateDepth -> Left (ActivationDuplicateDepth duplicateDepth)+    Nothing -> Right ()+  observedComplexes <- traverse activationComplexFromSlice slices+  buildActivationZigzag+    (NonEmpty.zip (fmap activationSliceDepth slices) observedComplexes)++activationZigzagIntervals ::+  ActivationZigzag depth label ->+  Either (ActivationZigzagError depth label) [ActivationInterval depth]+activationZigzagIntervals zigzag = do+  intervals <-+    first ActivationZigzagFailed+      (rationalZigzagIntervals (activationZigzagDiagram zigzag))+  traverse (traverse (requireStage (activationZigzagStages zigzag))) intervals++activationAlphaPersistence ::+  (Ord depth, Ord label) =>+  NonEmpty (ActivationSlice depth label) ->+  Either (ActivationZigzagError depth label) [ActivationInterval depth]+activationAlphaPersistence slices =+  activationAlphaZigzag slices >>= activationZigzagIntervals++activationComplexFromSlice ::+  Ord label =>+  ActivationSlice depth label ->+  Either (ActivationZigzagError depth label) (ActivationComplex depth label)+activationComplexFromSlice slice = do+  let depthValue = activationSliceDepth slice+      points = activationSlicePoints slice+      labels = fmap activationPointLabel points+  case firstDuplicate (Vector.toList labels) of+    Just duplicateLabel -> Left (ActivationDuplicateLabel depthValue duplicateLabel)+    Nothing -> Right ()+  buildResult <-+    first (ActivationBuildFailed depthValue)+      ( delaunayFromCoordinates+          unitElementDefaults+          (fmap activationPointCoordinates points)+          labels+          KeepFirstPayload+      )+  let inputCount = Vector.length points+      uniqueCount = statUniquePoints (buildStats buildResult)+  if uniqueCount /= inputCount+    then Left (ActivationCoordinateCollapse depthValue inputCount uniqueCount)+    else do+      let triangulation = buildTriangulation buildResult+      filtration <-+        first (ActivationFiltrationFailed depthValue) (alphaFiltration triangulation)+      selectedCells <-+        first (ActivationSelectionFailed depthValue)+          (alphaComplexAtRadius (activationSliceRadiusSquared slice) filtration)+      let stage = ObservedDepth depthValue+      cellSet <- activationCellsFromDcel stage triangulation (fromExactCellSet selectedCells)+      compileActivationComplex stage cellSet++activationCellsFromDcel ::+  Ord label =>+  ActivationStage depth ->+  DelaunayTriangulation label ->+  DCELComplex ->+  Either (ActivationZigzagError depth label) (PlanarComplex label)+activationCellsFromDcel stage triangulation complexValue = do+  let vertexCells =+        fmap+          (planarVertex . Dcel.vertexData triangulation)+          (CellComplex.vertices complexValue)+  edgeCells <-+    traverse+      (activationEdgeFromDcel stage triangulation complexValue)+      (CellComplex.edges complexValue)+  faceCells <-+    traverse+      (activationFaceFromDcel stage triangulation)+      (CellComplex.faces complexValue)+  first (ActivationComplexInvalid stage)+    (planarComplex (Set.fromList (vertexCells <> edgeCells <> faceCells)))++activationEdgeFromDcel ::+  Ord label =>+  ActivationStage depth ->+  DelaunayTriangulation label ->+  DCELComplex ->+  UndirectedEdgeId ->+  Either (ActivationZigzagError depth label) (PlanarSimplex label)+activationEdgeFromDcel stage triangulation complexValue edgeValue =+  let (firstVertex, secondVertex) = CellComplex.edgeBoundary complexValue edgeValue+   in first (ActivationSimplexInvalid stage)+        ( planarEdge+            (Dcel.vertexData triangulation firstVertex)+            (Dcel.vertexData triangulation secondVertex)+        )++activationFaceFromDcel ::+  Ord label =>+  ActivationStage depth ->+  DelaunayTriangulation label ->+  FaceId ->+  Either (ActivationZigzagError depth label) (PlanarSimplex label)+activationFaceFromDcel stage triangulation faceValue =+  case Dcel.innerFaceVertices triangulation faceValue of+    Nothing -> Left (ActivationInnerFaceInvalid stage faceValue)+    Just (firstVertex, secondVertex, thirdVertex) ->+      first (ActivationSimplexInvalid stage)+        ( planarFace+            (Dcel.vertexData triangulation firstVertex)+            (Dcel.vertexData triangulation secondVertex)+            (Dcel.vertexData triangulation thirdVertex)+        )++compileActivationComplex ::+  Ord label =>+  ActivationStage depth ->+  PlanarComplex label ->+  Either (ActivationZigzagError depth label) (ActivationComplex depth label)+compileActivationComplex stage complexValue = do+  chainComplex <-+    first (ActivationChainComplexFailed stage)+      (finitePlanarComplex complexValue)+  pure+    ActivationComplex+      { activationComplexStage = stage,+        storedActivationPlanarComplex = complexValue,+        activationComplexChainComplex = chainComplex+      }++buildActivationZigzag ::+  Ord label =>+  NonEmpty (depth, ActivationComplex depth label) ->+  Either (ActivationZigzagError depth label) (ActivationZigzag depth label)+buildActivationZigzag observedEntries@((_, firstComplex) :| remainingEntries) = do+  correspondences <-+    traverse+      ( \((leftDepth, leftComplex), (rightDepth, rightComplex)) ->+          adjacentUnionWitness leftDepth rightDepth leftComplex rightComplex+      )+      (zip (NonEmpty.toList observedEntries) remainingEntries)+  let arrows =+        correspondences+          >>= ( \witness ->+                  [ ForwardArrow (adjacentLeftInclusion witness),+                    BackwardArrow (adjacentRightInclusion witness)+                  ]+              )+  diagram <-+    first ActivationZigzagFailed+      ( mkFiniteChainZigzag+          (activationComplexChainComplex firstComplex)+          arrows+      )+  pure+    ActivationZigzag+      { activationZigzagComplexes = fmap snd observedEntries,+        activationZigzagCorrespondences = Vector.fromList correspondences,+        activationZigzagDiagram = diagram+      }++adjacentUnionWitness ::+  Ord label =>+  depth ->+  depth ->+  ActivationComplex depth label ->+  ActivationComplex depth label ->+  Either (ActivationZigzagError depth label) (AdjacentUnionWitness depth label)+adjacentUnionWitness leftDepth rightDepth leftComplex rightComplex = do+  let unionStage =+        AdjacentDepthUnion leftDepth rightDepth+      unionPlanar =+        unionPlanarComplex+          (storedActivationPlanarComplex leftComplex)+          (storedActivationPlanarComplex rightComplex)+  unionComplex <- compileActivationComplex unionStage unionPlanar+  leftInclusion <- activationInclusion leftComplex unionComplex+  rightInclusion <- activationInclusion rightComplex unionComplex+  pure+    AdjacentUnionWitness+      { adjacentCommonCells =+          planarComplexCells+            ( intersectPlanarComplex+                (storedActivationPlanarComplex leftComplex)+                (storedActivationPlanarComplex rightComplex)+            ),+        adjacentUnionComplex = unionComplex,+        adjacentLeftInclusion = leftInclusion,+        adjacentRightInclusion = rightInclusion+      }++activationInclusion ::+  Ord label =>+  ActivationComplex depth label ->+  ActivationComplex depth label ->+  Either (ActivationZigzagError depth label) (FiniteChainMap Int)+activationInclusion sourceComplex targetComplex =+  first ActivationZigzagFailed+    ( mkFiniteChainMapChecked+        (activationComplexChainComplex sourceComplex)+        (activationComplexChainComplex targetComplex)+        (inclusionAtDegree sourceComplex targetComplex)+    )++inclusionAtDegree ::+  Ord label =>+  ActivationComplex depth label ->+  ActivationComplex depth label ->+  HomologicalDegree ->+  BoundaryIncidence Int+inclusionAtDegree sourceComplex targetComplex degreeValue =+  overlapBoundaryIncidence+    (1 :: Int)+    (activationComplexBasisAt sourceComplex degreeValue)+    (activationComplexBasisAt targetComplex degreeValue)++simplexDimensionAt :: HomologicalDegree -> Maybe SimplexDimension+simplexDimensionAt (HomologicalDegree degreeIndex) =+  case degreeIndex of+    0 -> Just SimplexDimension0+    1 -> Just SimplexDimension1+    2 -> Just SimplexDimension2+    _ -> Nothing++requireStage ::+  Vector (ActivationStage depth) ->+  Int ->+  Either (ActivationZigzagError depth label) (ActivationStage depth)+requireStage stages stageIndex =+  maybe+    (Left (ActivationStageIndexMissing stageIndex))+    Right+    (stages Vector.!? stageIndex)
+ test/algebra/Main.hs view
@@ -0,0 +1,13 @@+module Main (main) where++import qualified Moonlight.Triangulation.AlgebraSpec as AlgebraSpec+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+  ScheduleAgreementSpec.tests
+ test/algebra/Moonlight/Triangulation/AlgebraFixtures.hs view
@@ -0,0 +1,353 @@+-- | The operand meshes and mesh observations both algebra slices are stated+-- over, built against the facade alone.+module Moonlight.Triangulation.AlgebraFixtures+  ( Mesh+  , PointMesh+  , meshOf+  , inputOrderedMeshOf+  , pointMeshOf+  , integerPoint+  , rectangleComponent+  , rectangleRegion+  , polygonRegion+  , annulusRegion+  , insideLayer+  , overlayRegions+  , operands+  , separatedOperands+  , cocircularRing+  , collinearSites+  , latticeSites+  , pointsOf+  , dedupeAscending+  , siteList+  , siteSet+  , edgeKeys+  , assertMesh+  , assertMeshEquivalent+  , pairs+  , triples+  , advance+  , scramble+  , randomSites+  ) 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+  , geometryOnlyPublication+  , mapVertices+  , numFaces+  , numUndirectedEdges+  , numVertices+  , overlayLayers+  , planarLayer+  , planarRegion+  , polygonComponent+  , undirectedEdges+  , undirectedEndpoints+  , unitElementDefaults+  , vertexPoint+  , vertices+  )+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+-- destroys the elements they labelled.+type Mesh = DelaunayTriangulation ()++-- | The same carrier with its exact coordinate retained as the vertex+-- annotation. Annotation-preserving set laws use it to construct their+-- expected values without reaching below the public facade.+type PointMesh = DelaunayTriangulation Point++-- ── operands ─────────────────────────────────────────────────────────────────++-- | The site families the laws are exercised over.+--+-- Sized so that the cubic sweep in the associativity law stays cheap. Coverage+-- here is by /kind/ of degeneracy, not by count: what breaks a join is a+-- cocircular quad whose tie-break went the other way, or a mesh with no faces+-- at all, and neither of those becomes more likely at ten thousand sites.+families :: [(String, [Point])]+families =+  [ ("void", [])+  , ("single", [Point 3 (-7)])+  , ("pair", [Point 0 0, Point 4 1])+  , ("collinear", collinearSites)+  , ("cocircular", cocircularRing)+  , ("lattice", latticeSites)+  , ("repeated", concatMap (replicate 3) [Point 0 0, Point 5 0, Point 0 5, Point 5 5, Point 2 3])+  , ("scattered", randomSites 0xC0FFEEBABE 32)+  , ("extreme", [Point 1.0e-8 1.0e-8, Point 1.0e8 (-1.0e8), Point (-1.0e8) 1.0e8, Point 0 0, Point 1 1])+  ]++-- | Exactly cocircular lattice points on @x² + y² = 625@.+--+-- Trigonometric points would be cocircular only to within rounding, and the+-- rule this is here to exercise — the diagonal tie-break that fires when the+-- lifted quadrilateral is exactly flat — would then never fire at all.+cocircularRing :: [Point]+cocircularRing =+  [ Point (fromIntegral (signX * x)) (fromIntegral (signY * y))+  | (x, y) <- [(25, 0), (0, 25), (7, 24), (24, 7), (15, 20), (20, 15)] :: [(Int, Int)]+  , signX <- [1, -1]+  , signY <- [1, -1]+  ]++collinearSites :: [Point]+collinearSites = [Point (fromIntegral k) (2 * fromIntegral k - 1) | k <- [0 .. 9 :: Int]]++latticeSites :: [Point]+latticeSites = [Point (fromIntegral i) (fromIntegral j) | i <- [0 .. 4 :: Int], j <- [0 .. 4 :: Int]]++-- | The meshes every pairwise and triple law runs over.+--+-- Chosen for overlap structure rather than for size: disjoint operands, nested+-- ones, partially overlapping ones, the empty one, and — the case that matters+-- most — two meshes standing on the /same/ sites built in different orders, so+-- they are geometrically identical and structurally distinct.+operands :: IO [(String, Mesh)]+operands = do+  let sites name = fromMaybe [] (lookup name families)+      lattice = sites "lattice"+  void' <- meshOf "void" []+  single <- meshOf "single" (sites "single")+  collinear <- meshOf "collinear" (sites "collinear")+  ring <- meshOf "cocircular" (sites "cocircular")+  lower <- meshOf "lattice-lower" (take 15 lattice)+  upper <- meshOf "lattice-upper" (drop 10 lattice)+  repeated <- meshOf "repeated" (sites "repeated")+  scatterA <- meshOf "scattered" (sites "scattered")+  scatterB <- meshOf "scattered-scrambled" (scramble 0x5EED (sites "scattered"))+  pure+    [ ("void", void')+    , ("single", single)+    , ("collinear", collinear)+    , ("cocircular", ring)+    , ("lattice-lower", lower)+    , ("lattice-upper", upper)+    , ("repeated", repeated)+    , ("scattered", scatterA)+    , ("scattered-scrambled", scatterB)+    ]++-- | Operand pairs whose sites are separated by a vertical line, which is the+-- stratum a seam schedule is defined on and the one the old-edge identity is+-- sharpest over: with no shared site, every edge is unambiguously left, right+-- or cross.+separatedOperands :: IO [((String, Mesh), (String, Mesh))]+separatedOperands =+  traverse+    ( \(name, seed, count, shift) -> do+        let sites = randomSites seed count+        left <- meshOf (name <> "-left") sites+        right <- meshOf (name <> "-right") [Point (x + shift) y | Point x y <- sites]+        pure ((name <> "-left", left), (name <> "-right", right))+    )+    [ ("split-distant", 0x51DE1, 60, 1000)+    , ("split-near", 0x51DE2, 60, 3)+    , ("split-abutting", 0x51DE3, 60, 2.05)+    ]++-- ── construction ─────────────────────────────────────────────────────────────++meshOf :: String -> [Point] -> IO Mesh+meshOf label points =+  geometryOnlyPublication+    <$> 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]++dedupeAscending :: [(Double, Double)] -> [Point]+dedupeAscending sorted = [Point x y | (x, y) <- dropAdjacentDuplicates sorted]++dropAdjacentDuplicates :: Eq a => [a] -> [a]+dropAdjacentDuplicates (first : second : rest)+  | first == second = dropAdjacentDuplicates (second : rest)+  | otherwise = first : dropAdjacentDuplicates (second : rest)+dropAdjacentDuplicates rest = rest++-- ── observation ──────────────────────────────────────────────────────────────++siteKey :: Mesh -> VertexId -> (Double, Double)+siteKey mesh vertex = let Point x y = vertexPoint mesh vertex in (x, y)++siteList :: Mesh -> [(Double, Double)]+siteList mesh = [siteKey mesh vertex | vertex <- vertices mesh]++siteSet :: Mesh -> Set.Set (Double, Double)+siteSet = Set.fromList . siteList++edgeKeys :: Mesh -> Set.Set ((Double, Double), (Double, Double))+edgeKeys mesh =+  Set.fromList+    [ if left <= right then (left, right) else (right, left)+    | edge <- undirectedEdges mesh+    , let (from, to) = undirectedEndpoints mesh edge+    , let left = siteKey mesh from+    , let right = siteKey mesh to+    ]++-- | What a mesh looks like when two of them were supposed to be equal.+--+-- The interesting failure is the one where the coordinate-keyed edge sets+-- agree and the values do not: that is the join having become correct only up+-- to DCEL isomorphism, which is precisely what these laws exist to forbid, and+-- a report that only printed counts would hide it.+assertMesh :: String -> Mesh -> Mesh -> IO ()+assertMesh label expected actual+  | expected == actual = pure ()+  | otherwise = fail (label <> ": " <> report)+ where+  report+    | expectedEdges == actualEdges =+        "same geometry, different representation — "+          <> meshCounts expected+          <> " vs "+          <> meshCounts actual+    | otherwise =+        meshCounts expected+          <> " vs "+          <> meshCounts actual+          <> "; edges only in expected: "+          <> show (take 4 (Set.toList (Set.difference expectedEdges actualEdges)))+          <> "; only in actual: "+          <> show (take 4 (Set.toList (Set.difference actualEdges expectedEdges)))+  expectedEdges = edgeKeys expected+  actualEdges = edgeKeys actual++assertMeshEquivalent :: String -> Mesh -> Mesh -> IO ()+assertMeshEquivalent label expected actual = do+  canonicalExpected <-+    requireRight (label <> ": canonical expected") (canonicalize expected)+  canonicalActual <-+    requireRight (label <> ": canonical actual") (canonicalize actual)+  assertMesh label canonicalExpected canonicalActual++meshCounts :: Mesh -> String+meshCounts mesh =+  show (numVertices mesh)+    <> "v/"+    <> show (numUndirectedEdges mesh)+    <> "e/"+    <> show (numFaces mesh)+    <> "f"++-- ── combinatorics and pseudo-randomness ──────────────────────────────────────++pairs :: [a] -> [(a, a)]+pairs values = [(left, right) | left <- values, right <- values]++triples :: [a] -> [(a, a, a)]+triples values = [(a, b, c) | a <- values, b <- values, c <- values]++advance :: Word64 -> Word64+advance state = state * 6364136223846793005 + 1442695040888963407++randomWords :: Word64 -> Int -> [Word64]+randomWords seed count = take count (drop 1 (iterate advance seed))++-- | A deterministic permutation: decorate, sort by the key, discard it.+scramble :: Word64 -> [a] -> [a]+scramble seed values =+  map snd (sortBy (comparing fst) (zip (randomWords seed (length values)) values))++randomSites :: Word64 -> Int -> [Point]+randomSites seed count =+  [ Point (unitCoordinate first) (unitCoordinate second)+  | (first, second) <- take count (chunkPairs (randomWords seed (2 * count)))+  ]++chunkPairs :: [a] -> [(a, a)]+chunkPairs (first : second : rest) = (first, second) : chunkPairs rest+chunkPairs _ = []++unitCoordinate :: Word64 -> Double+unitCoordinate value = 2 * fromIntegral (value `div` 2048) / 9007199254740992 - 1
+ test/algebra/Moonlight/Triangulation/AlgebraSpec.hs view
@@ -0,0 +1,919 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | The laws of finite union, stated against the typed facade a caller has.+--+-- Algebraic laws are observed through 'canonicalize'. Structural 'Eq' remains+-- the exact physical-representation observation used by round trips and caches.+module Moonlight.Triangulation.AlgebraSpec (tests) where++import Control.Monad (forM_, unless, when)+import Data.Foldable (traverse_)+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.List (sort)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Word (Word64)+import qualified Data.Vector as V+import Moonlight.Triangulation+  ( BuildError+  , ConstraintMode (..)+  , DelaunayTriangulation+  , DuplicatePayloadPolicy (..)+  , HasPosition (..)+  , JoinSemilattice (..)+  , Point (Point)+  , Triangulation+  , buildTriangulation+  , delaunay+  , delaunayFromCoordinates+  , delaunayGeometry+  , unitElementDefaults+  , vertexData+  , vertexPoint+  , vertices+  , SiteRelation (..)+  , canonicalize+  , difference+  , intersection+  , intersectionWith+  , mapVertices+  , numVertices+  , siteRelation+  , symmetricDifference+  , union+  , unions+  , validateTriangulation+  )+import Moonlight.Triangulation.AlgebraFixtures+  ( Mesh+  , advance+  , assertMesh+  , assertMeshEquivalent+  , cocircularRing+  , collinearSites+  , dedupeAscending+  , edgeKeys+  , inputOrderedMeshOf+  , latticeSites+  , meshOf+  , operands+  , pairs+  , pointMeshOf+  , pointsOf+  , randomSites+  , scramble+  , separatedOperands+  , siteList+  , siteSet+  , triples+  )+import Support (requireRight)++tests :: IO ()+tests = do+  testConstructionEntrances+  testJoinIdentity+  testJoinCommutative+  testJoinAssociative+  testJoinIdempotent+  testJoinGeneralPathIdempotent+  testJoinSiteUnion+  testJoinGluesAnnotations+  testJoinIsUnionRebuild+  testJoinResultValid+  testSkewedJoinPreservesBaseHandles+  testJoinBalancedFold+  testJoinPartitionTrees+  testConstructionOrderIndependent+  testCanonicalPublication+  testSiteRelationCoherence+  testMeetLaws+  testEmptySetIdentitiesPreserveVerbatim+  testSkewedSetOperationsRemainValid+  testDifferenceLaws+  testSymmetricDifferenceLaws+  testLatticeLaws+  testSetOperationsPublishCanonical+  testAnnotationPreservation+  testOldEdgeAccounting+  putStrLn "algebra: ok"++testConstructionEntrances :: IO ()+testConstructionEntrances = do+  let coordinates = V.fromList [Point 0 0, Point 3 0, Point 0 4, Point 0 0]+      payloads = V.fromList [2 :: Int, 3, 5, 7]+  geometry <- requireRight "geometry-only construction" (delaunayGeometry coordinates)+  legacy <-+    mapVertices (const ()) . buildTriangulation+      <$> requireRight "annotated point construction" (delaunay unitElementDefaults coordinates)+  assertMeshEquivalent+    "geometry-only construction agrees with annotated point construction"+    legacy+    geometry+  annotated <-+    buildTriangulation+      <$> requireRight+            "coordinate/payload construction"+            ( delaunayFromCoordinates+                unitElementDefaults+                coordinates+                payloads+                (CombineDuplicatePayload (+))+            )+  unless (validateTriangulation geometry == [] && validateTriangulation annotated == []) $+    fail "public construction entrance produced an invalid triangulation"+  let observed =+        Map.fromList+          [ ((x, y), vertexData annotated vertex)+          | vertex <- vertices annotated+          , let Point x y = vertexPoint annotated vertex+          ]+      expected = Map.fromList [((0, 0), 9), ((3, 0), 3), ((0, 4), 5)]+  unless (observed == expected) $+    fail "delaunayFromCoordinates did not apply its duplicate payload policy"++-- ── laws ─────────────────────────────────────────────────────────────────────++testJoinIdentity :: IO ()+testJoinIdentity = do+  values <- operands+  identity <- requireRight "union identity" (unions [])+  forM_ values $ \(name, mesh) -> do+    left <- requireRight ("left identity at " <> name) (union identity mesh)+    right <- requireRight ("right identity at " <> name) (union mesh identity)+    assertMesh ("left identity at " <> name) mesh left+    assertMesh ("right identity at " <> name) mesh right+  idempotent <- requireRight "identity is idempotent" (union identity identity)+  assertMesh "identity is idempotent" identity idempotent++testJoinCommutative :: IO ()+testJoinCommutative = do+  values <- operands+  forM_ (pairs values) $ \((leftName, left), (rightName, right)) -> do+    leftRight <- requireRight "commutative union left/right" (union left right)+    rightLeft <- requireRight "commutative union right/left" (union right left)+    assertMeshEquivalent+      ("commutativity at " <> leftName <> " ⋄ " <> rightName)+      leftRight+      rightLeft++testJoinAssociative :: IO ()+testJoinAssociative = do+  values <- operands+  forM_ (triples values) $ \((aName, a), (bName, b), (cName, c)) -> do+    leftAssociated <- requireRight "left-associated union" (union a b >>= (`union` c))+    rightAssociated <- requireRight "right-associated union" (union b c >>= union a)+    assertMeshEquivalent+      ("associativity at " <> aName <> " ⋄ " <> bName <> " ⋄ " <> cName)+      leftAssociated+      rightAssociated++testJoinIdempotent :: IO ()+testJoinIdempotent = do+  values <- operands+  forM_ values $ \(name, mesh) -> do+    result <- requireRight ("idempotence at " <> name) (union mesh mesh)+    assertMesh ("idempotence at " <> name) mesh result++-- | Idempotence with the structural-equality shortcut deliberately disarmed.+--+-- @a \<\> a@ is answered by a shortcut that compares the operands and returns+-- one verbatim, so on its own it says nothing about the operator underneath.+-- Three meshes standing on the same sites, built in three different orders, are+-- pairwise distinct as values — the test asserts that before relying on it —+-- so every join below takes the general path, and joining a fourth+-- representation of the same site set onto the result must still change+-- nothing.+testJoinGeneralPathIdempotent :: IO ()+testJoinGeneralPathIdempotent = do+  let base = randomSites 0xA11CE 40+  first <- 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)+  thirdResult <- requireRight "absorbing a third representation" (union joined third)+  fourthResult <- requireRight "absorbing a fourth representation" (union joined fourth)+  symmetric <- requireRight "the union of two representations is symmetric" (union second first)+  assertMeshEquivalent "absorbing a third representation" joined thirdResult+  assertMeshEquivalent "absorbing a fourth representation" joined fourthResult+  assertMeshEquivalent "the union of two representations is symmetric" joined symmetric++-- | The sites of a join are exactly the union of the operands' sites: none+-- dropped, none invented, each stored once.+testJoinSiteUnion :: IO ()+testJoinSiteUnion = do+  values <- operands+  forM_ (pairs values) $ \((leftName, left), (rightName, right)) -> do+    let label = leftName <> " ⋄ " <> rightName+        expected = Set.union (siteSet left) (siteSet right)+    joined <- requireRight ("site union at " <> label) (union left right)+    let actual = siteSet joined+    unless (expected == actual) $+      fail+        ( "site union at "+            <> label+            <> ": dropped "+            <> show (Set.toList (Set.difference expected actual))+            <> ", invented "+            <> show (Set.toList (Set.difference actual expected))+        )+    unless (Set.size actual == numVertices joined) $+      fail ("site union at " <> label <> ": a site is stored more than once")++-- | The reference semantics: a join /is/ a rebuild of the union when both are+-- observed canonically.+--+-- The union is rebuilt three times, in three unrelated orders, and all three+-- must canonicalize to the canonical observation of the join. Comparing+-- against a single rebuild would only say the two agree; comparing against+-- three says that what they agree on is a function of the site set and not of+-- any build schedule, which is the actual claim.+--+-- Both shortcut cases are excluded, because a shortcut returns an operand+-- verbatim and an operand need not be canonically published. The count of+-- pairs that actually reached the general path is asserted, so this cannot+-- quietly become a test of nothing.+testJoinIsUnionRebuild :: IO ()+testJoinIsUnionRebuild = do+  values <- operands+  exercised <- newIORef (0 :: Int)+  forM_ (pairs values) $ \((leftName, left), (rightName, right)) ->+    when (numVertices left > 0 && numVertices right > 0 && left /= right) $ do+      let label = leftName <> " ⋄ " <> rightName+          unionSites = siteList left <> siteList right+      joined <- requireRight ("union of " <> label) (union left right)+      canonicalJoined <- requireRight ("canonical union of " <> label) (canonicalize joined)+      forM_ [("ranked", dedupeAscending (sort unionSites)), ("reversed", pointsOf (reverse unionSites)), ("scrambled", pointsOf (scramble 0x7A57E unionSites))] $+        \(order, sites) -> do+          rebuilt <- meshOf ("rebuild of " <> label <> " in " <> order <> " order") sites+          canonical <- requireRight ("canonical rebuild of " <> label <> " in " <> order <> " order") (canonicalize rebuilt)+          assertMesh+            ("join equals canonical rebuild at " <> label <> " (" <> order <> ")")+            canonical+            canonicalJoined+      modifyIORef' exercised (+ 1)+  count <- readIORef exercised+  unless (count >= 40) $+    fail ("join-equals-rebuild exercised only " <> show count <> " general-path pairs")++-- | Canonical publication in its own right, since the union laws lean on it.+--+-- Renumbering must not move geometry, must be a fixed point, must leave a+-- valid triangulation, and — the load-bearing one — must send every build+-- order of a site set to the same value. The distinctness of the inputs is+-- asserted first, so a canonicalization that did nothing at all would fail+-- here rather than pass everything.+testCanonicalPublication :: IO ()+testCanonicalPublication = do+  values <- operands+  forM_ values $ \(name, mesh) -> do+    canonical <- requireRight ("canonicalization at " <> name) (canonicalize mesh)+    unless (siteSet canonical == siteSet mesh) $+      fail ("canonicalization at " <> name <> " moved the site set")+    unless (edgeKeys canonical == edgeKeys mesh) $+      fail ("canonicalization at " <> name <> " changed the triangulation")+    case validateTriangulation canonical of+      [] -> pure ()+      violations -> fail ("canonicalization at " <> name <> " is invalid: " <> show violations)+    fixedPoint <- requireRight ("canonicalization fixed point at " <> name) (canonicalize canonical)+    assertMesh ("canonicalization at " <> name <> " is a fixed point") canonical fixedPoint+  forM_ [("scattered", randomSites 0xB0A710 48), ("cocircular", cocircularRing), ("lattice", latticeSites), ("collinear", collinearSites)] $+    \(name, base) -> do+      built <-+        traverse+          (\(order, sites) -> (,) order <$> inputOrderedMeshOf (name <> "/" <> order) sites)+          [ ("input", base)+          , ("ranked", dedupeAscending (sort [(x, y) | Point x y <- base]))+          , ("reversed", reverse base)+          , ("scrambled", scramble 0x6666 base)+          ]+      case built of+        [] -> fail "canonical publication: nothing built"+        (_, reference) : rest -> do+          unless (any (\(_, mesh) -> mesh /= reference) rest) $+            fail ("canonical publication at " <> name <> ": every order already agreed, so this asserts nothing")+          canonicalReference <- requireRight ("canonical reference at " <> name) (canonicalize reference)+          forM_ rest $ \(order, mesh) -> do+            canonicalMesh <- requireRight ("canonical publication at " <> name <> " from " <> order <> " order") (canonicalize mesh)+            assertMesh+              ("canonical publication at " <> name <> " from " <> order <> " order")+              canonicalReference+              canonicalMesh++testJoinResultValid :: IO ()+testJoinResultValid = do+  values <- operands+  forM_ (pairs values) $ \((leftName, left), (rightName, right)) -> do+    joined <- requireRight ("valid union at " <> leftName <> " ⋄ " <> rightName) (union left right)+    case validateTriangulation joined of+      [] -> pure ()+      violations ->+        fail ("join at " <> leftName <> " ⋄ " <> rightName <> " is invalid: " <> show violations)++testSkewedJoinPreservesBaseHandles :: IO ()+testSkewedJoinPreservesBaseHandles = do+  let baseSites = randomSites 0x5A71E 256+      extensionSites =+        fmap+          (\(Point x y) -> Point (x + 4) y)+          (randomSites 0xE71E 16)+  base <- meshOf "persistent base" baseSites+  extension <- meshOf "persistent extension" extensionSites+  joined <- requireRight "persistent skewed union" (union base extension)+  let baseObservations = fmap (\vertex -> (vertex, vertexPoint base vertex)) (vertices base)+  forM_ baseObservations $ \(vertex, expectedPoint) ->+    unless (vertexPoint joined vertex == expectedPoint) $+      fail+        ( "persistent skewed union moved base handle "+            <> show vertex+            <> " from "+            <> show expectedPoint+            <> " to "+            <> show (vertexPoint joined vertex)+        )+  canonicalJoined <- requireRight "canonical persistent skewed union" (canonicalize joined)+  reference <- meshOf "persistent union reference" (baseSites <> extensionSites)+  canonicalReference <- requireRight "canonical persistent union reference" (canonicalize reference)+  assertMesh "persistent skewed union agrees with canonical reference" canonicalReference canonicalJoined++-- | The balanced tournament agrees with every typed fold, in both directions.+testJoinBalancedFold :: IO ()+testJoinBalancedFold = do+  shards <- shardMeshes 6 (randomSites 0xBA5EBA11 48)+  identity <- requireRight "empty union" (unions [])+  case shards of+    [] -> fail "balanced fold: no shards were built"+    firstShard : _ -> do+      expected <- requireRight "balanced unions" (unions shards)+      foldRight <- requireRight "right-folded unions" (foldr (\shard result -> result >>= union shard) (Right identity) shards)+      foldLeft <- requireRight "left-folded unions" (foldl (\result shard -> result >>= (`union` shard)) (Right identity) shards)+      singleton <- requireRight "singleton unions" (unions [firstShard])+      repeated <- requireRight "repeated unions" (unions [firstShard, firstShard])+      assertMeshEquivalent "balanced unions agree with foldr" expected foldRight+      assertMeshEquivalent "balanced unions agree with foldl" expected foldLeft+      assertMesh "unions of one shard is that shard" firstShard singleton+      assertMesh "unions respects the idempotence shortcut" firstShard repeated++-- | The document's partition test: one site set, many shardings, many+-- bracketings, one canonical observation.+testJoinPartitionTrees :: IO ()+testJoinPartitionTrees = do+  let base = randomSites 0xD15EA5E 54+  whole <- meshOf "whole" base+  reference <- requireRight "canonical whole partition reference" (canonicalize whole)+  forM_ ([2, 3, 5, 7] :: [Int]) $ \shardCount -> do+    shards <- shardMeshes shardCount base+    forM_ ([0 .. 7] :: [Int]) $ \shape -> do+      let scrambled = scramble (fromIntegral shape * 7919 + 13) shards+      result <-+        requireRight+          ("partition tree " <> show shardCount <> "/" <> show shape)+          (bracketRandomly (fromIntegral shape * 104729 + 7) scrambled)+      assertMeshEquivalent+        ("partition tree " <> show shardCount <> "/" <> show shape)+        reference+        result++-- | Delaunay uniqueness, stated as a law about this construction: the same+-- sites in any order give the same triangulation, and differ only in how it is+-- numbered.+--+-- Both halves are asserted, and the second is the one that carries weight. If+-- the numbering did /not/ differ, canonical publication would be a no-op and+-- the quotient this test names would be trivial. Because it does differ, this+-- law licenses construction in whichever order is cheapest and an explicit+-- canonical observation only where physical agreement is required.+--+-- The cocircular ring and the lattice are here because they are where it could+-- fail: an exactly flat lifted quadrilateral has two legal diagonals, and the+-- rule that picks between them is keyed on coordinates rather than on vertex+-- identifiers precisely so that this law holds.+testConstructionOrderIndependent :: IO ()+testConstructionOrderIndependent = do+  forM_ [("scattered", randomSites 0x0DDBA11 60), ("cocircular", cocircularRing), ("lattice", latticeSites)] $+    \(name, base) -> do+      let ranked = dedupeAscending (sort [(x, y) | Point x y <- base])+      meshes <-+        traverse+          (\(order, sites) -> (,) order <$> inputOrderedMeshOf (name <> "/" <> order) sites)+          [ ("input", base)+          , ("ranked", ranked)+          , ("reversed", reverse base)+          , ("scrambled-a", scramble 0x3333 base)+          , ("scrambled-b", scramble 0x4444 base)+          ]+      case meshes of+        [] -> fail "order independence: nothing built"+        (referenceOrder, reference) : rest -> do+          forM_ rest $ \(order, mesh) ->+            unless (edgeKeys reference == edgeKeys mesh) $+              fail+                ( "order independence at "+                    <> name+                    <> ": "+                    <> referenceOrder+                    <> " and "+                    <> order+                    <> " reached different triangulations"+                )+          unless (any (\(_, mesh) -> mesh /= reference) rest) $+            fail+              ( "order independence at "+                  <> name+                  <> ": every build order produced the identical value, so the"+                  <> " numbering quotient is trivial and this law asserts nothing"+              )++-- | The Guibas–Stolfi old-edge theorem, asserted as a law of the operator.+--+-- Adding sites to a Delaunay triangulation cannot create an edge between two+-- sites that were already there. So every edge of a join whose endpoints both+-- stood in one operand must already have been an edge of that operand, and any+-- other edge is bichromatic — it joins a site exclusive to the left to a site+-- exclusive to the right.+--+-- This is strictly stronger than checking that the result is a valid Delaunay+-- triangulation, and it is stronger in exactly the direction a merge schedule+-- fails in. A seam that stitches the wrong pair of hull vertices, or that+-- retracts one edge too far before it stops deleting, produces a mesh that is+-- still Delaunay for /some/ site set and still passes validation; what it does+-- not do is leave the two interiors alone. The identity names that.+--+-- It holds for every schedule, including the rebuild the operator uses today,+-- because it is a property of the Delaunay triangulation of the union and not+-- of the route taken to it. That is why it can be asserted before a second+-- schedule exists: it is the gate one would have to pass, green on the path+-- that is already trusted.+--+-- Degeneracy does not weaken it. The tie-break on an exactly cocircular+-- quadrilateral is keyed on the four coordinates alone, so the same quad+-- resolves the same way whatever else stands nearby; a cocircular diagonal can+-- therefore be lost when a site lands inside its circle, which the theorem+-- permits, but cannot be exchanged for the other diagonal, which it forbids.+testOldEdgeAccounting :: IO ()+testOldEdgeAccounting = do+  overlapping <- operands+  separated <- separatedOperands+  census <- newIORef (0 :: Int, 0 :: Int)+  forM_ ([(l, r) | l <- overlapping, r <- overlapping] <> separated) $ \((leftName, left), (rightName, right)) -> do+    let label = "old-edge " <> leftName <> " / " <> rightName+    joined <- requireRight label (union left right)+    let leftSites = siteSet left+        rightSites = siteSet right+        leftEdges = edgeKeys left+        rightEdges = edgeKeys right+    forM_ (Set.toList (edgeKeys joined)) $ \edge -> do+      let (from, to) = edge+          spans sites = Set.member from sites && Set.member to sites+          monochromeLeft = spans leftSites+          monochromeRight = spans rightSites+      when (monochromeLeft && not (Set.member edge leftEdges)) $+        fail (label <> ": join created " <> show edge <> ", an edge between two sites of the left operand")+      when (monochromeRight && not (Set.member edge rightEdges)) $+        fail (label <> ": join created " <> show edge <> ", an edge between two sites of the right operand")+      modifyIORef' census $ \(retained, cross) ->+        if monochromeLeft || monochromeRight+          then (retained + 1, cross)+          else (retained, cross + 1)+  (retained, cross) <- readIORef census+  when (retained < 1000 || cross < 100) $+    fail+      ( "old-edge accounting: the census is too thin to have asserted anything — "+          <> show retained+          <> " retained and "+          <> show cross+          <> " cross edges"+      )++-- ── finite-set descent laws ─────────────────────────────────────────────────++-- | The public support relation is the exact order observation of the same+-- site sets consumed by union, meet and relative complement. Its overlap+-- witness must therefore agree with every operation's cardinality rather than+-- merely with another classification routine.+testSiteRelationCoherence :: IO ()+testSiteRelationCoherence = do+  values <- operands+  traverse_ (uncurry checkRelation) (pairs values)+ where+  checkRelation (leftName, left) (rightName, right) = do+    let label = "site relation at " <> leftName <> " / " <> rightName+        leftSites = siteSet left+        rightSites = siteSet right+        overlap = Set.size (Set.intersection leftSites rightSites)+        expected = referenceSiteRelation leftSites rightSites+        coldActual = siteRelation left right+    unless (coldActual == expected) $+      fail (label <> ": expected " <> show expected <> ", got " <> show coldActual)+    let repeatedActual = siteRelation left right+    unless (repeatedActual == coldActual) $+      fail (label <> ": repeated observation changed the relation")+    met <- requireRight (label <> " intersection") (intersection left right)+    removed <- requireRight (label <> " difference") (difference left right)+    joined <- requireRight (label <> " union") (union left right)+    unless (numVertices met == overlap) $+      fail (label <> ": intersection cardinality disagrees with overlap")+    unless (numVertices removed == Set.size leftSites - overlap) $+      fail (label <> ": difference cardinality disagrees with overlap")+    unless (numVertices joined == Set.size leftSites + Set.size rightSites - overlap) $+      fail (label <> ": union cardinality disagrees with overlap")++referenceSiteRelation+  :: Set.Set (Double, Double)+  -> Set.Set (Double, Double)+  -> SiteRelation+referenceSiteRelation left right+  | left == right = EqualSites+  | left `Set.isProperSubsetOf` right = LeftProperSubset+  | right `Set.isProperSubsetOf` left = RightProperSubset+  | Set.null overlap = DisjointSites+  | otherwise = PartialOverlap (Set.size overlap)+ where+  overlap = Set.intersection left right++testMeetLaws :: IO ()+testMeetLaws = do+  values <- setLawOperands+  traverse_+    ( \(name, mesh) ->+        assertSetEquation+          ("meet idempotence at " <> name)+          (intersection mesh mesh)+          (canonicalize mesh)+    )+    values+  traverse_+    ( \((leftName, left), (rightName, right)) ->+        assertSetEquation+          ("meet commutativity at " <> leftName <> " / " <> rightName)+          (intersection left right)+          (intersection right left)+    )+    (pairs values)+  traverse_+    ( \((aName, a), (bName, b), (cName, c)) ->+        assertSetEquation+          ("meet associativity at " <> aName <> " / " <> bName <> " / " <> cName)+          (intersection a b >>= (`intersection` c))+          (intersection b c >>= intersection a)+    )+    (triples values)++testEmptySetIdentitiesPreserveVerbatim :: IO ()+testEmptySetIdentitiesPreserveVerbatim = do+  let sites = scramble 0xE771D3 (randomSites 0xE771D4 48)+  mesh <- 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"+  empty <- requireRight "verbatim empty identity" (unions [])+  differenceRightIdentity <- requireRight "verbatim difference right identity" (difference mesh empty)+  differenceLeftZero <- requireRight "verbatim difference left zero" (difference empty mesh)+  symmetricRightIdentity <- requireRight "verbatim symmetric difference right identity" (symmetricDifference mesh empty)+  symmetricLeftIdentity <- requireRight "verbatim symmetric difference left identity" (symmetricDifference empty mesh)+  assertMesh "difference by empty preserves the left representative verbatim" mesh differenceRightIdentity+  assertMesh "empty difference remains the empty representative" empty differenceLeftZero+  assertMesh "symmetric difference by empty preserves the left representative verbatim" mesh symmetricRightIdentity+  assertMesh "empty symmetric difference preserves the right representative verbatim" mesh symmetricLeftIdentity++testSkewedSetOperationsRemainValid :: IO ()+testSkewedSetOperationsRemainValid = do+  let baseSites = randomSites 0xD1FFE7 1024+      removedSites = take 4 (scramble 0xD1FFE8 baseSites)+      retainedSites = filter (`notElem` removedSites) baseSites+      disjointIncomingSites = fmap (\(Point x y) -> Point (x + 4) y) (randomSites 0xD1FFE9 4)+      nearFullIntersectionSites = retainedSites <> disjointIncomingSites+      overlappingRemovedSites = take 2 removedSites+      overlappingIncomingSites = overlappingRemovedSites <> take 2 disjointIncomingSites+      xorDisjointSites = baseSites <> disjointIncomingSites+      xorOverlappingSites = filter (`notElem` overlappingRemovedSites) baseSites <> take 2 disjointIncomingSites+  base <- meshOf "skewed set-operation base" baseSites+  removed <- meshOf "skewed difference subset" removedSites+  disjointIncoming <- meshOf "skewed difference disjoint" disjointIncomingSites+  nearFullIntersection <- meshOf "skewed geometry-only intersection" nearFullIntersectionSites+  overlappingIncoming <- meshOf "skewed xor overlapping" overlappingIncomingSites+  differenceSubset <- requireRight "skewed difference subset" (difference base removed)+  differenceDisjoint <- requireRight "skewed difference disjoint" (difference base disjointIncoming)+  intersectionNearFull <- requireRight "skewed geometry-only intersection" (intersection base nearFullIntersection)+  xorDisjoint <- requireRight "skewed xor disjoint" (symmetricDifference base disjointIncoming)+  xorOverlapping <- requireRight "skewed xor overlapping" (symmetricDifference base overlappingIncoming)+  assertRawSetResult "skewed difference subset" retainedSites differenceSubset+  assertRawSetResult "skewed difference disjoint" baseSites differenceDisjoint+  assertMesh "skewed difference disjoint preserves the base verbatim" base differenceDisjoint+  assertRawSetResult "skewed geometry-only intersection" retainedSites intersectionNearFull+  assertRawSetResult "skewed xor disjoint" xorDisjointSites xorDisjoint+  assertRawSetResult "skewed xor overlapping" xorOverlappingSites xorOverlapping++assertRawSetResult :: String -> [Point] -> Mesh -> IO ()+assertRawSetResult label expectedSites result = do+  case validateTriangulation result of+    [] -> pure ()+    violations -> fail (label <> " raw result is invalid: " <> show violations)+  reference <- meshOf (label <> " fresh rebuild") (scramble 0xD1FFEA expectedSites)+  assertMeshEquivalent (label <> " agrees canonically with a fresh rebuild") reference result++testDifferenceLaws :: IO ()+testDifferenceLaws = do+  values <- setLawOperands+  identity <- requireRight "difference identity" (unions [])+  traverse_+    ( \(name, mesh) -> do+        assertSetEquation+          ("difference cancellation at " <> name)+          (difference mesh mesh)+          (Right identity)+        assertSetEquation+          ("difference right identity at " <> name)+          (difference mesh identity)+          (canonicalize mesh)+    )+    values+  traverse_+    ( \((leftName, left), (rightName, right)) -> do+        let label = "difference partition at " <> leftName <> " / " <> rightName+            commonAndRemainder = do+              common <- intersection left right+              remainder <- difference left right+              union common remainder+            remainderMeetRight = difference left right >>= (`intersection` right)+        assertSetEquation label commonAndRemainder (canonicalize left)+        assertSetEquation (label <> " disjointness") remainderMeetRight (Right identity)+    )+    (pairs values)++testSymmetricDifferenceLaws :: IO ()+testSymmetricDifferenceLaws = do+  values <- setLawOperands+  identity <- requireRight "symmetric-difference identity" (unions [])+  traverse_+    ( \(name, mesh) -> do+        assertSetEquation+          ("symmetric-difference cancellation at " <> name)+          (symmetricDifference mesh mesh)+          (Right identity)+        assertSetEquation+          ("symmetric-difference identity at " <> name)+          (symmetricDifference mesh identity)+          (canonicalize mesh)+    )+    values+  traverse_+    ( \((leftName, left), (rightName, right)) -> do+        let label = "symmetric difference at " <> leftName <> " / " <> rightName+            decomposed = do+              leftOnly <- difference left right+              rightOnly <- difference right left+              union leftOnly rightOnly+        assertSetEquation+          (label <> " commutativity")+          (symmetricDifference left right)+          (symmetricDifference right left)+        assertSetEquation+          (label <> " decomposition")+          (symmetricDifference left right)+          decomposed+    )+    (pairs values)+  traverse_+    ( \((aName, a), (bName, b), (cName, c)) ->+        assertSetEquation+          ("symmetric-difference associativity at " <> aName <> " / " <> bName <> " / " <> cName)+          (symmetricDifference a b >>= (`symmetricDifference` c))+          (symmetricDifference b c >>= symmetricDifference a)+    )+    (triples values)++testLatticeLaws :: IO ()+testLatticeLaws = do+  values <- setLawOperands+  traverse_+    ( \((leftName, left), (rightName, right)) -> do+        let label = "absorption at " <> leftName <> " / " <> rightName+        assertSetEquation+          (label <> " meet-over-join")+          (union left right >>= intersection left)+          (canonicalize left)+        assertSetEquation+          (label <> " join-over-meet")+          (intersection left right >>= union left)+          (canonicalize left)+    )+    (pairs values)+  traverse_+    ( \((aName, a), (bName, b), (cName, c)) -> do+        let label = "distributivity at " <> aName <> " / " <> bName <> " / " <> cName+            meetOverJoin = union b c >>= intersection a+            joinedMeets = do+              left <- intersection a b+              right <- intersection a c+              union left right+            joinOverMeet = intersection b c >>= union a+            metJoins = do+              left <- union a b+              right <- union a c+              intersection left right+        assertSetEquation (label <> " meet-over-join") meetOverJoin joinedMeets+        assertSetEquation (label <> " join-over-meet") joinOverMeet metJoins+    )+    (triples values)++testSetOperationsPublishCanonical :: IO ()+testSetOperationsPublishCanonical = do+  values <- setLawOperands+  traverse_+    ( \((leftName, left), (rightName, right)) -> do+        let label = "canonical set publication at " <> leftName <> " / " <> rightName+        case siteRelation left right of+          DisjointSites -> assertCanonicalFixedPoint (label <> " intersection") (intersection left right)+          PartialOverlap _ -> assertCanonicalFixedPoint (label <> " intersection") (intersection left right)+          EqualSites -> pure ()+          LeftProperSubset -> pure ()+          RightProperSubset -> pure ()+        when (numVertices left > 0 && numVertices right > 0) $ do+          assertCanonicalFixedPoint (label <> " difference") (difference left right)+          assertCanonicalFixedPoint (label <> " symmetric difference") (symmetricDifference left right)+    )+    (pairs values)++-- | Payloads descend with their coordinates. Intersection combines only the+-- common sections, difference preserves the left section, and symmetric+-- difference preserves whichever unique section survives. The independently+-- built expected meshes ensure this is not a restatement of the implementation.+testAnnotationPreservation :: IO ()+testAnnotationPreservation = do+  let shared = randomSites 0xA6607A7E 12+      leftOnly = randomSites 0x1EF7 8+      rightOnly = randomSites 0xA1167 10+      leftPoints = leftOnly <> shared+      rightPoints = shared <> rightOnly+  left <- pointMeshOf "annotation-left" leftPoints+  rightPointsMesh <- pointMeshOf "annotation-right" rightPoints+  sharedReference <- canonicalPointMesh "annotation-shared" shared+  leftOnlyReference <- canonicalPointMesh "annotation-left-only" leftOnly+  exclusiveReference <- canonicalPointMesh "annotation-exclusive" (leftOnly <> rightOnly)+  let right = mapVertices rightAnnotation rightPointsMesh+      expectedCombined = mapVertices (\point -> (point, rightAnnotation point)) sharedReference+      taggedLeft = mapVertices (\point -> ExclusiveAnnotation point LeftOperand) left+      taggedRight = mapVertices (\point -> ExclusiveAnnotation point RightOperand) rightPointsMesh+      taggedExclusive =+        mapVertices+          (\point -> ExclusiveAnnotation point (if point `elem` leftOnly then LeftOperand else RightOperand))+          exclusiveReference+  unless (siteRelation left right == PartialOverlap (length shared)) $+    fail "siteRelation changed when the vertex annotation type changed"+  combined <- requireRight "annotation intersectionWith" (intersectionWith (,) left right)+  restricted <- requireRight "annotation restriction" (intersectionWith const left right)+  removed <- requireRight "annotation difference" (difference left right)+  exclusive <- requireRight "annotation symmetric difference" (symmetricDifference taggedLeft taggedRight)+  assertAnnotatedMesh "intersectionWith combines left then right" expectedCombined combined+  assertAnnotatedMesh "intersectionWith const restricts the left section" sharedReference restricted+  assertAnnotatedMesh "difference preserves left annotations" leftOnlyReference removed+  assertAnnotatedMesh "symmetric difference preserves the annotation of each exclusive owner" taggedExclusive exclusive++data ExclusiveOperand+  = LeftOperand+  | RightOperand+  deriving stock (Eq)++data ExclusiveAnnotation = ExclusiveAnnotation !(Point) !ExclusiveOperand+  deriving stock (Eq)++rightAnnotation :: Point -> (Double, Double)+rightAnnotation (Point x y) = (x + y, x - y)++canonicalPointMesh :: String -> [Point] -> IO (DelaunayTriangulation (Point))+canonicalPointMesh label points =+  pointMeshOf label points+    >>= requireRight ("canonicalize " <> label) . canonicalize++assertAnnotatedMesh :: Eq mesh => String -> mesh -> mesh -> IO ()+assertAnnotatedMesh label expected actual =+  unless (expected == actual) (fail (label <> ": structural values differ"))++assertSetEquation+  :: String+  -> Either BuildError Mesh+  -> Either BuildError Mesh+  -> IO ()+assertSetEquation label leftExpression rightExpression = do+  left <- requireRight (label <> " left") leftExpression+  right <- requireRight (label <> " right") rightExpression+  leftCanonical <- requireRight (label <> " canonical left") (canonicalize left)+  rightCanonical <- requireRight (label <> " canonical right") (canonicalize right)+  assertMesh label leftCanonical rightCanonical++assertCanonicalFixedPoint :: String -> Either BuildError Mesh -> IO ()+assertCanonicalFixedPoint label expression = do+  result <- requireRight label expression+  fixedPoint <- requireRight (label <> " fixed point") (canonicalize result)+  assertMesh label result fixedPoint++-- | Six representatives retain empty, degenerate, nested, partially+-- overlapping and equal-support/different-publication cases without turning+-- every ternary law into the full nine-cubed join corpus already exercised+-- above.+setLawOperands :: IO [(String, Mesh)]+setLawOperands =+  filter+    (\(name, _) -> name `elem` ["void", "single", "lattice-lower", "lattice-upper", "scattered", "scattered-scrambled"])+    <$> operands++-- ── construction ─────────────────────────────────────────────────────────────++-- | Deal the sites round-robin into @count@ shards, so every shard spans the+-- whole extent and the joins are genuinely overlapping rather than separable.+shardMeshes :: Int -> [Point] -> IO [Mesh]+shardMeshes count sites =+  traverse+    (\shard -> meshOf ("shard " <> show shard) [site | (index, site) <- indexed, index `mod` count == shard])+    [0 .. count - 1]+ where+  indexed = zip [0 :: Int ..] sites++-- | Combine by repeatedly joining a pseudo-randomly chosen adjacent pair, so+-- that successive seeds give genuinely different bracketings.+bracketRandomly :: Word64 -> [Mesh] -> Either BuildError Mesh+bracketRandomly _ [] = unions []+bracketRandomly _ [single] = Right single+bracketRandomly seed values =+  let !stepped = advance seed+      !cut = fromIntegral (stepped `mod` fromIntegral (length values - 1))+   in joinAdjacent cut values >>= bracketRandomly stepped++-- | Replace the pair at @index@ with its join, leaving everything else alone.+joinAdjacent :: Int -> [Mesh] -> Either BuildError [Mesh]+joinAdjacent index (left : right : rest)+  | index <= 0 = (: rest) <$> union left right+  | otherwise = (left :) <$> joinAdjacent (index - 1) (right : rest)+joinAdjacent _ rest = Right rest++-- | A site is a coordinate carrying a tag. The join acts on tags alone: two+-- annotations only ever meet at a shared coordinate, where the positions+-- already agree, so geometry is never authored by the payload.+data Site = Site !(Point) !Int+  deriving stock (Eq, Show)++instance HasPosition Site where+  position (Site point _) = point++instance JoinSemilattice Site where+  joinAnnotations (Site point left) (Site _ right) = Site point (max left right)++type AnnotatedMesh = Triangulation 'Unconstrained Site () () ()++annotatedMesh :: String -> [Site] -> IO AnnotatedMesh+annotatedMesh label sites =+  buildTriangulation <$> requireRight label (delaunay unitElementDefaults (V.fromList sites))++-- Keyed on the coordinate plane rather than on the payload's own point,+-- because geometry is authoritative and a payload that disagreed with it must+-- not be able to hide behind itself.+tagsOf :: AnnotatedMesh -> Map.Map (Double, Double) Int+tagsOf mesh =+  Map.fromList+    [ ((x, y), tag)+    | vertex <- vertices mesh+    , let Point x y = vertexPoint mesh vertex+    , let Site _ tag = vertexData mesh vertex+    ]++-- The whole law in one equation: the union's annotation at every site is the+-- join of whatever the operands carried there.+assertGluing :: String -> [Site] -> [Site] -> IO ()+assertGluing label leftSites rightSites = do+  left <- annotatedMesh (label <> " left") leftSites+  right <- annotatedMesh (label <> " right") rightSites+  glued <- requireRight (label <> " union") (union left right)+  assertEqualTags+    (label <> ": union glues shared annotations by join")+    (Map.unionWith max (tagsOf left) (tagsOf right))+    (tagsOf glued)++assertEqualTags :: String -> Map.Map (Double, Double) Int -> Map.Map (Double, Double) Int -> IO ()+assertEqualTags label expected actual =+  unless (expected == actual) $+    fail (label <> ": expected " <> show (Map.toList expected) <> ", got " <> show (Map.toList actual))++-- The plan is chosen by size: a small addition is inserted into the larger+-- operand, and only comparably sized operands are rebuilt canonically. Both+-- paths glue, and only running both shows it.+testJoinGluesAnnotations :: IO ()+testJoinGluesAnnotations = do+  assertGluing+    "insertion plan"+    [Site (Point 0 0) 1, Site (Point 6 0) 1, Site (Point 0 6) 1, Site (Point 2 1) 7]+    [Site (Point 0 0) 5, Site (Point 6 0) 2, Site (Point 0 6) 3, Site (Point 4 3) 9]+  assertGluing "rebuild plan" (grid 0 1) (grid 6 2)+ where+  -- Two hundred-odd sites overlapping in half, so neither operand is small+  -- enough to be inserted into the other and the canonical rebuild is taken.+  grid offset tag =+    [ Site (Point (fromIntegral column) (fromIntegral row)) (tag * (column + row))+    | column <- [offset .. offset + 11 :: Int]+    , row <- [0 .. 9 :: Int]+    ]
+ test/algebra/Moonlight/Triangulation/ExactClipRetentionSpec.hs view
@@ -0,0 +1,536 @@+-- | Independent endpoint-reconstruction oracle for the retained-line clipper.+--+-- The oracle is deliberately test-only. Production has one clipping authority:+-- 'exactClipRetainedPolygon'.+module Moonlight.Triangulation.ExactClipRetentionSpec (tests) where++import Control.Monad (foldM, unless)+import Data.Foldable (traverse_)+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (maybeToList)+import Moonlight.Triangulation.Exact+  ( ExactAffineLine+  , ExactClipDisposition (..)+  , ExactClipReceipt (..)+  , ExactClosedHalfPlane+  , ExactHalfPlaneError (..)+  , ExactIntersectionError+  , ExactPoint+  , ExactRetainedPolygon+  , SegmentRelation (..)+  , classifyExactPoint+  , exactAffineLine+  , exactAffineLineCoefficients+  , exactAffineLineIntersection+  , exactClipRetainedPolygon+  , exactClosedHalfPlane+  , exactClosedHalfPlaneFromDirectedEdge+  , exactClosedHalfPlaneLine+  , exactOrient2d+  , exactPoint+  , exactPointCoordinates+  , exactRetainedPolygon+  , exactRetainedPolygonPoints+  )+import Moonlight.Triangulation.Internal.BoundaryCycle+  ( cyclePairsNonEmpty+  , cyclicTriples+  )+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactRational+  , exactRational+  , exactRationalBitWidth+  , exactRationalDenominatorBitWidth+  )+import Support (assertEqual, integerPoint, requireRight)++tests :: IO ()+tests = do+  testAffineIntersectionCrossProducts+  testSelfIntersectingAllLeftCycleRefused+  testRetainedClosingLineSurvivesSecondClip+  testAngularHalfPlanePermutation+  testClosedDimensionalDispositions+  initialPolygon <-+    requireRight+      "retained-line fixture polygon"+      ( exactRetainedPolygon+          ( integerPoint (-1000) (-1000)+              :| [ integerPoint 1000 (-1000)+                 , integerPoint 1000 1000+                 , integerPoint (-1000) 1000+                 ]+          )+      )+  halfPlanes <- traverse fixtureHalfPlane fixtureCoefficients+  (retainedDisposition, retainedReceipt) <-+    requireRight+      "retained-line fixture clipping"+      (exactClipRetainedPolygon initialPolygon halfPlanes)+  retainedPoints <-+    case retainedDisposition of+      ExactClipFullDimensional polygon -> pure (exactRetainedPolygonPoints polygon)+      other -> fail ("retained-line fixture lost full dimension: " <> show other)+  (endpointPoints, endpointReceipt) <-+    requireRight+      "endpoint-reconstruction oracle"+      (endpointClipSequence (exactRetainedPolygonPoints initialPolygon) halfPlanes)++  assertExactPointSet "final exact polygon" retainedPoints endpointPoints+  assertEqual+    "final reduced denominator width is representation invariant"+    (exactClipFinalDenominatorBits retainedReceipt)+    (endpointFinalDenominatorBits endpointReceipt)+  assertEqual "measured retained coefficient width" 21 (exactClipMaximumAffineCoefficientBits retainedReceipt)+  assertEqual "measured endpoint coefficient width" 32 (endpointPeakAffineCoefficientBits endpointReceipt)+  unless+    ( endpointPeakAffineCoefficientBits endpointReceipt+        > exactClipMaximumAffineCoefficientBits retainedReceipt+    )+    ( fail+        "endpoint reconstruction did not exhibit strictly larger affine coefficients"+    )++  -- Equality is checked at every local section, not merely after global gluing.+  -- This is the reason no honest coordinate-width counterexample can exist.+  traverse_+    (assertPrefixAgreement initialPolygon)+    (List.inits halfPlanes)+  putStrLn "exact retained-line clipping: ok (source coefficients 21 bits; endpoint oracle 32 bits)"++testAffineIntersectionCrossProducts :: IO ()+testAffineIntersectionCrossProducts = do+  oneHalf <- rationalCoefficient 1 2+  oneThird <- rationalCoefficient 1 3+  twoFifths <- rationalCoefficient 2 5+  negativeOneSeventh <- rationalCoefficient (-1) 7+  negativeOne <- rationalCoefficient (-1) 1+  oneEleventh <- rationalCoefficient 1 11+  firstLine <-+    requireRight+      "first rational intersection line"+      (exactAffineLine oneHalf oneThird negativeOne)+  secondLine <-+    requireRight+      "second rational intersection line"+      (exactAffineLine twoFifths negativeOneSeventh oneEleventh)+  intersection <-+    requireRight+      "homogeneous integer affine intersection"+      (exactAffineLineIntersection firstLine secondLine)+  expectedX <- requireRight "expected rational x" (exactRational 260 473)+  expectedY <- requireRight "expected rational y" (exactRational 1029 473)+  assertEqual+    "homogeneous integer intersection agrees with rational Cramer's rule"+    (exactPoint expectedX expectedY)+    intersection+  assertEqual+    "intersection remains on the first source line"+    EQ+    (classifyExactPoint (exactClosedHalfPlane firstLine) intersection)+  assertEqual+    "intersection remains on the second source line"+    EQ+    (classifyExactPoint (exactClosedHalfPlane secondLine) intersection)+ where+  rationalCoefficient :: Integer -> Integer -> IO ExactRational+  rationalCoefficient numerator denominator =+    requireRight+      "rational intersection coefficient"+      (exactRational numerator denominator)++testAngularHalfPlanePermutation :: IO ()+testAngularHalfPlanePermutation = do+  square <- retainedSquare+  halfPlanes <-+    traverse+      fixtureHalfPlane+      [ (1, 0, -2)+      , (2, 0, -4)+      , (-1, 0, 8)+      , (0, 1, -1)+      , (0, -1, 9)+      ]+  (expected, expectedReceipt) <-+    requireRight+      "angular half-plane canonical result"+      (exactClipRetainedPolygon square halfPlanes)+  case expected of+    ExactClipFullDimensional polygon ->+      assertExactPointSet+        "parallel descent retains the strongest boundaries"+        ( integerPoint 2 1+            :| [integerPoint 8 1, integerPoint 8 9, integerPoint 2 9]+        )+        (exactRetainedPolygonPoints polygon)+    other -> fail ("expected a full-dimensional canonical section, got " <> show other)+  traverse_+    (\permutation -> do+       (actual, receipt) <-+         requireRight+           "permuted angular half-plane intersection"+           (exactClipRetainedPolygon square permutation)+       assertEqual "angular half-plane permutation" expected actual+       assertEqual+         "submitted half-plane count"+         (length halfPlanes)+         (exactClipSubmittedHalfPlanes receipt))+    (List.permutations halfPlanes)+  unless (exactClipBoundaryCompatibilityChecks expectedReceipt > 0) $+    fail "angular descent reported no boundary compatibility work"++testClosedDimensionalDispositions :: IO ()+testClosedDimensionalDispositions = do+  square <- retainedSquare+  xAtOne <- traverse fixtureHalfPlane [(1, 0, -1), (-1, 0, 1)]+  (segmentDisposition, _) <-+    requireRight+      "closed segment half-plane intersection"+      (exactClipRetainedPolygon square xAtOne)+  case segmentDisposition of+    ExactClipLowerDimensional points ->+      assertEqual+        "opposing closed half-planes retain their shared segment"+        (List.sort [integerPoint 1 0, integerPoint 1 10])+        (List.sort (NonEmpty.toList points))+    other -> fail ("expected a closed segment, got " <> show other)++  yAtThree <- traverse fixtureHalfPlane [(0, 1, -3), (0, -1, 3)]+  (pointDisposition, _) <-+    requireRight+      "closed point half-plane intersection"+      (exactClipRetainedPolygon square (xAtOne <> yAtThree))+  case pointDisposition of+    ExactClipLowerDimensional points ->+      assertEqual+        "two zero-width closed sections retain their shared point"+        [integerPoint 1 3]+        (List.sort (NonEmpty.toList points))+    other -> fail ("expected a closed point, got " <> show other)++  incompatible <- traverse fixtureHalfPlane [(1, 0, -6), (-1, 0, 5)]+  (emptyDisposition, _) <-+    requireRight+      "incompatible closed half-plane intersection"+      (exactClipRetainedPolygon square incompatible)+  assertEqual "separated opposing boundaries are empty" ExactClipEmpty emptyDisposition++retainedSquare :: IO ExactRetainedPolygon+retainedSquare =+  requireRight+    "retained square"+    ( exactRetainedPolygon+        ( integerPoint 0 0+            :| [integerPoint 10 0, integerPoint 10 10, integerPoint 0 10]+        )+    )++testSelfIntersectingAllLeftCycleRefused :: IO ()+testSelfIntersectingAllLeftCycleRefused = do+  let points =+        integerPoint 0 0+          :| [ integerPoint 5 3+             , integerPoint (-1) 3+             , integerPoint 4 0+             , integerPoint 2 5+             ]+      turns =+        fmap+          (\(previous, current, next) -> exactOrient2d previous current next)+          (cyclicTriples (NonEmpty.toList points))+  assertEqual "self-intersection fixture has only local left turns" (replicate 5 GT) turns+  case exactRetainedPolygon points of+    Left (ExactRetainedPolygonSelfRelation 0 2 SegmentsProperlyCross) -> pure ()+    other ->+      fail+        ( "self-intersecting all-left retained polygon: expected edge 0/2 crossing, got "+            <> show other+        )++-- The first clip emits its first point twice. The closing occurrence carries+-- the source line of the retained bottom edge; preserving the opening record+-- instead corrupts that edge into the square's stale right boundary and makes+-- the second clip spuriously report parallel lines.+testRetainedClosingLineSurvivesSecondClip :: IO ()+testRetainedClosingLineSurvivesSecondClip = do+  square <-+    requireRight+      "retained square"+      ( exactRetainedPolygon+          ( integerPoint 0 0+              :| [ integerPoint 10 0+                 , integerPoint 10 10+                 , integerPoint 0 10+                 ]+          )+      )+  diagonalLine <- requireRight "diagonal clipping line" (exactAffineLine (-1) (-1) 10)+  verticalLine <- requireRight "vertical clipping line" (exactAffineLine (-1) 0 5)+  let diagonalHalfPlane = exactClosedHalfPlane diagonalLine+      verticalHalfPlane = exactClosedHalfPlane verticalLine+      retainedHalfPlanes = diagonalHalfPlane :| [verticalHalfPlane]+  (diagonalDisposition, _) <-+    requireRight+      "retained square diagonal clip"+      (exactClipRetainedPolygon square [diagonalHalfPlane])+  diagonalPolygon <-+    requireFullDimensionalClip+      "retained square diagonal clip"+      diagonalDisposition+  assertExactPointSet+    "first clip retains the expected triangle"+    (integerPoint 0 0 :| [integerPoint 10 0, integerPoint 0 10])+    (exactRetainedPolygonPoints diagonalPolygon)+  (sequentialDisposition, _) <-+    requireRight+      "second clip over the retained first result"+      (exactClipRetainedPolygon diagonalPolygon [verticalHalfPlane])+  sequentialPolygon <-+    requireFullDimensionalClip+      "second clip over the retained first result"+      sequentialDisposition+  (combinedDisposition, combinedReceipt) <-+    requireRight+      "combined retained two-clip descent"+      (exactClipRetainedPolygon square (NonEmpty.toList retainedHalfPlanes))+  combinedPolygon <-+    requireFullDimensionalClip+      "combined retained two-clip descent"+      combinedDisposition+  let expectedFinalPoints =+        integerPoint 0 0+          :| [integerPoint 5 0, integerPoint 5 5, integerPoint 0 10]+  assertExactPointSet+    "second clip intersects the retained bottom and diagonal source lines"+    expectedFinalPoints+    (exactRetainedPolygonPoints sequentialPolygon)+  assertEqual+    "sequential and combined clipping preserve the same retained polygon"+    sequentialPolygon+    combinedPolygon+  assertEqual+    "combined clipping records both submitted half-planes"+    2+    (exactClipSubmittedHalfPlanes combinedReceipt)+  assertRetainedVerticesInside+    retainedHalfPlanes+    (exactRetainedPolygonPoints combinedPolygon)++requireFullDimensionalClip+  :: String+  -> ExactClipDisposition+  -> IO ExactRetainedPolygon+requireFullDimensionalClip _ (ExactClipFullDimensional polygon) = pure polygon+requireFullDimensionalClip label disposition =+  fail (label <> ": expected a full-dimensional polygon, got " <> show disposition)++assertExactPointSet+  :: String+  -> NonEmpty ExactPoint+  -> NonEmpty ExactPoint+  -> IO ()+assertExactPointSet label expected actual =+  assertEqual+    label+    (List.sort (NonEmpty.toList expected))+    (List.sort (NonEmpty.toList actual))++assertRetainedVerticesInside+  :: NonEmpty ExactClosedHalfPlane+  -> NonEmpty ExactPoint+  -> IO ()+assertRetainedVerticesInside halfPlanes points =+  traverse_+    (\halfPlane ->+       traverse_+         (\point ->+            unless (classifyExactPoint halfPlane point /= LT) $+              fail ("retained vertex violates clipping half-plane: " <> show point))+         points)+    halfPlanes++data EndpointOracleError+  = EndpointOracleHalfPlane !ExactHalfPlaneError+  | EndpointOracleIntersection !ExactIntersectionError+  | EndpointOracleLostFullDimension ![ExactPoint]+  deriving stock (Eq, Show)++data EndpointOracleReceipt = EndpointOracleReceipt+  { endpointPeakAffineCoefficientBits :: !Int+  , endpointPeakCoordinateBits :: !Int+  , endpointFinalDenominatorBits :: !Int+  }+  deriving stock (Eq, Show)++data EndpointEdgeClip = EndpointEdgeClip+  { endpointEdgePoints :: ![ExactPoint]+  , endpointEdgeReconstructedCoefficientBits :: !(Maybe Int)+  }+  deriving stock (Eq, Show)++endpointClipSequence+  :: NonEmpty ExactPoint+  -> [ExactClosedHalfPlane]+  -> Either EndpointOracleError (NonEmpty ExactPoint, EndpointOracleReceipt)+endpointClipSequence initialPoints halfPlanes = do+  let initialReceipt =+        EndpointOracleReceipt+          { endpointPeakAffineCoefficientBits = 0+          , endpointPeakCoordinateBits = pointCycleBitWidth initialPoints+          , endpointFinalDenominatorBits = pointCycleDenominatorBitWidth initialPoints+          }+  (finalPoints, accumulatedReceipt) <-+    foldM endpointClipStep (initialPoints, initialReceipt) halfPlanes+  pure+    ( finalPoints+    , accumulatedReceipt+        { endpointFinalDenominatorBits =+            pointCycleDenominatorBitWidth finalPoints+        }+    )++endpointClipStep+  :: (NonEmpty ExactPoint, EndpointOracleReceipt)+  -> ExactClosedHalfPlane+  -> Either EndpointOracleError (NonEmpty ExactPoint, EndpointOracleReceipt)+endpointClipStep (points, receipt) halfPlane = do+  clippedEdges <-+    traverse (clipEndpointEdge halfPlane) (cyclePairsNonEmpty points)+  let clippedPoints = concatMap endpointEdgePoints clippedEdges+      stepCoefficientBits =+        maximumOrZero+          ( foldMap+              (maybeToList . endpointEdgeReconstructedCoefficientBits)+              clippedEdges+          )+  nextPoints <-+    maybe+      (Left (EndpointOracleLostFullDimension clippedPoints))+      Right+      (NonEmpty.nonEmpty clippedPoints)+  if NonEmpty.length nextPoints < 3+    then Left (EndpointOracleLostFullDimension clippedPoints)+    else+      Right+        ( nextPoints+        , receipt+            { endpointPeakAffineCoefficientBits =+                max+                  (endpointPeakAffineCoefficientBits receipt)+                  stepCoefficientBits+            , endpointPeakCoordinateBits =+                max+                  (endpointPeakCoordinateBits receipt)+                  (pointCycleBitWidth nextPoints)+            }+        )++clipEndpointEdge+  :: ExactClosedHalfPlane+  -> (ExactPoint, ExactPoint)+  -> Either EndpointOracleError EndpointEdgeClip+clipEndpointEdge halfPlane (from, to) =+  let fromInside = classifyExactPoint halfPlane from /= LT+      toInside = classifyExactPoint halfPlane to /= LT+      crossing = do+        reconstructedBoundary <-+          either+            (Left . EndpointOracleHalfPlane)+            (Right . exactClosedHalfPlaneLine)+            (exactClosedHalfPlaneFromDirectedEdge from to)+        point <-+          either+            (Left . EndpointOracleIntersection)+            Right+            ( exactAffineLineIntersection+                reconstructedBoundary+                (exactClosedHalfPlaneLine halfPlane)+            )+        pure (point, affineLineBitWidth reconstructedBoundary)+   in case (fromInside, toInside) of+    (True, True) -> Right (EndpointEdgeClip [to] Nothing)+    (True, False) ->+      (\(point, coefficientBits) ->+         EndpointEdgeClip [point] (Just coefficientBits))+        <$> crossing+    (False, True) ->+      (\(point, coefficientBits) ->+         EndpointEdgeClip [point, to] (Just coefficientBits))+        <$> crossing+    (False, False) -> Right (EndpointEdgeClip [] Nothing)++assertPrefixAgreement+  :: ExactRetainedPolygon+  -> [ExactClosedHalfPlane]+  -> IO ()+assertPrefixAgreement initialPolygon prefix = do+  (retainedDisposition, retainedReceipt) <-+    requireRight+      "retained-line prefix"+      (exactClipRetainedPolygon initialPolygon prefix)+  retainedPoints <-+    case retainedDisposition of+      ExactClipFullDimensional polygon -> pure (exactRetainedPolygonPoints polygon)+      other -> fail ("retained-line prefix lost full dimension: " <> show other)+  (endpointPoints, endpointReceipt) <-+    requireRight+      "endpoint prefix"+      (endpointClipSequence (exactRetainedPolygonPoints initialPolygon) prefix)+  assertExactPointSet "prefix exact polygon" retainedPoints endpointPoints+  assertEqual+    "prefix denominator width"+    (exactClipFinalDenominatorBits retainedReceipt)+    (endpointFinalDenominatorBits endpointReceipt)++fixtureHalfPlane+  :: (Integer, Integer, Integer)+  -> IO ExactClosedHalfPlane+fixtureHalfPlane (coefficientX, coefficientY, constant) =+  exactClosedHalfPlane+    <$> requireRight+      "fixture affine half-plane"+      ( exactAffineLine+          (fromInteger coefficientX)+          (fromInteger coefficientY)+          (fromInteger constant)+      )++fixtureCoefficients :: [(Integer, Integer, Integer)]+fixtureCoefficients =+  [ (1, 2, 1300)+  , (-3, 5, 1700)+  , (-7, -2, 1900)+  , (4, -9, 2200)+  , (11, 3, 1800)+  , (-5, 13, 2100)+  , (-17, -4, 2300)+  , (6, -19, 2400)+  , (23, 7, 2500)+  , (-8, 29, 2600)+  ]++affineLineBitWidth :: ExactAffineLine -> Int+affineLineBitWidth line =+  let (coefficientX, coefficientY, constant) = exactAffineLineCoefficients line+   in maximumOrZero (fmap exactRationalBitWidth [coefficientX, coefficientY, constant])++pointCycleBitWidth :: NonEmpty ExactPoint -> Int+pointCycleBitWidth =+  maximumOrZero+    . concatMap+      (\point ->+         let (x, y) = exactPointCoordinates point+          in fmap exactRationalBitWidth [x, y])++pointCycleDenominatorBitWidth :: NonEmpty ExactPoint -> Int+pointCycleDenominatorBitWidth =+  maximumOrZero+    . concatMap+      (\point ->+         let (x, y) = exactPointCoordinates point+          in fmap exactRationalDenominatorBitWidth [x, y])++maximumOrZero :: Foldable collection => collection Int -> Int+maximumOrZero = List.foldl' max 0
+ test/algebra/Moonlight/Triangulation/LayerOperationsSpec.hs view
@@ -0,0 +1,275 @@+-- | Exact affine-envelope and compositional layer laws through the public+-- facade. Every comparison is against an independently composed public view.+module Moonlight.Triangulation.LayerOperationsSpec (tests) where++import Control.Monad (unless)+import Data.Foldable (traverse_)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import Moonlight.Triangulation+  ( AffineForm (..)+  , CoverGap+  , ExactPoint+  , ExactRational+  , LayerCoverageError (..)+  , PlanarLayer+  , PlanarRegion+  , PolygonComponent+  , RegionPublicationError (RegionUnboundedSelection)+  , UpperEnvelopeError (UpperEnvelopeEmptyForms)+  , coverGapRegion+  , exactAreaValue+  , exactLoop+  , exactLoopPoints+  , exactPoint+  , exactPointCoordinates+  , layerCovers+  , overlayAll+  , overlayConfusion+  , overlayLayers+  , overlayMass+  , overlaySelectedRegion+  , planarLayer+  , planarLayerLabelAt+  , planarLayerRegions+  , planarRegion+  , planarRegionComponents+  , polygonComponent+  , polygonHoleLoops+  , polygonOuterLoop+  , regionValuations+  , upperEnvelope+  , valuationArea+  )+import Moonlight.Triangulation.AlgebraFixtures+  ( insideLayer+  , rectangleComponent+  , rectangleRegion+  )+import Support (assertEqual, integerPoint, requireRight)++tests :: IO ()+tests = do+  testConvexUpperEnvelope+  testNonconvexAndHoledUpperEnvelope+  testEmptyUpperEnvelope+  testLayerCoverage+  testNaryOverlayLabels+  testOverlayMassAndConfusion+  putStrLn "layer operations: ok"++testConvexUpperEnvelope :: IO ()+testConvexUpperEnvelope = do+  window <- rectangleComponent 0 0 10 10+  let forms =+        Map.fromList+          [ (0 :: Int, AffineForm 0 (-1) 0)+          , (1, AffineForm 0 (-1) 0)+          , (2, AffineForm (-10) 1 0)+          , (3, AffineForm (-11) 1 0)+          ]+  layer <- requireRight "convex exact upper envelope" (upperEnvelope window forms)+  reordered <-+    requireRight+      "upper envelope is independent of map construction order"+      (upperEnvelope window (Map.fromList (reverse (Map.toList forms))))+  assertEqual "upper envelope map-order invariance" layer reordered+  assertEqual "identical and dominated forms own no cell" [Just 0, Just 2] (Map.keys (planarLayerRegions layer))+  assertEnvelopeDominance forms layer+  assertEqual "left affine winner" (Just 0) (planarLayerLabelAt layer (exactPoint 2 5))+  assertEqual "right affine winner" (Just 2) (planarLayerLabelAt layer (exactPoint 8 5))+  assertEqual "outside finite window" Nothing (planarLayerLabelAt layer (exactPoint (-1) 5))+  requireCoverage "upper envelope covers its convex window" layer window++testNonconvexAndHoledUpperEnvelope :: IO ()+testNonconvexAndHoledUpperEnvelope = do+  nonconvex <- lShapedComponent+  holed <- holedComponent+  let constantForm = Map.singleton (7 :: Int) (AffineForm 1 0 0)+  assertEnvelopeEqualsWindow "nonconvex envelope restriction" nonconvex constantForm+  assertEnvelopeEqualsWindow "holed envelope restriction" holed constantForm++testEmptyUpperEnvelope :: IO ()+testEmptyUpperEnvelope = do+  window <- rectangleComponent 0 0 1 1+  case upperEnvelope window (Map.empty :: Map.Map Int AffineForm) of+    Left UpperEnvelopeEmptyForms -> pure ()+    result -> fail ("empty upper envelope: unexpected result " <> show result)++testLayerCoverage :: IO ()+testLayerCoverage = do+  window <- rectangleComponent 0 0 10 10+  half <- rectangleRegion 0 0 5 10+  incomplete <- insideLayer half+  case layerCovers incomplete window of+    Left (LayerCoverageGap gap) -> assertGapArea 50 gap+    result -> fail ("incomplete layer coverage: unexpected result " <> show result)+  completeRegion <- requireRight "complete coverage region" (planarRegion [window])+  complete <- requireRight "complete coverage layer" (planarLayer False (Map.singleton True completeRegion))+  requireCoverage "complete layer" complete window++testNaryOverlayLabels :: IO ()+testNaryOverlayLabels = do+  vertical <- rectangleRegion 0 0 6 10 >>= insideLayer+  horizontal <- rectangleRegion 0 0 10 6 >>= insideLayer+  central <- rectangleRegion 2 2 8 8 >>= insideLayer+  let sourceLayers = vertical :| [horizontal, central]+  refined <- requireRight "balanced n-ary overlay" (overlayAll sourceLayers)+  assertNaryLabel sourceLayers refined (exactPoint 3 3)+  assertNaryLabel sourceLayers refined (exactPoint 7 3)+  assertNaryLabel sourceLayers refined (exactPoint 9 9)+  assertNaryLabel sourceLayers refined (exactPoint (-1) (-1))+  singleton <- requireRight "singleton n-ary overlay" (overlayAll (vertical :| []))+  assertNaryLabel (vertical :| []) singleton (exactPoint 3 3)++testOverlayMassAndConfusion :: IO ()+testOverlayMassAndConfusion = do+  left <- rectangleRegion 0 0 6 10 >>= insideLayer+  right <- rectangleRegion 4 0 10 10 >>= insideLayer+  result <- requireRight "mass overlay" (overlayLayers left right)+  direct <- requireRight "direct overlap mass" (overlayMass (== (True, True)) result)+  published <-+    requireRight+      "published overlap region"+      (overlaySelectedRegion (== (True, True)) result)+  publishedValues <- requireRight "published overlap valuation" (regionValuations published)+  assertEqual+    "direct mass equals published-region valuation"+    (exactAreaValue (valuationArea publishedValues))+    (exactAreaValue direct)+  assertEqual "overlap mass" 20 (exactAreaValue direct)+  case overlayMass (== (False, False)) result of+    Left RegionUnboundedSelection -> pure ()+    value -> fail ("unbounded overlay mass: unexpected result " <> show value)+  assertEqual+    "one-pass finite confusion masses"+    ( Map.fromList+        [ ((False, True), 40)+        , ((True, False), 40)+        , ((True, True), 20)+        ]+    )+    (fmap exactAreaValue (overlayConfusion result))+  traverse_+    (\(labels, expected) -> do+       measured <- requireRight "direct confusion-cell mass" (overlayMass (== labels) result)+       assertEqual "confusion entry equals direct mass" expected (exactAreaValue measured))+    (Map.toAscList (fmap exactAreaValue (overlayConfusion result)))++assertEnvelopeDominance+  :: Map.Map Int AffineForm+  -> PlanarLayer (Maybe Int)+  -> IO ()+assertEnvelopeDominance forms layer =+  traverse_ checkRegion (Map.toAscList (planarLayerRegions layer))+ where+  checkRegion :: (Maybe Int, PlanarRegion) -> IO ()+  checkRegion (Nothing, _) = fail "bounded upper-envelope region has the outside label"+  checkRegion (Just winner, region) =+    case Map.lookup winner forms of+      Nothing -> fail ("upper-envelope winner is absent from its input map: " <> show winner)+      Just winnerForm ->+        traverse_+          (checkWinnerAtPoint winner winnerForm)+          (concatMap componentBoundaryPoints (planarRegionComponents region))++  checkWinnerAtPoint+    :: Int+    -> AffineForm+    -> ExactPoint+    -> IO ()+  checkWinnerAtPoint winner winnerForm point =+    let winnerValue = affineValue winnerForm point+     in traverse_+          (\(candidate, candidateForm) ->+             unless (winnerValue >= affineValue candidateForm point) $+               fail+                 ( "upper-envelope dominance failed: winner "+                     <> show winner+                     <> ", candidate "+                     <> show candidate+                 ))+          (Map.toAscList forms)++componentBoundaryPoints :: PolygonComponent -> [ExactPoint]+componentBoundaryPoints component =+  NonEmpty.toList (exactLoopPoints (polygonOuterLoop component))+    <> concatMap (NonEmpty.toList . exactLoopPoints) (polygonHoleLoops component)++affineValue+  :: AffineForm+  -> ExactPoint+  -> ExactRational+affineValue form point =+  let (coordinateX, coordinateY) = exactPointCoordinates point+   in affineFormConstant form+        + affineFormXCoefficient form * coordinateX+        + affineFormYCoefficient form * coordinateY++assertEnvelopeEqualsWindow+  :: String+  -> PolygonComponent+  -> Map.Map Int AffineForm+  -> IO ()+assertEnvelopeEqualsWindow label window forms = do+  expected <- requireRight (label <> " expected region") (planarRegion [window])+  layer <- requireRight label (upperEnvelope window forms)+  assertEqual label (Just expected) (Map.lookup (Just 7) (planarLayerRegions layer))+  requireCoverage (label <> " coverage") layer window++assertGapArea :: Integer -> CoverGap -> IO ()+assertGapArea expected gap = do+  values <- requireRight "gap valuation" (regionValuations (coverGapRegion gap))+  assertEqual "coverage obstruction retains exact gap" (fromInteger expected) (exactAreaValue (valuationArea values))++assertNaryLabel+  :: NonEmpty (PlanarLayer Bool)+  -> PlanarLayer (NonEmpty Bool)+  -> ExactPoint+  -> IO ()+assertNaryLabel sourceLayers refined point =+  assertEqual+    "n-ary label tuple follows source order"+    (fmap (`planarLayerLabelAt` point) sourceLayers)+    (planarLayerLabelAt refined point)++requireCoverage+  :: (Ord label, Show label)+  => String+  -> PlanarLayer label+  -> PolygonComponent+  -> IO ()+requireCoverage label layer window =+  case layerCovers layer window of+    Right () -> pure ()+    Left failure -> fail (label <> ": " <> show failure)++lShapedComponent :: IO PolygonComponent+lShapedComponent = do+  outer <-+    requireRight+      "L-shaped outer loop"+      ( exactLoop+          ( integerPoint 0 0+              :| [ integerPoint 4 0+                 , integerPoint 4 1+                 , integerPoint 1 1+                 , integerPoint 1 4+                 , integerPoint 0 4+                 ]+          )+      )+  requireRight "L-shaped component" (polygonComponent outer [])++holedComponent :: IO PolygonComponent+holedComponent = do+  outer <-+    requireRight+      "holed outer loop"+      (exactLoop (integerPoint 0 0 :| [integerPoint 6 0, integerPoint 6 6, integerPoint 0 6]))+  hole <-+    requireRight+      "clockwise hole loop"+      (exactLoop (integerPoint 2 2 :| [integerPoint 2 4, integerPoint 4 4, integerPoint 4 2]))+  requireRight "holed component" (polygonComponent outer [hole])
+ test/algebra/Moonlight/Triangulation/MinkowskiSpec.hs view
@@ -0,0 +1,309 @@+-- | Exact convex convolution and residual-morphology laws.+module Moonlight.Triangulation.MinkowskiSpec (tests) where++import Data.List.NonEmpty (NonEmpty (..))+import Moonlight.Triangulation.AlgebraFixtures+  ( annulusRegion+  , polygonRegion+  , rectangleComponent+  , rectangleRegion+  )+import Moonlight.Triangulation.Exact (ExactPoint, exactPoint)+import Moonlight.Triangulation.Internal.ExactRational+  ( ExactRational+  , exactRational+  )+import Moonlight.Triangulation.Minkowski+  ( MinkowskiOperation (..)+  , closeWith+  , convexMinkowskiSum+  , convexPolygon+  , convexPolygonPoints+  , erodeBy+  , minkowskiGeneratedPieces+  , minkowskiExactCrossings+  , minkowskiOperation+  , minkowskiOverlayPasses+  , minkowskiSum+  , openWith+  , polygonOffset+  , reflectConvexPolygon+  , 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+  testConvexReflection+  testGeneralAddition+  testOffsetClosure+  testConvexMorphology+  testGeneralErosion+  testHoledAndNeckedErosion+  putStrLn "minkowski: ok"++testConvexReflection :: IO ()+testConvexReflection = do+  triangle <-+    requireRight+      "asymmetric convex triangle"+      (convexPolygon (exactPoint 0 0 :| [exactPoint 3 0, exactPoint 1 2]))+  let reflected = reflectConvexPolygon triangle+  readmitted <-+    requireRight+      "reflected convex polygon preserves counter-clockwise orientation"+      (convexPolygon (convexPolygonPoints reflected))+  assertEqual "reflected carrier remains admissible" reflected readmitted+  assertEqual+    "convex reflection is involutive"+    triangle+    (reflectConvexPolygon reflected)++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"++-- Dilation must be closed over its own exact published image. This fixture+-- used to admit the first offset and then refuse the second when rounded+-- resident wedges were mistaken for exact two-cells.+testOffsetClosure :: IO ()+testOffsetClosure = do+  source <-+    polygonRegion+      [ (-9, -1)+      , (-5, -6)+      , (0, -13)+      , (7, -9)+      , (9, 1)+      , (10, 10)+      , (5, 12)+      , (-7, 8)+      ]+  shoulder <-+    requireRight+      "unit octagon shoulder"+      (exactRational 1592262918131443 2251799813685248)+  kernel <-+    requireRight+      "unit octagon kernel"+      (convexPolygon (centeredOctagon 1 shoulder))+  element <- requireRight "unit octagon element" (structuringElement kernel)+  (firstOffset, _) <-+    requireRight "first closure-regression offset" (polygonOffset element source)+  (secondOffset, secondReceipt) <-+    requireRight+      "offset remains closed over its own published image"+      (polygonOffset element firstOffset)+  assertEqual+    "offset-of-offset remains one full-dimensional component"+    1+    (length (planarRegionComponents secondOffset))+  if minkowskiOverlayPasses secondReceipt > 0+    then pure ()+    else fail "offset closure regression did not exercise overlay descent"++centeredOctagon :: ExactRational -> ExactRational -> NonEmpty ExactPoint+centeredOctagon radius shoulder =+  exactPoint radius 0+    :| [ exactPoint shoulder shoulder+       , exactPoint 0 radius+       , exactPoint (-shoulder) shoulder+       , exactPoint (-radius) 0+       , exactPoint (-shoulder) (-shoulder)+       , exactPoint 0 (-radius)+       , exactPoint shoulder (-shoulder)+       ]++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)+  assertEqual+    "convex erosion reports exact HPI line intersections"+    4+    (minkowskiExactCrossings 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/PowerDiagramSpec.hs view
@@ -0,0 +1,1282 @@+-- | Exact bounded power-cell laws through the public owner.+module Moonlight.Triangulation.PowerDiagramSpec (tests) where++import Control.Monad (unless)+import Data.Foldable (traverse_)+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Vector as Vector+import Moonlight.Triangulation+  ( ExactPoint+  , ExactRational+  , ExactVector (..)+  , BoundedPowerDiagram+  , ConvexPolygon+  , Point (..)+  , PowerCellDisposition (..)+  , PowerDualEdge (..)+  , PowerDiagramError (..)+  , PowerSite+  , PowerWeight+  , PowerWeightError (..)+  , powerAlphaBirthExact+  , RegularEditError (..)+  , RegularEditResult (..)+  , RegularSiteDisposition (..)+  , RegularSiteTransition (..)+  , RegularEdge+  , RegularTriangulation+  , boundedPowerDiagram+  , boundedPowerDiagramFromRegular+  , convexPolygon+  , convexPolygonPoints+  , exactPointCoordinates+  , exactPointFromPoint+  , exactRayDirection+  , exactRayOrigin+  , exactSegmentEndpoints+  , planarLayerRegions+  , powerCellDisposition+  , powerCellDispositions+  , powerDiagramActiveBoundaries+  , powerDiagramCoincidentEquivalentCells+  , powerDiagramCoincidentDominatedCells+  , powerDiagramEmptyCells+  , powerDiagramInputSites+  , powerDiagramLowerDimensionalCells+  , powerDiagramPlanarLayer+  , powerDiagramPublishedCells+  , powerDiagramOracleCells+  , powerDiagramMaximumCellConstraints+  , powerDiagramRegularEdges+  , powerDiagramSubmittedSiteConstraints+  , powerSite+  , powerSiteLabel+  , powerSitePosition+  , powerSiteWeight+  , powerWeight+  , powerWeightExact+  , regularAlphaBirths+  , regularAlphaComplex+  , regularAlphaComplexAtBirth+  , regularAlphaFiltration+  , emptyRegularTriangulation+  , insertRegularSite+  , regularEdgeDual+  , regularEdgeLabels+  , regularEdges+  , regularFaceDualPoint+  , regularFaceLabels+  , regularFaces+  , regularNeighbours+  , regularSite+  , regularSiteCount+  , regularSiteDisposition+  , regularSites+  , regularTriangulation+  , regularTriangulationReceipt+  , regularTriangulationEdges+  , regularTriangulationFaces+  , regularTriangulationInputSites+  , regularTriangulationVisibleSites+  , removeRegularSite+  , reweightRegularSites+  , translateExactPoint+  )+import Moonlight.Triangulation.Exact+  ( ExactClipDisposition (..)+  , ExactClosedHalfPlane+  , exactAffineLine+  , exactClipRetainedPolygon+  , exactClosedHalfPlane+  , exactRetainedPolygon+  , exactRetainedPolygonPoints+  )+import Moonlight.Triangulation.Simplex+  ( planarComplexCells+  , planarEdge+  , planarFace+  , planarVertex+  )+import Support (assertEqual, integerPoint, requireRight)++tests :: IO ()+tests = do+  testEqualWeightsAndCommonShift+  testThreeSiteExactPartitionCoverage+  testRegularTriangleDualRays+  testRegularAlphaBirths+  testRegularAlphaCommonShift+  testRegularBoundedDualSegment+  testRegularCoplanarUpperFacet+  testRegularCollinearClassification+  testRegularLowerDimensionalAndHiddenSites+  testRegularSiteOwnership+  testHiddenInsertionAndExposure+  testRegularInsertionAndRemovalTransitions+  testRegularReweightTransitions+  testTopologyPreservingEdits+  testRegularEditDifferentialLaws+  testRegularEditObstructionsAndIdempotence+  testBoundedPowerFromRegular+  testSparsePowerMatchesCompleteOracle+  testEqualCoincidentResolution+  testDominantCoincidentResolution+  testLowerDimensionalCell+  testDistinctEmptyCell+  testDyadicNearParallelBisectors+  testBinary64PrecisionSites+  testDuplicateLabels+  testNonFiniteWeight+  putStrLn "power diagram: ok"++testRegularAlphaBirths :: IO ()+testRegularAlphaBirths = do+  positive <- admittedWeight 3+  singleton <- admittedSite "only" (Point 0 0) positive+  (singleRegular, _) <-+    requireRight "singleton regular topology" (regularTriangulation (singleton :| []))+  singleAlpha <- requireRight "singleton weighted alpha" (regularAlphaFiltration singleRegular)+  assertEqual+    "positive weight gives signed vertex birth"+    (Just (-3))+    (fmap powerAlphaBirthExact (Map.lookup (planarVertex "only") (regularAlphaBirths singleAlpha)))++  zero <- admittedWeight 0+  firstSite <- admittedSite "first" (Point 0 0) zero+  secondSite <- admittedSite "second" (Point 2 0) zero+  thirdSite <- admittedSite "third" (Point 0 2) zero+  dominated <- admittedSite "dominated" (Point 0 0) =<< admittedWeight (-1)+  (regular, _) <-+    requireRight+      "triangle regular topology for weighted alpha"+      (regularTriangulation (firstSite :| [secondSite, thirdSite, dominated]))+  filtration <- requireRight "triangle weighted alpha" (regularAlphaFiltration regular)+  firstSecond <- requireRight "first-second simplex" (planarEdge "first" "second")+  firstThird <- requireRight "first-third simplex" (planarEdge "first" "third")+  secondThird <- requireRight "second-third simplex" (planarEdge "second" "third")+  face <- requireRight "triangle simplex" (planarFace "first" "second" "third")+  let birthAt simplex = fmap powerAlphaBirthExact (Map.lookup simplex (regularAlphaBirths filtration))+  assertEqual "first leg birth" (Just 1) (birthAt firstSecond)+  assertEqual "second leg birth" (Just 1) (birthAt firstThird)+  assertEqual "hypotenuse birth" (Just 2) (birthAt secondThird)+  assertEqual "face birth" (Just 2) (birthAt face)+  assertEqual+    "coincident subordinate has no alpha simplex"+    False+    (Set.member (planarVertex "dominated") (planarComplexCells (regularAlphaComplex filtration)))+  threshold <- requireSome "edge threshold" (Map.lookup firstSecond (regularAlphaBirths filtration))+  _ <- requireRight "weighted alpha sublevel is closed" (regularAlphaComplexAtBirth threshold filtration)+  pure ()++testRegularAlphaCommonShift :: IO ()+testRegularAlphaCommonShift = do+  zero <- admittedWeight 0+  shifted <- admittedWeight 3+  let labelledPoints =+        ("south-west", Point 0 0)+          :| [ ("south-east", Point 4 0)+             , ("north-east", Point 3 3)+             , ("north-west", Point 0 4)+             ]+  baseSites <- traverse (\(label, point) -> admittedSite label point zero) labelledPoints+  shiftedSites <- traverse (\(label, point) -> admittedSite label point shifted) labelledPoints+  (baseRegular, _) <- requireRight "base regular alpha topology" (regularTriangulation baseSites)+  (shiftedRegular, _) <- requireRight "shifted regular alpha topology" (regularTriangulation shiftedSites)+  shiftedEdit <-+    requireRight+      "common regular weight shift"+      ( reweightRegularSites+          (Map.fromList [(label, shifted) | (label, _) <- NonEmpty.toList labelledPoints])+          baseRegular+      )+  assertEqual+    "common shift reuses the regular topology"+    shiftedRegular+    (regularEditTriangulation shiftedEdit)+  assertEqual "common shift changes no disposition" [] (editTransitions shiftedEdit)+  baseAlpha <- requireRight "base regular alpha" (regularAlphaFiltration baseRegular)+  shiftedAlpha <- requireRight "shifted regular alpha" (regularAlphaFiltration shiftedRegular)+  assertEqual+    "common weight shift preserves the complex"+    (regularAlphaComplex baseAlpha)+    (regularAlphaComplex shiftedAlpha)+  assertEqual+    "common weight shift subtracts from every birth"+    (Map.map ((\birth -> birth - 3) . powerAlphaBirthExact) (regularAlphaBirths baseAlpha))+    (Map.map powerAlphaBirthExact (regularAlphaBirths shiftedAlpha))++testRegularTriangleDualRays :: IO ()+testRegularTriangleDualRays = do+  zero <- admittedWeight 0+  firstSite <- admittedSite "first" (Point 0 0) zero+  secondSite <- admittedSite "second" (Point 2 0) zero+  thirdSite <- admittedSite "third" (Point 0 2) zero+  let sites = firstSite :| [secondSite, thirdSite]+  (regular, receipt) <-+    requireRight "three-site regular topology" (regularTriangulation sites)+  assertEqual "three visible regular sites" 3 (regularTriangulationVisibleSites receipt)+  assertEqual "one regular face" 1 (length (regularFaces regular))+  assertEqual "three regular boundary edges" 3 (length (regularEdges regular))+  dualPoint <-+    case regularFaces regular of+      [face] -> pure (regularFaceDualPoint face)+      faces -> fail ("three-site topology expected one face, got " <> show (length faces))+  traverse_ (assertBoundaryDualRay sites dualPoint) (regularEdges regular)+  traverse_+    (\site ->+       let label = powerSiteLabel site+        in do+          assertEqual+            ("visible regular disposition for " <> label)+            (Just RegularSiteVisible)+            (regularSiteDisposition label regular)+          assertEqual+            ("two regular neighbours for " <> label)+            2+            (Set.size (regularNeighbours label regular)))+    sites++testRegularBoundedDualSegment :: IO ()+testRegularBoundedDualSegment = do+  zero <- admittedWeight 0+  sites <-+    traverse+      (\(label, point) -> admittedSite label point zero)+      ( ("south-west", Point 0 0)+          :| [ ("south-east", Point 4 0)+             , ("north-east", Point 3 3)+             , ("north-west", Point 0 4)+             ]+      )+  (regular, receipt) <-+    requireRight "four-site regular topology" (regularTriangulation sites)+  assertEqual+    "regular planar Euler equation"+    1+    ( regularTriangulationVisibleSites receipt+        - regularTriangulationEdges receipt+        + regularTriangulationFaces receipt+    )+  let faceDuals = Set.fromList (fmap regularFaceDualPoint (regularFaces regular))+      bounded =+        [ segment+        | edge <- regularEdges regular+        , BoundedPowerDual segment <- [regularEdgeDual edge]+        ]+  case bounded of+    [segment] ->+      let (firstEndpoint, secondEndpoint) = exactSegmentEndpoints segment+       in unless+            (Set.member firstEndpoint faceDuals && Set.member secondEndpoint faceDuals)+            (fail "bounded regular dual does not join its two incident face duals")+    segments ->+      fail ("four-site topology expected one bounded dual, got " <> show (length segments))++testRegularCoplanarUpperFacet :: IO ()+testRegularCoplanarUpperFacet = do+  sites <-+    traverse+      prepareOracleSite+      ( ("a-bottom", Point 0.25 0.25, -0.875)+          :| [ ("b-south-west", Point 0 0, 0)+             , ("c-south-east", Point 1 0, 1)+             , ("d-center", Point 0.5 0.5, 0.5)+             , ("e-north-east", Point 1 1, 2)+             , ("f-north-west", Point 0 1, 1)+             ]+      )+  (regular, receipt) <-+    requireRight "coplanar upper regular facet" (regularTriangulation sites)+  traverse_+    (\label ->+       assertEqual+         ("upper-facet vertex remains visible: " <> label)+         (Just RegularSiteVisible)+         (regularSiteDisposition label regular))+    ["b-south-west", "c-south-east", "e-north-east", "f-north-west"]+  assertEqual+    "upper-facet interior generator remains lower-dimensional"+    (Just RegularSiteLowerDimensional)+    (regularSiteDisposition "d-center" regular)+  assertEqual+    "strictly lower lifted generator remains hidden"+    (Just RegularSiteHidden)+    (regularSiteDisposition "a-bottom" regular)+  assertEqual "coplanar upper facet has four visible vertices" 4 (regularTriangulationVisibleSites receipt)+  assertEqual "coplanar upper facet receives one deterministic diagonal" 2 (regularTriangulationFaces receipt)++testRegularLowerDimensionalAndHiddenSites :: IO ()+testRegularLowerDimensionalAndHiddenSites = do+  domain <- squareDomain+  zero <- admittedWeight 0+  lowerWeight <- admittedWeight (-1.5)+  hiddenWeight <- admittedWeight (-2)+  firstSite <- admittedSite "first" (Point 0 0) zero+  secondSite <- admittedSite "second" (Point 2 0) zero+  thirdSite <- admittedSite "third" (Point 0 2) zero+  lowerSite <- admittedSite "center" (Point 0.5 0.5) lowerWeight+  hiddenSite <- admittedSite "center" (Point 0.5 0.5) hiddenWeight+  let lowerSites = firstSite :| [secondSite, thirdSite, lowerSite]+      hiddenSites = firstSite :| [secondSite, thirdSite, hiddenSite]+  (lowerRegular, _) <-+    requireRight "coplanar regular topology" (regularTriangulation lowerSites)+  assertEqual+    "coplanar interior generator remains lower-dimensional"+    (Just RegularSiteLowerDimensional)+    (regularSiteDisposition "center" lowerRegular)+  (lowerDiagram, lowerReceipt) <-+    requireRight "bounded lower-dimensional power cell" (boundedPowerDiagram domain lowerSites)+  case powerCellDisposition "center" lowerDiagram of+    Just (LowerDimensionalPowerCell _) -> pure ()+    other -> fail ("expected lower-dimensional center cell, got " <> dispositionTag other)+  assertEqual "one lower-dimensional oracle cell" 1 (powerDiagramOracleCells lowerReceipt)+  (hiddenRegular, _) <-+    requireRight "hidden regular topology" (regularTriangulation hiddenSites)+  assertEqual+    "strictly interior lifted generator is hidden"+    (Just RegularSiteHidden)+    (regularSiteDisposition "center" hiddenRegular)+  (hiddenDiagram, hiddenReceipt) <-+    requireRight "bounded hidden power cell" (boundedPowerDiagram domain hiddenSites)+  assertEqual "hidden generator has empty cell" (Just EmptyPowerCell) (powerCellDisposition "center" hiddenDiagram)+  assertEqual "hidden generator needs no HPI oracle" 0 (powerDiagramOracleCells hiddenReceipt)+  unless+    ( powerDiagramMaximumCellConstraints hiddenReceipt <= powerDiagramRegularEdges hiddenReceipt+    )+    (fail "power construction retained more axes than the regular graph")++testRegularSiteOwnership :: IO ()+testRegularSiteOwnership = do+  zero <- admittedWeight 0+  sites <-+    traverse+      (\(label, point) -> admittedSite label point zero)+      ( ("c", Point 0 2)+          :| [("a", Point 0 0), ("b", Point 2 0)]+      )+  (regular, receipt) <-+    requireRight "site-owning regular topology" (regularTriangulation sites)+  assertEqual "regular site count" 3 (regularSiteCount regular)+  assertEqual+    "regular sites are the canonical ascending section"+    ["a", "b", "c"]+    (fmap powerSiteLabel (regularSites regular))+  traverse_+    (\site ->+       assertEqual+         ("regular site lookup for " <> powerSiteLabel site)+         (Just site)+         (regularSite (powerSiteLabel site) regular))+    sites+  case NonEmpty.nonEmpty (regularSites regular) of+    Nothing -> fail "nonempty regular topology lost its canonical site section"+    Just retainedSites -> do+      (reconstructed, _) <-+        requireRight "regular reconstruction from owned sites" (regularTriangulation retainedSites)+      assertEqual "owned sites reconstruct the same semantic value" regular reconstructed+  assertEqual "receipt counts every owned site" 3 (regularTriangulationInputSites receipt)+  assertEqual "empty regular site count" 0 (regularSiteCount emptyRegularTriangulation)+  assertEqual+    "empty regular site section"+    ([] :: [PowerSite String])+    (regularSites emptyRegularTriangulation)++testHiddenInsertionAndExposure :: IO ()+testHiddenInsertionAndExposure = do+  zero <- admittedWeight 0+  hiddenWeight <- admittedWeight (-2)+  first <- admittedSite "first" (Point 0 0) zero+  second <- admittedSite "second" (Point 2 0) zero+  third <- admittedSite "third" (Point 0 2) zero+  hidden <- admittedSite "hidden" (Point 0.5 0.5) hiddenWeight+  (initial, _) <-+    requireRight+      "regular hidden-insertion base"+      (regularTriangulation (first :| [second, third]))+  inserted <-+    requireRight "insert hidden regular site" (insertRegularSite hidden initial)+  assertEqual+    "hidden insertion is successful resident publication"+    (Just hidden)+    (regularSite "hidden" (regularEditTriangulation inserted))+  assertEqual+    "hidden insertion disposition"+    [RegularSiteAppeared "hidden" RegularSiteHidden]+    (editTransitions inserted)+  removed <-+    requireRight+      "remove face-defining site"+      (removeRegularSite "first" (regularEditTriangulation inserted))+  assertEqual+    "removal re-exposes a hidden resident"+    (Just RegularSiteVisible)+    (regularSiteDisposition "hidden" (regularEditTriangulation removed))+  assertEqual+    "hidden exposure receipt"+    [ RegularSiteDisappeared "first" RegularSiteVisible+    , RegularSiteTransitioned "hidden" RegularSiteHidden RegularSiteVisible+    ]+    (editTransitions removed)++testRegularInsertionAndRemovalTransitions :: IO ()+testRegularInsertionAndRemovalTransitions = do+  zero <- admittedWeight 0+  dominantWeight <- admittedWeight 1+  resident <- admittedSite "a-resident" (Point 0 0) zero+  dominant <- admittedSite "z-dominant" (Point 0 0) dominantWeight+  (initial, _) <-+    requireRight "regular insertion base" (regularTriangulation (resident :| []))+  inserted <-+    requireRight "dominant regular insertion" (insertRegularSite dominant initial)+  assertEqual+    "insert changed-site support"+    (Set.singleton "z-dominant")+    (regularEditChangedSites inserted)+  assertEqual+    "dominant insertion transitions"+    [ RegularSiteTransitioned+        "a-resident"+        RegularSiteVisible+        (RegularSiteCoincidentDominatedBy "z-dominant")+    , RegularSiteAppeared "z-dominant" RegularSiteVisible+    ]+    (editTransitions inserted)+  removed <-+    requireRight+      "dominant regular removal"+      (removeRegularSite "z-dominant" (regularEditTriangulation inserted))+  assertEqual+    "remove changed-site support"+    (Set.singleton "z-dominant")+    (regularEditChangedSites removed)+  assertEqual+    "dominant removal re-exposes resident"+    [ RegularSiteTransitioned+        "a-resident"+        (RegularSiteCoincidentDominatedBy "z-dominant")+        RegularSiteVisible+    , RegularSiteDisappeared "z-dominant" RegularSiteVisible+    ]+    (editTransitions removed)+  assertEqual+    "insert then remove returns the canonical site value"+    initial+    (regularEditTriangulation removed)++testRegularReweightTransitions :: IO ()+testRegularReweightTransitions = do+  dominantWeight <- admittedWeight 1+  subordinateWeight <- admittedWeight 0+  promotedWeight <- admittedWeight 2+  first <- admittedSite "a" (Point 0 0) dominantWeight+  second <- admittedSite "b" (Point 0 0) subordinateWeight+  (initial, _) <-+    requireRight "regular reweight base" (regularTriangulation (first :| [second]))+  reweighted <-+    requireRight+      "regular batch reweight"+      (reweightRegularSites (Map.singleton "b" promotedWeight) initial)+  assertEqual+    "reweight changed-site support"+    (Set.singleton "b")+    (regularEditChangedSites reweighted)+  assertEqual+    "reweight transitions preserve identities"+    [ RegularSiteTransitioned+        "a"+        RegularSiteVisible+        (RegularSiteCoincidentDominatedBy "b")+    , RegularSiteTransitioned+        "b"+        (RegularSiteCoincidentDominatedBy "a")+        RegularSiteVisible+    ]+    (editTransitions reweighted)+  let revised = regularEditTriangulation reweighted+  assertEqual+    "reweight preserves the site position"+    (Just (Point 0 0))+    (powerSitePosition <$> regularSite "b" revised)+  assertEqual+    "reweight replaces only the requested weight"+    (Just promotedWeight)+    (powerSiteWeight <$> regularSite "b" revised)++testTopologyPreservingEdits :: IO ()+testTopologyPreservingEdits = do+  domain <- squareDomain+  zero <- admittedWeight 0+  one <- admittedWeight 1+  hiddenWeight <- admittedWeight (-2)+  lowerHiddenWeight <- admittedWeight (-3)++  representative <- admittedSite "a" (Point 0 0) one+  subordinate <- admittedSite "b" (Point 0 0) zero+  (coincidentBase, _) <-+    requireRight "coincident edit base" (regularTriangulation (representative :| []))+  inserted <-+    requireRight+      "canonical coincident insertion"+      (insertRegularSite subordinate coincidentBase)+  assertEqual+    "coincident subordinate insertion transition"+    [RegularSiteAppeared "b" (RegularSiteCoincidentDominatedBy "a")]+    (editTransitions inserted)+  assertRegularReconstructs domain "canonical coincident insertion" (regularEditTriangulation inserted)++  reweighted <-+    requireRight+      "topology-preserving coincident reweight"+      (reweightRegularSites (Map.singleton "b" one) (regularEditTriangulation inserted))+  assertEqual+    "coincident subordinate reweight transition"+    [ RegularSiteTransitioned+        "b"+        (RegularSiteCoincidentDominatedBy "a")+        (RegularSiteCoincidentEquivalentTo "a")+    ]+    (editTransitions reweighted)+  assertRegularReconstructs domain "coincident reweight" (regularEditTriangulation reweighted)++  removedSubordinate <-+    requireRight+      "topology-preserving coincident removal"+      (removeRegularSite "b" (regularEditTriangulation reweighted))+  assertEqual+    "coincident subordinate removal transition"+    [RegularSiteDisappeared "b" (RegularSiteCoincidentEquivalentTo "a")]+    (editTransitions removedSubordinate)+  assertRegularReconstructs domain "coincident removal" (regularEditTriangulation removedSubordinate)++  first <- admittedSite "first" (Point 0 0) zero+  second <- admittedSite "second" (Point 2 0) zero+  third <- admittedSite "third" (Point 0 2) zero+  hidden <- admittedSite "hidden" (Point 0.5 0.5) hiddenWeight+  secondHidden <- admittedSite "hidden-second" (Point 0.75 0.5) hiddenWeight+  (hiddenBase, _) <-+    requireRight+      "hidden edit base"+      (regularTriangulation (first :| [second, third, hidden, secondHidden]))+  lowered <-+    requireRight+      "topology-preserving hidden reweight"+      ( reweightRegularSites+          (Map.fromList [("hidden", lowerHiddenWeight), ("hidden-second", lowerHiddenWeight)])+          hiddenBase+      )+  assertEqual+    "hidden batch changed-site support"+    (Set.fromList ["hidden", "hidden-second"])+    (regularEditChangedSites lowered)+  assertEqual "hidden downward reweight has no visibility transition" [] (editTransitions lowered)+  assertRegularReconstructs domain "hidden downward reweight" (regularEditTriangulation lowered)++  removedHidden <-+    requireRight+      "topology-preserving hidden removal"+      (removeRegularSite "hidden" (regularEditTriangulation lowered))+  assertEqual+    "hidden removal transition"+    [RegularSiteDisappeared "hidden" RegularSiteHidden]+    (editTransitions removedHidden)+  assertRegularReconstructs domain "hidden removal" (regularEditTriangulation removedHidden)++assertRegularReconstructs+  :: (Ord label, Show label)+  => ConvexPolygon+  -> String+  -> RegularTriangulation label+  -> IO ()+assertRegularReconstructs domain name edited =+  case NonEmpty.nonEmpty (regularSites edited) of+    Nothing -> assertEqual (name <> " remains empty") 0 (regularSiteCount edited)+    Just sites -> do+      (rebuilt, _) <-+        requireRight (name <> " reconstruction") (regularTriangulation sites)+      let labels = fmap powerSiteLabel (NonEmpty.toList sites)+      assertEqual+        (name <> " receipt")+        (regularTriangulationReceipt rebuilt)+        (regularTriangulationReceipt edited)+      assertEqual+        (name <> " face labels")+        (fmap regularFaceLabels (regularFaces rebuilt))+        (fmap regularFaceLabels (regularFaces edited))+      assertEqual (name <> " faces") (regularFaces rebuilt) (regularFaces edited)+      assertEqual+        (name <> " edge labels")+        (fmap regularEdgeLabels (regularEdges rebuilt))+        (fmap regularEdgeLabels (regularEdges edited))+      assertEqual (name <> " edges") (regularEdges rebuilt) (regularEdges edited)+      traverse_+        (\label -> do+           assertEqual+             (name <> " disposition " <> show label)+             (regularSiteDisposition label rebuilt)+             (regularSiteDisposition label edited)+           assertEqual+             (name <> " neighbours " <> show label)+             (regularNeighbours label rebuilt)+             (regularNeighbours label edited))+        labels+      rebuiltDiagram <-+        requireRight (name <> " rebuilt clipping") (boundedPowerDiagramFromRegular domain rebuilt)+      editedDiagram <-+        requireRight (name <> " edited clipping") (boundedPowerDiagramFromRegular domain edited)+      assertEqual (name <> " bounded cells") rebuiltDiagram editedDiagram++testRegularEditDifferentialLaws :: IO ()+testRegularEditDifferentialLaws = do+  domain <- squareDomain+  sites <- traverse prepareDifferentialSite [0 .. 47]+  nonEmptySites <-+    maybe (fail "differential regular fixture is empty") pure (NonEmpty.nonEmpty sites)+  baseSites <-+    maybe (fail "differential insertion fixture is empty") pure+      (NonEmpty.nonEmpty (NonEmpty.init nonEmptySites))+  (base, _) <- requireRight "differential insertion base" (regularTriangulation baseSites)+  inserted <-+    requireRight+      "differential local insertion"+      (insertRegularSite (NonEmpty.last nonEmptySites) base)+  assertRegularAlphaClosed+    "differential weighted alpha"+    (regularEditTriangulation inserted)+  assertRegularReconstructs+    domain+    "differential insertion"+    (regularEditTriangulation inserted)+  removed <-+    requireRight+      "differential local removal"+      (removeRegularSite "s23" (regularEditTriangulation inserted))+  assertRegularReconstructs+    domain+    "differential removal"+    (regularEditTriangulation removed)+  raised <- admittedWeight 2+  reweighted <-+    requireRight+      "differential local reweight"+      (reweightRegularSites (Map.singleton "s17" raised) (regularEditTriangulation removed))+  assertRegularReconstructs+    domain+    "differential reweight"+    (regularEditTriangulation reweighted)++assertRegularAlphaClosed+  :: (Ord label, Show label)+  => String+  -> RegularTriangulation label+  -> IO ()+assertRegularAlphaClosed name regular = do+  filtration <- requireRight name (regularAlphaFiltration regular)+  traverse_+    (requireRight (name <> " sublevel") . (`regularAlphaComplexAtBirth` filtration))+    (Map.elems (regularAlphaBirths filtration))++prepareDifferentialSite :: Int -> IO (PowerSite String)+prepareDifferentialSite label = do+  let coordinateX = fromIntegral ((label * 37 + 11) `mod` 97) / 10+      coordinateY = fromIntegral ((label * 61 + 7) `mod` 89) / 10+      weightValue = fromIntegral ((label * 17) `mod` 13 - 6) / 64+  weight <- admittedWeight weightValue+  admittedSite ("s" <> show label) (Point coordinateX coordinateY) weight++testRegularEditObstructionsAndIdempotence :: IO ()+testRegularEditObstructionsAndIdempotence = do+  zero <- admittedWeight 0+  one <- admittedWeight 1+  site <- admittedSite "site" (Point 0 0) zero+  conflicting <- admittedSite "site" (Point 0 0) one+  inserted <-+    requireRight+      "insert into empty regular topology"+      (insertRegularSite site emptyRegularTriangulation)+  repeated <-+    requireRight+      "repeat identical regular insertion"+      (insertRegularSite site (regularEditTriangulation inserted))+  assertEqual+    "identical insertion changes no site"+    Set.empty+    (regularEditChangedSites repeated)+  assertEqual "identical insertion has no transitions" [] (editTransitions repeated)+  case insertRegularSite conflicting (regularEditTriangulation inserted) of+    Left (RegularEditSiteConflict "site" resident requested) -> do+      assertEqual "conflict retains resident" site resident+      assertEqual "conflict retains requested site" conflicting requested+    other -> fail ("expected regular edit site conflict, got " <> show other)+  case reweightRegularSites (Map.singleton "missing" zero) (regularEditTriangulation inserted) of+    Left (RegularEditUnknownSites ("missing" :| [])) -> pure ()+    other -> fail ("expected unknown reweight site, got " <> show other)+  absent <-+    requireRight+      "remove absent regular site"+      (removeRegularSite "missing" (regularEditTriangulation inserted))+  assertEqual+    "absent removal changes no site"+    Set.empty+    (regularEditChangedSites absent)+  assertEqual "absent removal has no transitions" [] (editTransitions absent)+  removed <-+    requireRight+      "remove final regular site"+      (removeRegularSite "site" (regularEditTriangulation inserted))+  assertEqual "final removal returns empty" 0 (regularSiteCount (regularEditTriangulation removed))+  assertEqual+    "final removal transition"+    [RegularSiteDisappeared "site" RegularSiteVisible]+    (editTransitions removed)++testBoundedPowerFromRegular :: IO ()+testBoundedPowerFromRegular = do+  domain <- squareDomain+  fixtures <-+    traverse+      (\(name, submitted) -> (,) name <$> traverse prepareOracleSite submitted)+      [ ( "ordinary"+        , ("a", Point 1 1, 0.25)+            :| [("b", Point 3 1, -0.125), ("c", Point 2 3, 0.5)]+        )+      , ( "lower-dimensional"+        , ("a", Point 0 0, 0)+            :| [("b", Point 2 0, 0), ("c", Point 0 2, 0), ("center", Point 0.5 0.5, -1.5)]+        )+      , ( "hidden"+        , ("a", Point 0 0, 0)+            :| [("b", Point 2 0, 0), ("c", Point 0 2, 0), ("center", Point 0.5 0.5, -2)]+        )+      , ( "coincident"+        , ("a", Point 1 1, 0)+            :| [("b", Point 1 1, 0), ("c", Point 3 1, 0)]+        )+      ]+  traverse_ (assertPreparedPowerMatches domain) fixtures+  (emptyDiagram, emptyReceipt) <-+    requireRight+      "bounded power diagram from empty regular source"+      (boundedPowerDiagramFromRegular domain (emptyRegularTriangulation :: RegularTriangulation String))+  assertEqual "empty regular source has no cell dispositions" [] (powerCellDispositions emptyDiagram)+  assertEqual "empty regular source has no input sites" 0 (powerDiagramInputSites emptyReceipt)++assertPreparedPowerMatches+  :: ConvexPolygon+  -> (String, NonEmpty (PowerSite String))+  -> IO ()+assertPreparedPowerMatches domain (name, sites) = do+  (regular, _) <-+    requireRight (name <> " regular source") (regularTriangulation sites)+  oneShot <-+    requireRight (name <> " one-shot power diagram") (boundedPowerDiagram domain sites)+  fromRegular <-+    requireRight+      (name <> " prepared power diagram")+      (boundedPowerDiagramFromRegular domain regular)+  assertEqual (name <> " prepared clipping") oneShot fromRegular++testRegularCollinearClassification :: IO ()+testRegularCollinearClassification = do+  sites <- traverse prepareCollinearSite (0 :| [1 .. 8])+  (regular, _) <-+    requireRight "collinear regular topology" (regularTriangulation sites)+  traverse_+    (\index ->+       assertEqual+         ("collinear disposition for " <> show index)+         (Just (if even index then RegularSiteVisible else RegularSiteHidden))+         (regularSiteDisposition (show index) regular))+    ([0 .. 8] :: [Int])+ where+  prepareCollinearSite :: Int -> IO (PowerSite String)+  prepareCollinearSite index = do+    weight <- admittedWeight (if odd index then -(2 / 256) else 0)+    admittedSite (show index) (Point (fromIntegral index / 16) 0) weight++testSparsePowerMatchesCompleteOracle :: IO ()+testSparsePowerMatchesCompleteOracle = do+  domain <- squareDomain+  sites <-+    traverse+      prepareOracleSite+      ( ("a", Point 1.0 1.0, 0.25)+          :| [ ("b", Point 3.0 0.8, -0.125)+             , ("c", Point 5.2 1.4, 0.375)+             , ("d", Point 8.5 1.0, 0.0)+             , ("e", Point 1.7 3.8, -0.25)+             , ("f", Point 4.1 4.4, 0.125)+             , ("g", Point 7.6 3.5, -0.375)+             , ("h", Point 9.1 5.4, 0.25)+             , ("i", Point 1.0 7.8, 0.0)+             , ("j", Point 3.6 8.9, 0.5)+             , ("k", Point 6.4 7.5, -0.125)+             , ("l", Point 8.8 9.0, 0.375)+             ]+      )+  (diagram, receipt) <-+    requireRight "sparse regular-neighbour power diagram" (boundedPowerDiagram domain sites)+  traverse_+    (\site -> do+       oracle <- completeOraclePowerCell domain sites site+       assertEqual+         ("regular-neighbour cell equals complete HPI oracle for " <> powerSiteLabel site)+         (Just oracle)+         (powerCellDisposition (powerSiteLabel site) diagram))+    sites+  let siteCount = NonEmpty.length sites+      completeConstraintCount = siteCount * (siteCount - 1)+  unless (powerDiagramSubmittedSiteConstraints receipt < completeConstraintCount) $+    fail "regular-neighbour construction did not eliminate the complete pairwise cell schedule"+  unless (powerDiagramMaximumCellConstraints receipt <= powerDiagramRegularEdges receipt) $+    fail "regular-neighbour construction retained a non-topological radical axis"++prepareOracleSite+  :: (String, Point, Double)+  -> IO (PowerSite String)+prepareOracleSite (label, point, weightValue) = do+  weight <- admittedWeight weightValue+  admittedSite label point weight++data OracleScore = OracleScore+  { oracleXCoefficient :: !ExactRational+  , oracleYCoefficient :: !ExactRational+  , oracleConstant :: !ExactRational+  }++oracleScore :: PowerSite label -> IO OracleScore+oracleScore site = do+  point <- requireRight "oracle source point" (exactPointFromPoint (powerSitePosition site))+  let (coordinateX, coordinateY) = exactPointCoordinates point+  pure+    OracleScore+      { oracleXCoefficient = 2 * coordinateX+      , oracleYCoefficient = 2 * coordinateY+      , oracleConstant =+          powerWeightExact (powerSiteWeight site)+            - coordinateX * coordinateX+            - coordinateY * coordinateY+      }++completeOraclePowerCell+  :: ConvexPolygon+  -> NonEmpty (PowerSite String)+  -> PowerSite String+  -> IO (PowerCellDisposition String)+completeOraclePowerCell domain sites owner = do+  retainedDomain <-+    requireRight "oracle retained domain" (exactRetainedPolygon (convexPolygonPoints domain))+  ownerScore <- oracleScore owner+  halfPlanes <-+    traverse+      (oracleWinningHalfPlane ownerScore)+      ( filter+          ((/= powerSiteLabel owner) . powerSiteLabel)+          (NonEmpty.toList sites)+      )+  (disposition, _) <-+    requireRight+      ("complete HPI oracle for " <> powerSiteLabel owner)+      (exactClipRetainedPolygon retainedDomain halfPlanes)+  case disposition of+    ExactClipFullDimensional retained ->+      PublishedPowerCell+        <$> requireRight+          "oracle convex publication"+          (convexPolygon (exactRetainedPolygonPoints retained))+    ExactClipLowerDimensional points ->+      pure (LowerDimensionalPowerCell points)+    ExactClipEmpty -> pure EmptyPowerCell++oracleWinningHalfPlane+  :: OracleScore+  -> PowerSite label+  -> IO ExactClosedHalfPlane+oracleWinningHalfPlane owner competitor = do+  competitorScore <- oracleScore competitor+  line <-+    requireRight+      "oracle radical axis"+      ( exactAffineLine+          (oracleXCoefficient owner - oracleXCoefficient competitorScore)+          (oracleYCoefficient owner - oracleYCoefficient competitorScore)+          (oracleConstant owner - oracleConstant competitorScore)+      )+  pure (exactClosedHalfPlane line)++assertBoundaryDualRay+  :: NonEmpty (PowerSite String)+  -> ExactPoint+  -> RegularEdge String+  -> IO ()+assertBoundaryDualRay sites expectedOrigin edge =+  case regularEdgeDual edge of+    UnboundedPowerDual ray -> do+      assertEqual "regular ray starts at incident face dual" expectedOrigin (exactRayOrigin ray)+      let ExactVector directionX directionY = exactRayDirection ray+      unless (directionX /= 0 || directionY /= 0) $+        fail ("regular edge has a zero dual-ray direction: " <> show (regularEdgeLabels edge))+      let sample = translateExactPoint expectedOrigin (exactRayDirection ray)+          (firstLabel, secondLabel) = regularEdgeLabels edge+      firstSite <- requireSite firstLabel sites+      secondSite <- requireSite secondLabel sites+      firstDistance <- powerDistance sample firstSite+      secondDistance <- powerDistance sample secondSite+      assertEqual "regular ray remains on its radical axis" firstDistance secondDistance+      traverse_+        (\competitor -> do+           competitorDistance <- powerDistance sample competitor+           unless (firstDistance <= competitorDistance) $+             fail ("regular ray points outside the common winning cone: " <> show (firstLabel, secondLabel)))+        sites+    other -> fail ("regular triangle boundary expected a ray, got " <> show other)++requireSite :: Eq label => label -> NonEmpty (PowerSite label) -> IO (PowerSite label)+requireSite label sites =+  case List.find ((== label) . powerSiteLabel) (NonEmpty.toList sites) of+    Nothing -> fail "regular topology references a missing source site"+    Just site -> pure site++testEqualWeightsAndCommonShift :: IO ()+testEqualWeightsAndCommonShift = do+  domain <- squareDomain+  zero <- admittedWeight 0+  shifted <- admittedWeight 7+  zeroSites <-+    ( :| )+      <$> admittedSite "left" (Point 2 5) zero+      <*> traverse (uncurry3 admittedSite) [("right", Point 8 5, zero)]+  shiftedSites <-+    ( :| )+      <$> admittedSite "left" (Point 2 5) shifted+      <*> traverse (uncurry3 admittedSite) [("right", Point 8 5, shifted)]+  (diagram, receipt) <- requireRight "equal-weight power diagram" (boundedPowerDiagram domain zeroSites)+  (shiftedDiagram, _) <- requireRight "common-shift power diagram" (boundedPowerDiagram domain shiftedSites)+  assertEqual "common additive power shift" (powerCellDispositions diagram) (powerCellDispositions shiftedDiagram)+  assertPermutationInvariant "equal-weight power diagram" domain zeroSites diagram+  assertPermutationInvariant "common-shift power diagram" domain shiftedSites shiftedDiagram+  expectedLeft <-+    requireRight+      "expected left power cell"+      (convexPolygon (integerPoint 0 0 :| [integerPoint 5 0, integerPoint 5 10, integerPoint 0 10]))+  expectedRight <-+    requireRight+      "expected right power cell"+      (convexPolygon (integerPoint 5 0 :| [integerPoint 10 0, integerPoint 10 10, integerPoint 5 10]))+  assertEqual "equal-weight left bisector cell" (Just (PublishedPowerCell expectedLeft)) (powerCellDisposition "left" diagram)+  assertEqual "equal-weight right bisector cell" (Just (PublishedPowerCell expectedRight)) (powerCellDisposition "right" diagram)+  assertEqual "receipt input sites" 2 (powerDiagramInputSites receipt)+  assertEqual+    "one submitted site constraint per cell"+    2+    (powerDiagramSubmittedSiteConstraints receipt)+  assertEqual+    "parallel domain and site boundaries coalesce"+    8+    (powerDiagramActiveBoundaries receipt)+  assertEqual "receipt published cells" 2 (powerDiagramPublishedCells receipt)+  assertEqual "receipt empty cells" 0 (powerDiagramEmptyCells receipt)+  traverse_ (assertPublishedVerticesWin zeroSites) (powerCellDispositions diagram)+  let layer = powerDiagramPlanarLayer diagram+  assertEqual "derived layer contains both cells" [Just "left", Just "right"] (Map.keys (planarLayerRegions layer))++testThreeSiteExactPartitionCoverage :: IO ()+testThreeSiteExactPartitionCoverage = do+  domain <- squareDomain+  weight <- admittedWeight 0+  left <- admittedSite "left" (Point 2 5) weight+  middle <- admittedSite "middle" (Point 5 5) weight+  right <- admittedSite "right" (Point 8 5) weight+  let sites = left :| [middle, right]+  (diagram, receipt) <-+    requireRight "three-site exact partition" (boundedPowerDiagram domain sites)+  assertEqual "three-site partition publishes every cell" 3 (powerDiagramPublishedCells receipt)+  assertEqual+    "three-site exact cell areas cover the square"+    200+    (publishedTwiceAreaSum diagram)+  traverse_+    (\permutation -> do+       (permuted, _) <-+         requireRight+           "permuted three-site exact partition"+           (boundedPowerDiagram domain permutation)+       assertEqual+         "three-site partition is permutation invariant"+         (powerCellDispositions diagram)+         (powerCellDispositions permuted)+       assertEqual+         "permuted exact cell areas cover the square"+         200+         (publishedTwiceAreaSum permuted))+    (nonEmptyPermutations sites)++nonEmptyPermutations :: NonEmpty value -> [NonEmpty value]+nonEmptyPermutations =+  foldMap (maybe [] pure . NonEmpty.nonEmpty)+    . List.permutations+    . NonEmpty.toList++assertPermutationInvariant+  :: String+  -> ConvexPolygon+  -> NonEmpty (PowerSite String)+  -> BoundedPowerDiagram String+  -> IO ()+assertPermutationInvariant label domain sites expected =+  traverse_+    (\permutation -> do+       (permuted, _) <-+         requireRight+           (label <> " permutation")+           (boundedPowerDiagram domain permutation)+       assertEqual+         (label <> " is permutation invariant")+         (powerCellDispositions expected)+         (powerCellDispositions permuted))+    (nonEmptyPermutations sites)++publishedTwiceAreaSum :: BoundedPowerDiagram label -> ExactRational+publishedTwiceAreaSum =+  List.foldl'+    (\total (_, disposition) -> case disposition of+        PublishedPowerCell polygon -> total + exactPolygonTwiceArea (convexPolygonPoints polygon)+        LowerDimensionalPowerCell _ -> total+        EmptyPowerCell -> total+        CoincidentEquivalentTo _ -> total+        CoincidentDominatedBy _ -> total)+    0+    . powerCellDispositions++exactPolygonTwiceArea :: NonEmpty ExactPoint -> ExactRational+exactPolygonTwiceArea points =+  abs+    ( List.foldl'+        (\twiceArea (firstPoint, secondPoint) ->+           let (firstX, firstY) = exactPointCoordinates firstPoint+               (secondX, secondY) = exactPointCoordinates secondPoint+            in twiceArea + firstX * secondY - firstY * secondX)+        0+        (cyclicPairs points)+    )++cyclicPairs :: NonEmpty value -> [(value, value)]+cyclicPairs (firstValue :| remainingValues) =+  zip+    (firstValue : remainingValues)+    (remainingValues <> [firstValue])++testEqualCoincidentResolution :: IO ()+testEqualCoincidentResolution = do+  domain <- squareDomain+  weight <- admittedWeight 3+  a <- admittedSite "a" (Point 4 4) weight+  b <- admittedSite "b" (Point 4 4) weight+  (diagram, receipt) <- requireRight "equivalent coincident power sites" (boundedPowerDiagram domain (b :| [a]))+  assertPublished "coincident canonical representative" (powerCellDisposition "a" diagram)+  assertEqual "equal-function coincident alias" (Just (CoincidentEquivalentTo "a")) (powerCellDisposition "b" diagram)+  assertEqual "equivalent coincidence receipt" 1 (powerDiagramCoincidentEquivalentCells receipt)+  assertEqual "equivalent coincidence is not dominance" 0 (powerDiagramCoincidentDominatedCells receipt)+  (permuted, _) <- requireRight "permuted equivalent sites" (boundedPowerDiagram domain (a :| [b]))+  assertEqual "equivalent resolution permutation invariance" (powerCellDispositions diagram) (powerCellDispositions permuted)++testDominantCoincidentResolution :: IO ()+testDominantCoincidentResolution = do+  domain <- squareDomain+  high <- admittedWeight 3+  low <- admittedWeight 2+  winner <- admittedSite "winner" (Point 4 4) high+  dominated <- admittedSite "dominated" (Point 4 4) low+  (diagram, receipt) <- requireRight "dominant coincident power sites" (boundedPowerDiagram domain (dominated :| [winner]))+  assertPublished "dominant coincident representative" (powerCellDisposition "winner" diagram)+  assertEqual "lower-weight coincident site" (Just (CoincidentDominatedBy "winner")) (powerCellDisposition "dominated" diagram)+  assertEqual "dominant coincidence receipt" 1 (powerDiagramCoincidentDominatedCells receipt)+  assertEqual "dominance is not equivalence" 0 (powerDiagramCoincidentEquivalentCells receipt)+  assertPermutationInvariant "dominant coincident power sites" domain (dominated :| [winner]) diagram++testLowerDimensionalCell :: IO ()+testLowerDimensionalCell = do+  domain <- squareDomain+  zero <- admittedWeight 0+  suppressed <- admittedWeight (-1)+  left <- admittedSite "left" (Point 0 5) zero+  right <- admittedSite "right" (Point 2 5) zero+  middle <- admittedSite "middle" (Point 1 5) suppressed+  let sites = left :| [right, middle]+  (diagram, receipt) <- requireRight "one-dimensional bounded power cell" (boundedPowerDiagram domain sites)+  case powerCellDisposition "middle" diagram of+    Just (LowerDimensionalPowerCell points) ->+      assertEqual+        "middle cell is the exact x=1 segment"+        (List.sort [integerPoint 1 0, integerPoint 1 10])+        (List.sort (NonEmpty.toList points))+    other -> fail ("one-dimensional power cell: expected retained segment, got " <> dispositionTag other)+  assertEqual "lower-dimensional receipt" 1 (powerDiagramLowerDimensionalCells receipt)+  assertEqual "lower-dimensional cell is not empty" 0 (powerDiagramEmptyCells receipt)+  assertEqual "two full-dimensional neighbours" 2 (powerDiagramPublishedCells receipt)+  traverse_ (assertPublishedVerticesWin sites) (powerCellDispositions diagram)+  let layer = powerDiagramPlanarLayer diagram+  assertEqual "derived layer omits the one-dimensional cell" [Just "left", Just "right"] (Map.keys (planarLayerRegions layer))+  assertPermutationInvariant "one-dimensional bounded power cell" domain sites diagram++testDistinctEmptyCell :: IO ()+testDistinctEmptyCell = do+  domain <- squareDomain+  ordinary <- admittedWeight 0+  suppressed <- admittedWeight (-1000)+  winner <- admittedSite "winner" (Point 0 0) ordinary+  hidden <- admittedSite "hidden" (Point 5 5) suppressed+  (diagram, receipt) <- requireRight "distinct empty power cell" (boundedPowerDiagram domain (winner :| [hidden]))+  assertPublished "dominant distinct site" (powerCellDisposition "winner" diagram)+  assertEqual "distinct site may have empty bounded cell" (Just EmptyPowerCell) (powerCellDisposition "hidden" diagram)+  assertEqual "empty disposition receipt" 1 (powerDiagramEmptyCells receipt)+  assertPermutationInvariant "distinct empty power cell" domain (winner :| [hidden]) diagram++testDyadicNearParallelBisectors :: IO ()+testDyadicNearParallelBisectors = do+  domain <- squareDomain+  weight <- admittedWeight 0+  let epsilon = 2 ** (-20) :: Double+  origin <- admittedSite "origin" (Point 0 0) weight+  horizontal <- admittedSite "horizontal" (Point 2 0) weight+  tilted <- admittedSite "tilted" (Point 2 epsilon) weight+  let sites = origin :| [horizontal, tilted]+  (diagram, receipt) <-+    requireRight+      "dyadic near-parallel power bisectors"+      (boundedPowerDiagram domain sites)+  assertEqual "near-parallel cells retain full dimension" 3 (powerDiagramPublishedCells receipt)+  traverse_ (assertPublishedVerticesWin sites) (powerCellDispositions diagram)+  assertPermutationInvariant "dyadic near-parallel power bisectors" domain sites diagram++testBinary64PrecisionSites :: IO ()+testBinary64PrecisionSites = do+  domain <- squareDomain+  firstWeight <- admittedWeight 0.2+  secondWeight <- admittedWeight (-0.3)+  thirdWeight <- admittedWeight 0.7+  firstSite <- admittedSite "first" (Point 0.1 0.3) firstWeight+  secondSite <- admittedSite "second" (Point 9.7 0.2) secondWeight+  thirdSite <- admittedSite "third" (Point 4.9 9.6) thirdWeight+  let sites = firstSite :| [secondSite, thirdSite]+  (diagram, receipt) <-+    requireRight+      "exact binary64 power sites"+      (boundedPowerDiagram domain sites)+  assertEqual "binary64 fixture publishes every cell" 3 (powerDiagramPublishedCells receipt)+  traverse_ (assertPublishedVerticesWin sites) (powerCellDispositions diagram)+  assertPermutationInvariant "exact binary64 power sites" domain sites diagram++testDuplicateLabels :: IO ()+testDuplicateLabels = do+  domain <- squareDomain+  weight <- admittedWeight 0+  firstSite <- admittedSite "duplicate" (Point 1 1) weight+  secondSite <- admittedSite "duplicate" (Point 9 9) weight+  case boundedPowerDiagram domain (firstSite :| [secondSite]) of+    Left (DuplicatePowerSiteLabel "duplicate") -> pure ()+    other -> fail ("duplicate power-site label: expected typed refusal, got " <> show other)++testNonFiniteWeight :: IO ()+testNonFiniteWeight =+  case powerWeight (0 / 0) of+    Left (PowerWeightNonFinite _) -> pure ()+    other -> fail ("non-finite power weight: expected typed refusal, got " <> show other)++editTransitions+  :: RegularEditResult label+  -> [RegularSiteTransition label]+editTransitions =+  Vector.toList . regularEditTransitions++squareDomain :: IO ConvexPolygon+squareDomain =+  requireRight+    "square clipping domain"+    (convexPolygon (integerPoint 0 0 :| [integerPoint 10 0, integerPoint 10 10, integerPoint 0 10]))++admittedWeight :: Double -> IO PowerWeight+admittedWeight value =+  requireRight+    "finite power weight"+    (powerWeight value)++admittedSite :: String -> Point -> PowerWeight -> IO (PowerSite String)+admittedSite label point weight = requireRight "admitted power site" (powerSite label point weight)++uncurry3 :: (a -> b -> c -> result) -> (a, b, c) -> result+uncurry3 function (firstValue, secondValue, thirdValue) = function firstValue secondValue thirdValue++assertPublished :: String -> Maybe (PowerCellDisposition label) -> IO ()+assertPublished _ (Just (PublishedPowerCell _)) = pure ()+assertPublished label other = fail (label <> ": expected published cell, got " <> dispositionTag other)++dispositionTag :: Maybe (PowerCellDisposition label) -> String+dispositionTag Nothing = "missing"+dispositionTag (Just (PublishedPowerCell _)) = "published"+dispositionTag (Just (LowerDimensionalPowerCell _)) = "lower-dimensional"+dispositionTag (Just EmptyPowerCell) = "empty"+dispositionTag (Just (CoincidentEquivalentTo _)) = "coincident-equivalent"+dispositionTag (Just (CoincidentDominatedBy _)) = "coincident-dominated"++requireSome :: String -> Maybe value -> IO value+requireSome label value =+  case value of+    Just present -> pure present+    Nothing -> fail (label <> ": missing value")++assertPublishedVerticesWin+  :: NonEmpty (PowerSite String)+  -> (String, PowerCellDisposition String)+  -> IO ()+assertPublishedVerticesWin sites (ownerLabel, disposition) =+  case disposition of+    PublishedPowerCell polygon ->+      assertCellPointsWin ownerLabel sites (convexPolygonPoints polygon)+    LowerDimensionalPowerCell points ->+      assertCellPointsWin ownerLabel sites points+    EmptyPowerCell -> pure ()+    CoincidentEquivalentTo _ -> pure ()+    CoincidentDominatedBy _ -> pure ()++assertCellPointsWin+  :: String+  -> NonEmpty (PowerSite String)+  -> NonEmpty ExactPoint+  -> IO ()+assertCellPointsWin ownerLabel sites points =+  case lookupOwner ownerLabel (NonEmpty.toList sites) of+    Nothing -> fail ("power-cell owner missing: " <> ownerLabel)+    Just owner ->+      traverse_+        (\point -> traverse_ (assertOwnerWinsAt point owner) sites)+        points++lookupOwner :: Eq label => label -> [PowerSite label] -> Maybe (PowerSite label)+lookupOwner label = List.find ((== label) . powerSiteLabel)++assertOwnerWinsAt+  :: ExactPoint+  -> PowerSite String+  -> PowerSite String+  -> IO ()+assertOwnerWinsAt point owner competitor = do+  ownerValue <- powerDistance point owner+  competitorValue <- powerDistance point competitor+  unless (ownerValue <= competitorValue) $+    fail+      ( "power-cell vertex violates source inequality: "+          <> show (powerSiteLabel owner, powerSiteLabel competitor, ownerValue, competitorValue)+      )++powerDistance :: ExactPoint -> PowerSite label -> IO ExactRational+powerDistance point site = do+  exactSite <- requireRight "site exact position" (exactPointFromPoint (powerSitePosition site))+  let (x, y) = exactPointCoordinates point+      (siteX, siteY) = exactPointCoordinates exactSite+      deltaX = x - siteX+      deltaY = y - siteY+  pure (deltaX * deltaX + deltaY * deltaY - powerWeightExact (powerSiteWeight site))
+ 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/ScheduleAgreementSpec.hs view
@@ -0,0 +1,72 @@+-- | The schedule-agreement slice: the seam merge publishes what the reference+-- rebuild publishes. It travels and dies with the schedule it names.+module Moonlight.Triangulation.ScheduleAgreementSpec (tests) where++import Control.Monad (forM_, when)+import Data.IORef (modifyIORef', newIORef, readIORef)+import Moonlight.Triangulation (Point (Point), canonicalize, union)+import Moonlight.Triangulation.AlgebraFixtures+  ( assertMesh+  , meshOf+  , operands+  , separatedOperands+  , siteList+  )+import Moonlight.Triangulation.Internal.Join.Seam (executeSeam, planSeam)+import Support (requireRight)++tests :: IO ()+tests = do+  testSeamAgreesWithReference+  putStrLn "schedule agreement: ok"++-- | The seam schedule and the reference schedule are the same function.+--+-- A join has one meaning and several internal schedules, so this is the law+-- that lets a second one exist at all: for every input where the seam applies,+-- it must publish the value the rebuild publishes — not an isomorphic mesh, the+-- same value, once both are canonically numbered.+--+-- The guard matters more than the equality. 'executeSeam' can only be reached+-- with the opaque proof returned by 'planSeam'; the run fails if too few cases+-- obtain that proof, so the reference cannot quietly be compared with itself.+testSeamAgreesWithReference :: IO ()+testSeamAgreesWithReference = do+  separable <- separatedOperands+  overlapping <- operands+  taken <- newIORef (0 :: Int)+  forM_ separable $ \((leftName, left), (rightName, right)) -> do+    let label = "seam " <> leftName <> " / " <> rightName+    seamPlan <- case planSeam left right of+      Nothing ->+        fail (label <> ": the operands are separated but planSeam refused them")+      Just admitted -> do+        modifyIORef' taken (+ 1)+        pure admitted+    rawRebuild <- meshOf label [Point x y | (x, y) <- siteList left <> siteList right]+    rebuilt <- requireRight (label <> ", canonical rebuild") (canonicalize rawRebuild)+    seamed <- requireRight (label <> ", direct seam") (executeSeam seamPlan left right)+    canonicalSeam <- requireRight (label <> ", canonical seam") (canonicalize seamed)+    assertMesh (label <> ", against a rebuild") rebuilt canonicalSeam+    joined <- requireRight (label <> ", through union") (union left right)+    canonicalJoined <- requireRight (label <> ", canonical union") (canonicalize joined)+    assertMesh (label <> ", through the operator") rebuilt canonicalJoined+  forM_ [(l, r) | l <- overlapping, r <- overlapping] $ \((leftName, left), (rightName, right)) ->+    case planSeam left right of+      Nothing -> pure ()+      Just seamPlan -> do+        rawRebuild <-+          meshOf+            ("seam admission " <> leftName <> " / " <> rightName)+            [Point x y | (x, y) <- siteList left <> siteList right]+        rebuilt <- requireRight "seam admission canonical rebuild" (canonicalize rawRebuild)+        seamed <- requireRight "seam admission" (executeSeam seamPlan left right)+        canonicalSeam <- requireRight "seam admission canonical seam" (canonicalize seamed)+        assertMesh+          ("seam admission " <> leftName <> " / " <> rightName)+          rebuilt+          canonicalSeam+        modifyIORef' taken (+ 1)+  count <- readIORef taken+  when (count < 3) $+    fail ("seam agreement: only " <> show count <> " cases entered the seam, so the law asserted nothing")
+ test/algebra/Moonlight/Triangulation/ValuationSpec.hs view
@@ -0,0 +1,335 @@+-- | 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+  , exactRational+  )+import Moonlight.Triangulation.Overlay+  ( overlayClosedIntersection+  , overlayClosedUnion+  , overlayLayers+  , overlaySelectedRegion+  )+import Moonlight.Triangulation.Region+  ( PlanarRegion+  , emptyPlanarRegion+  , planarRegion+  , planarRegionComponents+  )+import Moonlight.Triangulation.Valuation+  ( CertifiedInterval (..)+  , ExactPlanarMoments+  , ExactLengthTerm+  , PlanarValuations+  , ValuationError (ValuationCellSetNotPureRegion)+  , cellSetPerimeter+  , cellValuations+  , exactAreaValue+  , exactLengthBounds+  , exactLengthExpression+  , exactLengthTerms+  , exactPlanarFirstX+  , exactPlanarFirstY+  , exactPlanarMeasure+  , exactPlanarSecondXX+  , exactPlanarSecondXY+  , exactPlanarSecondYY+  , eulerCharacteristicValue+  , lengthCoefficient+  , polygonComponentArea+  , polygonComponentMoments+  , regionPerimeter+  , regionValuations+  , scaleExactPlanarMoments+  , squaredLength+  , valuationArea+  , valuationEuler+  , valuationIntrinsic1+  )+import Support (assertEqual, requireRight)++tests :: IO ()+tests = do+  testRegionGoldenValues+  testExactPlanarMoments+  testClosedCellInclusionExclusion+  testDimensionalCellFixtures+  testMetricInvariance+  putStrLn "valuation: ok"++testExactPlanarMoments :: IO ()+testExactPlanarMoments = do+  unit <- rectangleComponent 0 0 1 1+  oneHalfValue <- exactValue 1 2+  oneThird <- exactValue 1 3+  oneQuarter <- exactValue 1 4+  let unitMoments = polygonComponentMoments unit+  assertEqual+    "area is the measure projection"+    (exactPlanarMeasure unitMoments)+    (exactAreaValue (polygonComponentArea unit))+  assertEqual+    "unit-square moments"+    (1, oneHalfValue, oneHalfValue, oneThird, oneQuarter, oneThird)+    (momentDigest unitMoments)++  translated <- rectangleComponent 2 (-1) 4 2+  assertEqual+    "translated-rectangle moments"+    (6, 18, 3, 56, 9, 6)+    (momentDigest (polygonComponentMoments translated))++  annulus <- annulusRegion (0, 0, 3, 3) (1, 1, 2, 2)+  seventyFourThirds <- exactValue 74 3+  let annulusMoments = foldMap polygonComponentMoments (planarRegionComponents annulus)+  assertEqual+    "annulus moments respect clockwise holes"+    (8, 12, 12, seventyFourThirds, 18, seventyFourThirds)+    (momentDigest annulusMoments)+  assertEqual+    "moment monoid and scalar action"+    (momentDigest (unitMoments <> unitMoments))+    (momentDigest (scaleExactPlanarMoments 2 unitMoments))++momentDigest+  :: ExactPlanarMoments+  -> (ExactRational, ExactRational, ExactRational, ExactRational, ExactRational, ExactRational)+momentDigest moments =+  ( exactPlanarMeasure moments+  , exactPlanarFirstX moments+  , exactPlanarFirstY moments+  , exactPlanarSecondXX moments+  , exactPlanarSecondXY moments+  , exactPlanarSecondYY moments+  )++exactValue :: Integer -> Integer -> IO ExactRational+exactValue numerator denominator =+  requireRight "exact valuation fixture" (exactRational numerator denominator)++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/cell-complex/Main.hs view
@@ -0,0 +1,484 @@+module Main (main) where++import Data.Bits (shiftL)+import Data.Function ((&))+import Data.Foldable (traverse_)+import Data.List qualified as List+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.Ratio ((%))+import Data.Set qualified as Set+import Data.Vector qualified as Vector+import Moonlight.Hex.CellComplex (finiteHexCellComplex)+import Moonlight.Hex.Coordinate (HexCoord (..), allHexDirections, hexStepCoord)+import Moonlight.Hex.Region (hexLayout, hexRegionFromCoords)+import Moonlight.Homology.Boundary+  ( BoundaryEntry+  , boundaryCoefficient+  , boundaryEntries+  , degreeCardinality+  , incidenceMatrixAt+  , sourceIndex+  , targetIndex+  )+import Moonlight.Homology.Chain+  ( HomologicalDegree (..)+  , PersistencePair (..)+  )+import Moonlight.Homology.Persistence+  ( FilteredFiniteChainComplex+  , filteredBaseComplex+  , filteredCellBirths+  , mod2PersistentPairs+  )+import Moonlight.Homology.Topology+  ( BasisCellRef (..)+  , freeBettiVector+  )+import Moonlight.Homology.Pure.Topology.CellComplex+  ( CellComplex2D (..),+    CellTypes (..),+    OrientedEdge (..),+    ValidateComplex2D (..),+    eulerCharacteristic,+    isBoundaryEdge,+  )+import Moonlight.Triangulation.Alpha+  ( AlphaBirth+  , AlphaFiltration+  , alphaBirthDenominator+  , alphaBirthNumerator+  , alphaEdgeBirth+  , alphaFaceBirth+  , alphaFiltration+  , alphaFiltrationCellSet+  , alphaVertexBirth+  )+import Moonlight.Triangulation.BulkLoad (delaunayGeometry)+import Moonlight.Triangulation.CellSet+  ( ExactCellSet,+    closeFaceCellSet,+    exactCellSetEdgeCount,+    exactCellSetFaceCount,+    exactCellSetVertexCount,+  )+import Moonlight.Triangulation.CellComplex+  ( DCELComplex+  , filteredAlphaComplex+  , finiteChainComplex+  , fromExactCellSet+  )+import Moonlight.Triangulation.Dcel+  ( undirectedEndpoints+  , vertexPoint+  )+import Moonlight.Triangulation.Internal.HandleDefs+  ( UndirectedEdgeId+  )+import Moonlight.Triangulation.Handles.Iterators.FixedIterators+  ( innerFaces+  , undirectedEdges+  )+import Moonlight.Triangulation.Internal.Dyadic (exactDiametralDot)+import Moonlight.Triangulation.Internal.ExactRational+  ( exactRational+  , exactRationalFromDyadic+  , exactRationalFromDyadicRatio+  )+import Moonlight.Triangulation.Internal.Predicates (inDiametralCircle)+import Moonlight.Triangulation.LabelledComplex (filteredPlanarComplex)+import Moonlight.Triangulation.Simplex+  ( planarComplex+  , planarEdge+  , planarFace+  , planarVertex+  )+import Moonlight.Triangulation.Types+  ( DelaunayTriangulation+  , Point (..)+  )+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit ((@?=), Assertion, assertBool, assertFailure, testCase)++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+  testGroup+    "ExactCellSet bridge"+    [ testCase "preserves the admitted cell inventory" preserveCellInventory,+      testCase "preserves downward-closed incidence" preserveClosedIncidence,+      testCase "marks the triangular exterior as absent" preserveExteriorAdjacency,+      testCase "lowers oriented DCEL incidence to a checked integral chain complex" lowerIntegralChainComplex,+      testCase "lowers a native hexagonal ring through the same chain owner" lowerHexagonalRing,+      testCase "assigns exact Gabriel and non-Gabriel alpha births" exactAlphaBirths,+      testCase "preserves exact dyadic rational normalization" exactDyadicRationalNormalization,+      testCase "orders cached alpha keys by their exact rational births" alphaBirthOrderMatchesExactRationals,+      testCase "agrees with the exact diametral predicate" diametralPredicateMatchesExactSign,+      testCase "keeps every boundary cell no later than its coface" alphaBirthsAreFaceMonotone,+      testCase "finds the square alpha hole from radius one to radius two" squareAlphaPersistence,+      testCase "lowers a labelled planar filtration through the same Homology owner" labelledPlanarPersistence,+      testCase "keeps point and collinear alpha filtrations total" degenerateSupportFiltrations+    ]++preserveCellInventory :: Assertion+preserveCellInventory =+  withTriangleComplex $ \cellSet complexValue -> do+    length (vertices complexValue) @?= exactCellSetVertexCount cellSet+    length (edges complexValue) @?= exactCellSetEdgeCount cellSet+    length (faces complexValue) @?= exactCellSetFaceCount cellSet+    (length (vertices complexValue), length (edges complexValue), length (faces complexValue))+      @?= (3, 3, 1)+    eulerCharacteristic complexValue @?= 1+    validateComplex complexValue @?= []++preserveClosedIncidence :: Assertion+preserveClosedIncidence =+  withTriangleComplex $ \_ complexValue -> do+    traverse_ (assertSelectedEdgeEndpoints complexValue) (edges complexValue)+    traverse_ (assertSelectedFaceBoundary complexValue) (faces complexValue)+    fmap (length . edgesAtVertex complexValue) (vertices complexValue) @?= [2, 2, 2]++preserveExteriorAdjacency :: Assertion+preserveExteriorAdjacency =+  withTriangleComplex $ \_ complexValue ->+    assertBool+      "every edge of a single selected triangle has one exterior incident face"+      (all (isBoundaryEdge complexValue) (edges complexValue))++lowerIntegralChainComplex :: Assertion+lowerIntegralChainComplex =+  withTriangleComplex $ \_ complexValue -> do+    finite <- requireRight "triangle finite chain lowering" (finiteChainComplex complexValue)+    freeBettiVector finite @?= [1, 0, 0]++lowerHexagonalRing :: Assertion+lowerHexagonalRing = do+  layout <- requireRight "hexagonal ring layout" (hexLayout (HexCoord (-1) (-1)) 3 3)+  let ringCoordinates =+        [ coordinate+        | direction <- NonEmpty.toList allHexDirections+        , Just coordinate <- [hexStepCoord (HexCoord 0 0) direction]+        ]+  region <- requireRight "hexagonal ring region" (hexRegionFromCoords layout ringCoordinates)+  finite <- requireRight "hexagonal ring chain lowering" (finiteHexCellComplex region)+  freeBettiVector finite @?= [1, 1, 0]++exactAlphaBirths :: Assertion+exactAlphaBirths = do+  triangulation <- requireDelaunay "obtuse triangle" obtuseTrianglePoints+  filtration <- requireRight "obtuse triangle alpha filtration" (alphaFiltration triangulation)+  let vertexBirthRatios =+        vertices (fromExactCellSet (alphaFiltrationCellSet filtration))+          & fmap (fmap alphaBirthRatio . alphaVertexBirth filtration)+      faceBirthRatios =+        faces (fromExactCellSet (alphaFiltrationCellSet filtration))+          & fmap (fmap alphaBirthRatio . alphaFaceBirth filtration)+  assertBool "every vertex is born at zero" (all (== Just (0, 1)) vertexBirthRatios)+  faceBirthRatios @?= [Just (25, 4)]+  longEdge <- requireSome "obtuse triangle long edge" (edgeBetween triangulation (Point (-2) 0) (Point 2 0))+  fmap alphaBirthRatio (alphaEdgeBirth filtration longEdge) @?= Just (25, 4)+  let shortEdgeBirths =+        edges (fromExactCellSet (alphaFiltrationCellSet filtration))+          & filter (/= longEdge)+          & fmap (fmap alphaBirthRatio . alphaEdgeBirth filtration)+  shortEdgeBirths @?= [Just (5, 4), Just (5, 4)]++exactDyadicRationalNormalization :: Assertion+exactDyadicRationalNormalization = do+  traverse_ assertDyadic+    [ (0, -200)+    , (12, -5)+    , (-12, -5)+    , (3, 4)+    , (2 ^ (80 :: Int) + 8, -70)+    ]+  traverse_ assertDyadicRatio+    [ (0, 7, -200)+    , (96, 40, -11)+    , (-96, 40, 9)+    , (45, -28, -3)+    , (2 ^ (120 :: Int) + 24, 2 ^ (75 :: Int) + 12, -51)+    ]+ where+  assertDyadic (numerator, power) =+    Right (exactRationalFromDyadic numerator power)+      @?= ( if power >= 0+              then exactRational (numerator `shiftL` power) 1+              else exactRational numerator (1 `shiftL` negate power)+          )+  assertDyadicRatio (numerator, denominator, power) =+    exactRationalFromDyadicRatio numerator denominator power+      @?= ( if power >= 0+              then exactRational (numerator `shiftL` power) denominator+              else exactRational numerator (denominator `shiftL` negate power)+          )++alphaBirthOrderMatchesExactRationals :: Assertion+alphaBirthOrderMatchesExactRationals = do+  filtrations <-+    traverse+      (\(label, points) -> requireDelaunay label points >>= requireRight (label <> " alpha filtration") . alphaFiltration)+      [ ("exact-order obtuse triangle", obtuseTrianglePoints)+      , ("exact-order square", squarePoints)+      ]+  let births = filtrations >>= allAlphaBirths+  traverse_+    ( \(leftBirth, rightBirth) ->+        compare leftBirth rightBirth+          @?= compare (alphaBirthRational leftBirth) (alphaBirthRational rightBirth)+    )+    [(leftBirth, rightBirth) | leftBirth <- births, rightBirth <- births]++diametralPredicateMatchesExactSign :: Assertion+diametralPredicateMatchesExactSign =+  traverse_+    ( \(firstPoint, secondPoint, witnessPoint) ->+        inDiametralCircle firstPoint secondPoint witnessPoint+          @?= exactDiametralMembership firstPoint secondPoint witnessPoint+    )+    [ (Point (-1) 0, Point 1 0, Point 0 0)+    , (Point (-1) 0, Point 1 0, Point 0 2)+    , (Point (-1) 0, Point 1 0, Point 0 1)+    , (Point (-1) 0, Point 1 0, Point 0 (1 + encodeFloat 1 (-52)))+    , (Point (-1e40) 0, Point 1e40 0, Point 0 1e40)+    ]++allAlphaBirths :: AlphaFiltration -> [AlphaBirth]+allAlphaBirths filtration =+  let complexValue = fromExactCellSet (alphaFiltrationCellSet filtration)+   in mapMaybe (alphaVertexBirth filtration) (vertices complexValue)+        <> mapMaybe (alphaEdgeBirth filtration) (edges complexValue)+        <> mapMaybe (alphaFaceBirth filtration) (faces complexValue)++alphaBirthRational :: AlphaBirth -> Rational+alphaBirthRational birth =+  alphaBirthNumerator birth % alphaBirthDenominator birth++exactDiametralMembership :: Point -> Point -> Point -> Bool+exactDiametralMembership (Point ax ay) (Point bx by) (Point px py) =+  exactDiametralDot ax ay bx by px py <= 0++alphaBirthsAreFaceMonotone :: Assertion+alphaBirthsAreFaceMonotone = do+  triangulation <- requireDelaunay "alpha monotonicity square" squarePoints+  filtration <- requireRight "alpha monotonicity filtration" (alphaFiltration triangulation)+  filtered <- requireRight "alpha monotonicity filtered complex" (filteredAlphaComplex filtration)+  traverse_+    (assertBoundaryDegreeMonotone filtered)+    [HomologicalDegree 1, HomologicalDegree 2]++assertBoundaryDegreeMonotone+  :: FilteredFiniteChainComplex AlphaBirth Int+  -> HomologicalDegree+  -> Assertion+assertBoundaryDegreeMonotone filtered degreeValue =+  traverse_+    (assertBoundaryEntryMonotone filtered degreeValue)+    ( boundaryEntries+        (incidenceMatrixAt (filteredBaseComplex filtered) degreeValue)+    )++assertBoundaryEntryMonotone+  :: FilteredFiniteChainComplex AlphaBirth Int+  -> HomologicalDegree+  -> BoundaryEntry Int+  -> Assertion+assertBoundaryEntryMonotone filtered degreeValue@(HomologicalDegree degreeIndex) entryValue = do+  let sourceCell =+        BasisCellRef+          { cellDegree = degreeValue+          , cellIndex = sourceIndex entryValue+          }+      targetCell =+        BasisCellRef+          { cellDegree = HomologicalDegree (degreeIndex - 1)+          , cellIndex = targetIndex entryValue+          }+      births = filteredCellBirths filtered+  sourceBirth <- requireSome "source alpha birth" (Map.lookup sourceCell births)+  targetBirth <- requireSome "boundary alpha birth" (Map.lookup targetCell births)+  assertBool+    ("boundary birth exceeds coface birth for " <> show (targetCell, sourceCell, boundaryCoefficient entryValue))+    (targetBirth <= sourceBirth)++squareAlphaPersistence :: Assertion+squareAlphaPersistence = do+  triangulation <- requireDelaunay "cocircular square" squarePoints+  filtration <- requireRight "cocircular square alpha filtration" (alphaFiltration triangulation)+  filtered <- requireRight "cocircular square filtered chain complex" (filteredAlphaComplex filtration)+  pairs <- requireRight "cocircular square persistence" (mod2PersistentPairs filtered)+  let positiveDegreeOnePairs =+        pairs+          & filter ((== HomologicalDegree 1) . persistenceDegree)+          & mapMaybe positiveBirthAndDeath+  positiveDegreeOnePairs @?= [((1, 1), (2, 1))]++labelledPlanarPersistence :: Assertion+labelledPlanarPersistence = do+  edgeAB <- requireRight "labelled edge ab" (planarEdge 'a' 'b')+  edgeAC <- requireRight "labelled edge ac" (planarEdge 'a' 'c')+  edgeBC <- requireRight "labelled edge bc" (planarEdge 'b' 'c')+  faceABC <- requireRight "labelled face abc" (planarFace 'a' 'b' 'c')+  complexValue <-+    requireRight+      "labelled triangle complex"+      ( planarComplex+          ( Set.fromList+              [ planarVertex 'a'+              , planarVertex 'b'+              , planarVertex 'c'+              , edgeAB+              , edgeAC+              , edgeBC+              , faceABC+              ]+          )+      )+  filtered <-+    requireRight+      "labelled triangle filtration"+      ( filteredPlanarComplex+          complexValue+          ( Map.fromList+              [ (planarVertex 'a', 0 :: Int)+              , (planarVertex 'b', 0)+              , (planarVertex 'c', 0)+              , (edgeAB, 1)+              , (edgeAC, 1)+              , (edgeBC, 1)+              , (faceABC, 2)+              ]+          )+      )+  pairs <- requireRight "labelled triangle persistence" (mod2PersistentPairs filtered)+  let oneCycles =+        [ pair+        | pair <- pairs+        , persistenceDegree pair == HomologicalDegree 1+        ]+  fmap (\pair -> (persistenceBirth pair, persistenceDeath pair)) oneCycles+    @?= [(1, Just 2)]++degenerateSupportFiltrations :: Assertion+degenerateSupportFiltrations =+  traverse_+    assertSupport+    [ ("two sites", Vector.fromList [Point 0 0, Point 2 0], (2, 1, 0))+    , ("three collinear sites", Vector.fromList [Point 0 0, Point 1 0, Point 3 0], (3, 2, 0))+    ]+ where+  assertSupport (label, points, expectedCounts) = do+    triangulation <- requireDelaunay label points+    filtration <- requireRight (label <> " alpha filtration") (alphaFiltration triangulation)+    filtered <- requireRight (label <> " filtered chain complex") (filteredAlphaComplex filtration)+    let finite = filteredBaseComplex filtered+        counts =+          ( degreeCardinality finite (HomologicalDegree 0)+          , degreeCardinality finite (HomologicalDegree 1)+          , degreeCardinality finite (HomologicalDegree 2)+          )+    counts @?= expectedCounts++positiveBirthAndDeath+  :: PersistencePair AlphaBirth+  -> Maybe ((Integer, Integer), (Integer, Integer))+positiveBirthAndDeath pairValue =+  case persistenceDeath pairValue of+    Just deathBirth+      | persistenceBirth pairValue < deathBirth ->+          Just+            ( alphaBirthRatio (persistenceBirth pairValue)+            , alphaBirthRatio deathBirth+            )+    _ -> Nothing++alphaBirthRatio :: AlphaBirth -> (Integer, Integer)+alphaBirthRatio birth =+  (alphaBirthNumerator birth, alphaBirthDenominator birth)++edgeBetween+  :: DelaunayTriangulation ()+  -> Point+  -> Point+  -> Maybe UndirectedEdgeId+edgeBetween triangulation firstPoint secondPoint =+  List.find hasEndpoints (undirectedEdges triangulation)+ where+  hasEndpoints edgeValue =+    let (fromVertex, toVertex) = undirectedEndpoints triangulation edgeValue+        fromPoint = vertexPoint triangulation fromVertex+        toPoint = vertexPoint triangulation toVertex+     in (fromPoint == firstPoint && toPoint == secondPoint)+          || (fromPoint == secondPoint && toPoint == firstPoint)++requireDelaunay+  :: String+  -> Vector.Vector Point+  -> IO (DelaunayTriangulation ())+requireDelaunay label points =+  requireRight (label <> " Delaunay construction") (delaunayGeometry points)++requireRight :: Show failure => String -> Either failure value -> IO value+requireRight label result =+  case result of+    Left failureValue -> assertFailure (label <> " failed: " <> show failureValue)+    Right value -> pure value++requireSome :: String -> Maybe value -> IO value+requireSome label maybeValue =+  case maybeValue of+    Nothing -> assertFailure (label <> " was absent")+    Just value -> pure value++obtuseTrianglePoints :: Vector.Vector Point+obtuseTrianglePoints =+  Vector.fromList+    [ Point (-2) 0+    , Point 2 0+    , Point 0 1+    ]++squarePoints :: Vector.Vector Point+squarePoints =+  Vector.fromList+    [ Point (-1) (-1)+    , Point 1 (-1)+    , Point 1 1+    , Point (-1) 1+    ]++assertSelectedEdgeEndpoints :: DCELComplex -> Edge DCELComplex -> Assertion+assertSelectedEdgeEndpoints complexValue edgeValue = do+  let selectedVertices = vertices complexValue+      (sourceVertex, targetVertex) = edgeBoundary complexValue edgeValue+  assertBool "edge source is selected" (sourceVertex `elem` selectedVertices)+  assertBool "edge target is selected" (targetVertex `elem` selectedVertices)++assertSelectedFaceBoundary :: DCELComplex -> Face DCELComplex -> Assertion+assertSelectedFaceBoundary complexValue faceValue = do+  let selectedEdges = edges complexValue+      boundary = faceBoundary complexValue faceValue+  length boundary @?= 3+  assertBool+    "every oriented boundary edge is selected"+    (all ((`elem` selectedEdges) . orientedEdge) boundary)++withTriangleComplex :: (ExactCellSet -> DCELComplex -> Assertion) -> Assertion+withTriangleComplex assertion =+  case delaunayGeometry trianglePoints of+    Left buildFailure -> assertFailure ("triangle construction failed: " <> show buildFailure)+    Right triangulation ->+      case closeFaceCellSet triangulation (innerFaces triangulation) of+        Left selectionFailure -> assertFailure ("triangle selection failed: " <> show selectionFailure)+        Right cellSet -> assertion cellSet (fromExactCellSet cellSet)++trianglePoints :: Vector.Vector Point+trianglePoints =+  Vector.fromList+    [ Point 0 0,+      Point 2 0,+      Point 0 2+    ]
+ test/coherence/Main.hs view
@@ -0,0 +1,19 @@+-- | Compile every test slice against the union of their dependencies. Empty+-- imports make module and instance collisions observable without executing the+-- behavioral suites twice.+module Main (main) where++import Moonlight.Triangulation.AlgebraSpec ()+import Moonlight.Triangulation.ExactClipRetentionSpec ()+import Moonlight.Triangulation.LayerOperationsSpec ()+import Moonlight.Triangulation.MinkowskiSpec ()+import Moonlight.Triangulation.NativeSpec ()+import Moonlight.Triangulation.ParallelSpec ()+import Moonlight.Triangulation.PowerDiagramSpec ()+import Moonlight.Triangulation.RegionAlgebraSpec ()+import Moonlight.Triangulation.ScheduleAgreementSpec ()+import Moonlight.Triangulation.SerializationSpec ()+import Moonlight.Triangulation.ValuationSpec ()++main :: IO ()+main = pure ()
+ test/exact-planar/Main.hs view
@@ -0,0 +1,15 @@+module Main (main) where++import qualified Moonlight.Triangulation.ExactClipRetentionSpec as ExactClipRetentionSpec+import qualified Moonlight.Triangulation.LayerOperationsSpec as LayerOperationsSpec+import qualified Moonlight.Triangulation.MinkowskiSpec as MinkowskiSpec+import qualified Moonlight.Triangulation.PowerDiagramSpec as PowerDiagramSpec++main :: IO ()+main =+  sequence_+    [ ExactClipRetentionSpec.tests+    , MinkowskiSpec.tests+    , PowerDiagramSpec.tests+    , LayerOperationsSpec.tests+    ]
+ test/examples/Main.hs view
@@ -0,0 +1,56 @@+module Main (main) where++import Moonlight.Triangulation.Example.AlphaBoundary+import Moonlight.Triangulation.Example.ConstrainedRegion+import Moonlight.Triangulation.Example.PlanarRegion+import Moonlight.Triangulation.Example.SetAlgebra+import Moonlight.Triangulation.Handles.Dynamic ()+import Moonlight.Triangulation.Session ()+import Moonlight.Triangulation.Voronoi ()+import System.Exit (die)++main :: IO ()+main = do+  assertRight "set algebra" (6, 2) siteCounts+  assertRight "constrained region" (11, 8) constrainedRegionCounts+  assertRight "alpha boundary" [BoundaryShape 4 0] alphaBoundaryShapes+  assertRight+    "planar region"+    expectedPlanarSummary+    planarExample+  putStrLn "examples: ok"++expectedPlanarSummary :: PlanarExampleSummary+expectedPlanarSummary =+  PlanarExampleSummary+    { booleanValuations =+        [ CellValuationSummary 1 (ExactFractionSummary 20 1)+        , CellValuationSummary 1 (ExactFractionSummary 4 1)+        , CellValuationSummary 1 (ExactFractionSummary 12 1)+        ]+    , morphologyAreas =+        fmap+          (`ExactFractionSummary` 1)+          [48, 36, 4, 16, 16]+    }++assertRight+  :: (Eq value, Show value, Show obstruction)+  => String+  -> value+  -> Either obstruction value+  -> IO ()+assertRight label expected result =+  case result of+    Left obstruction ->+      die (label <> " failed with " <> show obstruction)+    Right actual+      | actual == expected -> pure ()+      | otherwise ->+          die+            ( label+                <> " expected "+                <> show expected+                <> ", got "+                <> show actual+            )
+ test/ffi/Main.hs view
@@ -0,0 +1,441 @@+module Main (main) where++import Control.Exception (bracket)+import Control.Monad (unless)+import Data.Int (Int64)+import Data.List (nub)+import Data.Maybe (mapMaybe)+import Data.Word (Word32)+import Foreign.C.String (peekCString)+import Foreign.C.Types (CDouble (..), CSize (..), CUInt)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Marshal.Array (allocaArray, peekArray, withArray)+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.Storable (Storable (sizeOf), peek)+import Moonlight.Triangulation.Foreign.Contract+import Moonlight.Triangulation.Foreign.Mesh+import Moonlight.Triangulation.Foreign.Morphology+import Moonlight.Triangulation.Foreign.Region++type MeshPointer = Ptr CMesh+type RegionPointer = Ptr CRegion+type Point = (Double, Double)+type Loop = [Point]+data ComponentInput = ComponentInput !Loop ![Loop]++data RegionMeasurement = RegionMeasurement+  { measuredEuler :: !Int64+  , measuredArea :: !String+  , measuredPerimeterLower :: !Double+  , measuredPerimeterUpper :: !Double+  }++main :: IO ()+main = do+  testStableWireContract+  unless (sizeOf obstructionLayoutWitness == 320) $+    fail "C obstruction layout changed"+  unless (sizeOf receiptLayoutWitness == 72) $+    fail "C Minkowski receipt layout changed"+  bracket (buildMesh [(0, 0), (2, 0), (0, 2), (2, 2)]) meshFree $ \left ->+    bracket (buildMesh [(2, 0), (4, 0), (2, 2), (4, 2)]) meshFree $ \right -> do+      requireMeshCount "left vertex count" meshVertexCount left 4+      requireMeshCount "left triangle count" meshTriangleCount left 2+      testDenseCopies left+      testImmutableBatch left+      testBatchAdmission left+      testSiteSetAlgebra left right+  testExactRegionSurface+  testTypedCoordinateRefusal+  testCoordinateCountOverflow+  testNullPointerRefusal+  testRegionLayoutRefusal+  putStrLn "ffi: ok"++testStableWireContract :: IO ()+testStableWireContract = do+  unless+    ( allDistinct (fmap abiStatusId allAbiStatuses)+        && allDistinct (fmap obstructionCodeId allObstructionCodes)+        && allDistinct (fmap coordinateErrorCodeId allCoordinateErrorCodes)+        && allDistinct (fmap regionLocationCodeId allRegionLocationCodes)+        && allDistinct (fmap minkowskiOperationCodeId allMinkowskiOperationCodes)+        && allDistinct wireSymbols+        && allDistinct (fmap abiFunctionSymbol allAbiFunctions)+        && allDistinct (mapMaybe haskellImplementationName allAbiFunctions)+        && allDistinct (fmap abiHandleSymbol allAbiHandles <> fmap abiStructSymbol allAbiStructs)+    )+    (fail "FFI contract contains duplicate identifiers")+  unless+    ( abiVersion == 2+        && fmap abiStatusId allAbiStatuses == [0, 1, 2, 3, 4, 5]+        && obstructionCodeId ObstructionInvalidCoordinate == 1+        && obstructionCodeId ObstructionNullPointer == 100+        && obstructionCodeId ObstructionCountOverflow == 101+        && obstructionCodeId ObstructionBufferTooSmall == 102+        && obstructionCodeId ObstructionRegionLayoutInvalid == 200+        && fmap regionLocationCodeId allRegionLocationCodes == [0, 1, 2]+        && fmap minkowskiOperationCodeId allMinkowskiOperationCodes == [0, 1, 2, 3]+    )+    (fail "stable FFI wire identifiers changed")+ where+  wireSymbols =+    fmap abiStatusSymbol allAbiStatuses+      <> fmap obstructionCodeSymbol allObstructionCodes+      <> fmap coordinateErrorCodeSymbol allCoordinateErrorCodes+      <> fmap regionLocationCodeSymbol allRegionLocationCodes+      <> fmap minkowskiOperationCodeSymbol allMinkowskiOperationCodes+  haskellImplementationName function =+    case abiFunctionImplementation function of+      AbiFunctionRuntime -> Nothing+      AbiFunctionHaskell _ name -> Just name++allDistinct :: Eq value => [value] -> Bool+allDistinct values = length values == length (nub values)++obstructionLayoutWitness :: CObstruction+obstructionLayoutWitness = CObstruction 0 0 0 0 0 0 0 0 0 ""++receiptLayoutWitness :: CMinkowskiReceipt+receiptLayoutWitness = CMinkowskiReceipt 0 0 0 0 0 0 0 0 0++buildMesh :: [Point] -> IO MeshPointer+buildMesh points =+  withPointArray points $ \coordinates ->+    produceHandle "delaunay" (delaunayF64 coordinates (fromIntegral (length points)))++testDenseCopies :: MeshPointer -> IO ()+testDenseCopies mesh = do+  alloca $ \written ->+    alloca $ \obstruction -> do+      status <- meshCopyVerticesF64 mesh nullPtr 0 written obstruction+      requireStatus "undersized vertex copy" AbiStatusBufferTooSmall status obstruction+      required <- peek written+      refusal <- peek obstruction+      unless (required == 4 && obstructionCode refusal == obstructionCodeId ObstructionBufferTooSmall) $+        fail "undersized vertex copy lost its required-capacity witness"+  allocaArray 8 $ \coordinates ->+    alloca $ \written ->+      alloca $ \obstruction -> do+        status <- meshCopyVerticesF64 mesh coordinates 4 written obstruction+        requireStatus "vertex copy" AbiStatusOk status obstruction+        values <- peekArray 8 coordinates+        unless (length values == 8) (fail "vertex copy wrote the wrong coordinate extent")+  allocaArray 6 $ \triangles ->+    alloca $ \written ->+      alloca $ \obstruction -> do+        status <- meshCopyTrianglesU32 mesh triangles 2 written obstruction+        requireStatus "triangle copy" AbiStatusOk status obstruction+        indices <- peekArray 6 triangles :: IO [Word32]+        unless (all (< 4) indices) (fail "triangle copy produced an out-of-range vertex")++testImmutableBatch :: MeshPointer -> IO ()+testImmutableBatch original =+  withPointArray [(1, 1), (3, 1)] $ \coordinates ->+    bracket+      (produceHandle "batch insert" (meshInsertManyF64 original coordinates 2))+      meshFree+      (\revised -> do+        requireMeshCount "original after batch" meshVertexCount original 4+        requireMeshCount "revised after batch" meshVertexCount revised 6)++testBatchAdmission :: MeshPointer -> IO ()+testBatchAdmission original = do+  testLateInvalidPoint+  testCanonicalZeros+ where+  testLateInvalidPoint =+    withPointArray [(1, 1), (3, 1), (0 / 0, 1)] $ \coordinates ->+      alloca $ \output ->+        alloca $ \obstruction -> do+          status <- meshInsertManyF64 original coordinates 3 output obstruction+          requireStatus "late invalid batch point" AbiStatusGeometryObstruction status obstruction+          refusal <- peek obstruction+          unless+            ( obstructionCode refusal == obstructionCodeId ObstructionInvalidCoordinate+                && obstructionCoordinateError refusal == coordinateErrorCodeId CoordinateErrorNaN+                && obstructionInputIndex refusal == 2+            )+            (fail "late invalid batch point lost its raw input-index obstruction")+          requireMeshCount "original after refused batch" meshVertexCount original 4+  testCanonicalZeros =+    let negativeZero = -0.0 :: Double+     in withPointArray [(negativeZero, 1), (1, negativeZero)] $ \coordinates ->+          bracket+            (produceHandle "canonical-zero batch" (meshInsertManyF64 original coordinates 2))+            meshFree+            (\revised -> do+               requireMeshCount "canonical-zero batch vertex count" meshVertexCount revised 6+               allocaArray 12 $ \copiedCoordinates ->+                 alloca $ \_written ->+                   alloca $ \obstruction -> do+                     status <- meshCopyVerticesF64 revised copiedCoordinates 6 _written obstruction+                     requireStatus "canonical-zero batch copy" AbiStatusOk status obstruction+                     copied <- map unCDouble <$> peekArray 12 copiedCoordinates+                     unless (not (any isNegativeZero copied)) $+                       fail "canonical-zero batch published a negative zero")+  unCDouble (CDouble value) = value++testSiteSetAlgebra :: MeshPointer -> MeshPointer -> IO ()+testSiteSetAlgebra left right = do+  test "site union" meshSiteUnion 6+  test "site intersection" meshSiteIntersection 2+  test "site difference" meshSiteDifference 2+  test "site symmetric difference" meshSiteSymmetricDifference 4+ where+  test label operation expected =+    bracket (produceHandle label (operation left right)) meshFree $ \result ->+      requireMeshCount label meshVertexCount result expected++testExactRegionSurface :: IO ()+testExactRegionSurface =+  bracket (buildRegion [ComponentInput leftSquare []]) regionFree $ \left ->+    bracket (buildRegion [ComponentInput rightSquare []]) regionFree $ \right -> do+      testRegionProjection left+      testRegionBooleans left right+      testRegionPointLocation left+      testRegionMorphology left right+ where+  leftSquare = [(0, 0), (2, 0), (2, 2), (0, 2)]+  rightSquare = [(1, 0), (3, 0), (3, 2), (1, 2)]++testRegionProjection :: RegionPointer -> IO ()+testRegionProjection region =+  alloca $ \componentCountOutput ->+    alloca $ \loopCountOutput ->+      alloca $ \pointCountOutput ->+        alloca $ \obstruction -> do+          status <- regionCounts region componentCountOutput loopCountOutput pointCountOutput obstruction+          requireStatus "region counts" AbiStatusOk status obstruction+          componentCount <- fromIntegral <$> peek componentCountOutput+          loopCount <- fromIntegral <$> peek loopCountOutput+          pointCount <- fromIntegral <$> peek pointCountOutput+          unless ((componentCount, loopCount, pointCount) == (1, 1, 4)) $+            fail "region counts lost component/loop/point structure"+          allocaArray (pointCount * 2) $ \coordinates ->+            allocaArray (loopCount + 1) $ \loopOffsets ->+              allocaArray (componentCount + 1) $ \componentOffsets -> do+                copyStatus <-+                  regionCopyF64+                    region+                    coordinates+                    (fromIntegral pointCount)+                    loopOffsets+                    (fromIntegral (loopCount + 1))+                    componentOffsets+                    (fromIntegral (componentCount + 1))+                    obstruction+                requireStatus "region copy" AbiStatusOk copyStatus obstruction+                copiedLoopOffsets <- peekArray (loopCount + 1) loopOffsets+                copiedComponentOffsets <- peekArray (componentCount + 1) componentOffsets+                unless (copiedLoopOffsets == [0, 4] && copiedComponentOffsets == [0, 1]) $+                  fail "region copy changed the bulk offset topology"++testRegionBooleans :: RegionPointer -> RegionPointer -> IO ()+testRegionBooleans left right = do+  test "region union" regionUnion 1 "6/1" 10+  test "region intersection" regionIntersection 1 "2/1" 6+  test "region difference" regionDifference 1 "2/1" 6+  test "region symmetric difference" regionSymmetricDifference 2 "4/1" 12+ where+  test label operation expectedEuler expectedArea expectedPerimeter =+    bracket (produceHandle label (operation left right)) regionFree $ \result -> do+      measurement <- measureRegion result+      unless (measuredEuler measurement == expectedEuler && measuredArea measurement == expectedArea) $+        fail (label <> " returned the wrong exact valuation")+      requireCertifiedContainment+        label+        expectedPerimeter+        (measuredPerimeterLower measurement)+        (measuredPerimeterUpper measurement)++testRegionPointLocation :: RegionPointer -> IO ()+testRegionPointLocation region = do+  requireRegionLocation "interior location" region (1, 1) RegionLocationInterior+  requireRegionLocation "boundary location" region (0, 1) RegionLocationBoundary+  requireRegionLocation "exterior location" region (3, 1) RegionLocationExterior++testRegionMorphology :: RegionPointer -> RegionPointer -> IO ()+testRegionMorphology left right =+  withPointArray [(-0.5, -0.5), (0.5, -0.5), (0.5, 0.5), (-0.5, 0.5)] $ \coordinates ->+    bracket+      (produceHandle "structuring element" (structuringElementCreateF64 coordinates 4))+      structuringElementFree+      (\element -> do+        test "Minkowski sum" regionMinkowskiSum left right MinkowskiOperationAddition "16/1"+        test "offset" regionOffset element left MinkowskiOperationAddition "9/1"+        test "inset" regionInset element left MinkowskiOperationErosion "1/1"+        test "open" regionOpen element left MinkowskiOperationOpening "4/1"+        test "close" regionClose element left MinkowskiOperationClosing "4/1")+ where+  test+    :: String+    -> (first -> RegionPointer -> Ptr RegionPointer -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt)+    -> first+    -> RegionPointer+    -> MinkowskiOperationCode+    -> String+    -> IO ()+  test label operation firstInput secondInput expectedOperation expectedArea =+    bracket+      (produceRegionWithReceipt label (operation firstInput secondInput))+      (regionFree . fst)+      (\(result, receipt) -> do+        measurement <- measureRegion result+        unless (receiptOperation receipt == minkowskiOperationCodeId expectedOperation && measuredArea measurement == expectedArea) $+          fail (label <> " lost its result or morphology receipt"))++measureRegion :: RegionPointer -> IO RegionMeasurement+measureRegion region =+  alloca $ \eulerOutput ->+    allocaArray 64 $ \areaOutput ->+      alloca $ \areaBytesWritten ->+        alloca $ \perimeterLowerOutput ->+          alloca $ \perimeterUpperOutput ->+            alloca $ \obstruction -> do+              status <-+                regionMeasure+                  region+                  eulerOutput+                  areaOutput+                  64+                  areaBytesWritten+                  perimeterLowerOutput+                  perimeterUpperOutput+                  obstruction+              requireStatus "region measure" AbiStatusOk status obstruction+              measuredEuler <- peek eulerOutput+              measuredArea <- peekCString areaOutput+              CDouble measuredPerimeterLower <- peek perimeterLowerOutput+              CDouble measuredPerimeterUpper <- peek perimeterUpperOutput+              pure (RegionMeasurement measuredEuler measuredArea measuredPerimeterLower measuredPerimeterUpper)++requireCertifiedContainment :: String -> Double -> Double -> Double -> IO ()+requireCertifiedContainment label expected lower upper =+  unless (lower <= expected && expected <= upper) $+    fail (label <> " perimeter certificate excludes the exact perimeter")++requireRegionLocation :: String -> RegionPointer -> Point -> RegionLocationCode -> IO ()+requireRegionLocation label region (x, y) expected =+  alloca $ \output ->+    alloca $ \obstruction -> do+      status <- regionLocatePointF64 region (CDouble x) (CDouble y) output obstruction+      requireStatus label AbiStatusOk status obstruction+      observed <- peek output+      unless (observed == fromIntegral (regionLocationCodeId expected)) $+        fail (label <> " returned location " <> show observed)++buildRegion :: [ComponentInput] -> IO RegionPointer+buildRegion components =+  let loopsByComponent = map (\(ComponentInput outer holes) -> outer : holes) components+      loops = concat loopsByComponent+      points = concat loops+      loopPointCounts = map length loops+      componentLoopCounts = map length loopsByComponent+   in withPointArray points $ \coordinates ->+        withArray (map fromIntegral loopPointCounts) $ \loopCounts ->+          withArray (map fromIntegral componentLoopCounts) $ \componentCounts ->+            produceHandle+              "region create"+              ( regionCreateF64+                  coordinates+                  (fromIntegral (length points))+                  loopCounts+                  (fromIntegral (length loops))+                  componentCounts+                  (fromIntegral (length components))+              )++testRegionLayoutRefusal :: IO ()+testRegionLayoutRefusal =+  withPointArray [(0, 0), (1, 0), (1, 1), (0, 1)] $ \coordinates ->+    withArray [5] $ \loopCounts ->+      withArray [1] $ \componentCounts ->+        alloca $ \output ->+          alloca $ \obstruction -> do+            status <- regionCreateF64 coordinates 4 loopCounts 1 componentCounts 1 output obstruction+            requireStatus "invalid region layout" AbiStatusGeometryObstruction status obstruction+            refusal <- peek obstruction+            unless (obstructionCode refusal == obstructionCodeId ObstructionRegionLayoutInvalid) $+              fail "invalid region layout lost its typed obstruction"++testTypedCoordinateRefusal :: IO ()+testTypedCoordinateRefusal =+  withPointArray [(0, 0), (0 / 0, 1), (1, 0)] $ \coordinates ->+    alloca $ \output ->+      alloca $ \obstruction -> do+        status <- delaunayF64 coordinates 3 output obstruction+        requireStatus "invalid coordinate" AbiStatusGeometryObstruction status obstruction+        refusal <- peek obstruction+        unless+          ( obstructionCode refusal == obstructionCodeId ObstructionInvalidCoordinate+              && obstructionCoordinateError refusal == coordinateErrorCodeId CoordinateErrorNaN+              && obstructionInputIndex refusal == 1+          ) $+          fail "invalid coordinate lost its typed witness"++testNullPointerRefusal :: IO ()+testNullPointerRefusal =+  alloca $ \count ->+    alloca $ \obstruction -> do+      status <- meshVertexCount nullPtr count obstruction+      requireStatus "null mesh" AbiStatusNullPointer status obstruction+      refusal <- peek obstruction+      unless (obstructionCode refusal == obstructionCodeId ObstructionNullPointer) $+        fail "null pointer refusal lost its typed witness"++testCoordinateCountOverflow :: IO ()+testCoordinateCountOverflow =+  alloca $ \output ->+    alloca $ \obstruction -> do+      let overflowingCount = fromIntegral (maxBound `div` 2 + 1 :: Int)+      status <- delaunayF64 nullPtr overflowingCount output obstruction+      requireStatus "coordinate count overflow" AbiStatusCountOverflow status obstruction+      refusal <- peek obstruction+      unless (obstructionCode refusal == obstructionCodeId ObstructionCountOverflow) $+        fail "coordinate count overflow lost its typed witness"++requireMeshCount :: String -> (MeshPointer -> Ptr CSize -> Ptr CObstruction -> IO CUInt) -> MeshPointer -> Int -> IO ()+requireMeshCount label operation mesh expected =+  alloca $ \count ->+    alloca $ \obstruction -> do+      status <- operation mesh count obstruction+      requireStatus label AbiStatusOk status obstruction+      observed <- peek count+      unless (observed == fromIntegral expected) $+        fail (label <> " produced " <> show observed <> ", expected " <> show expected)++produceHandle :: String -> (Ptr (Ptr carrier) -> Ptr CObstruction -> IO CUInt) -> IO (Ptr carrier)+produceHandle label operation =+  alloca $ \output ->+    alloca $ \obstruction -> do+      status <- operation output obstruction+      requireStatus label AbiStatusOk status obstruction+      handle <- peek output+      unless (handle /= nullPtr) (fail (label <> " returned a null handle"))+      pure handle++produceRegionWithReceipt+  :: String+  -> (Ptr RegionPointer -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt)+  -> IO (RegionPointer, CMinkowskiReceipt)+produceRegionWithReceipt label operation =+  alloca $ \output ->+    alloca $ \receiptOutput ->+      alloca $ \obstruction -> do+        status <- operation output receiptOutput obstruction+        requireStatus label AbiStatusOk status obstruction+        handle <- peek output+        receipt <- peek receiptOutput+        unless (handle /= nullPtr) (fail (label <> " returned a null region"))+        pure (handle, receipt)++requireStatus :: String -> AbiStatus -> CUInt -> Ptr CObstruction -> IO ()+requireStatus label expected observed obstruction+  | observed == fromIntegral (abiStatusId expected) = pure ()+  | otherwise = do+      refusal <- peek obstruction+      fail (label <> " returned status " <> show observed <> ": " <> obstructionMessage refusal)++withPointArray :: [Point] -> (Ptr CDouble -> IO result) -> IO result+withPointArray points = withArray (concatMap (\(x, y) -> [CDouble x, CDouble y]) points)
+ test/hex/Main.hs view
@@ -0,0 +1,229 @@+module Main (main) where++import Data.ByteString.Lazy qualified as BL+import Data.Foldable (traverse_)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Vector qualified as Vector+import Moonlight.Hex.Coordinate+import Moonlight.Hex.Element+import Moonlight.Hex.Planar+import Moonlight.Hex.Region+import Moonlight.Hex.Serialization+import Moonlight.Triangulation.Region+  ( exactLoopPoints+  , planarRegionComponents+  , polygonHoleLoops+  , polygonOuterLoop+  )+main :: IO ()+main = do+  coordinateAndElementLaws+  packedRegionLaws+  restrictionLaws+  gluingLaws+  planarLaws+  serializationLaws+  wordBoundaryLaws+  putStrLn "hex-laws: coordinate element boolean restriction gluing planar serialization word-boundary=passed"++type Assertion = IO ()++coordinateAndElementLaws :: Assertion+coordinateAndElementLaws = do+  layout <- requireRight (hexLayout (HexCoord (-2) (-2)) 5 5)+  let coordinates = Vector.toList (layoutCoords layout)+  traverse_+    (\coordinate ->+        traverse_+          (\direction ->+              case hexNeighbourCoord layout coordinate direction of+                Nothing -> pure ()+                Just neighbour -> do+                  assertEqual+                    "opposite direction returns to the source"+                    (Just coordinate)+                    (hexNeighbourCoord layout neighbour (oppositeHexDirection direction))+                  assertEqual+                    "adjacent cells share one canonical side"+                    (hexCellSide coordinate direction)+                    (hexCellSide neighbour (oppositeHexDirection direction))+          )+          allHexDirections+    )+    coordinates+  assertEqual "east overflow is typed absence" Nothing (hexStepCoord (HexCoord maxBound 0) HexEast)++packedRegionLaws :: Assertion+packedRegionLaws = do+  layout <- requireRight (hexLayout (HexCoord 0 0) 2 2)+  let universe = Set.fromList (Vector.toList (layoutCoords layout))+      subsets = powerset universe+  regions <- traverse (regionFromSet layout) subsets+  traverse_+    (\(leftSet, left) -> do+        assertRegion "idempotent union" leftSet =<< requireRight (hexRegionUnion left left)+        assertRegion "empty union identity" leftSet =<< requireRight (hexRegionUnion left (emptyHexRegion layout))+        assertRegion "full intersection identity" leftSet =<< requireRight (hexRegionIntersection left (fullHexRegion layout))+        assertRegion "relative complement" (universe Set.\\ leftSet) (complementHexRegion left)+        traverse_+          (\(rightSet, right) -> do+              assertRegion "union" (Set.union leftSet rightSet) =<< requireRight (hexRegionUnion left right)+              assertRegion "intersection" (Set.intersection leftSet rightSet) =<< requireRight (hexRegionIntersection left right)+              assertRegion "difference" (Set.difference leftSet rightSet) =<< requireRight (hexRegionDifference left right)+              assertRegion+                "symmetric difference"+                ((leftSet Set.\\ rightSet) `Set.union` (rightSet Set.\\ leftSet))+                =<< requireRight (hexRegionSymmetricDifference left right)+              assertEqual+                "subset"+                (Right (leftSet `Set.isSubsetOf` rightSet))+                (hexRegionSubsetOf left right)+          )+          regions+    )+    regions+  traverse_+    (\(_, left) ->+        traverse_+          (\(_, right) ->+              traverse_+                (\(_, third) -> do+                    leftAssociated <- requireRight (hexRegionUnion left right) >>= requireRight . (`hexRegionUnion` third)+                    rightAssociated <- requireRight (hexRegionUnion right third) >>= requireRight . hexRegionUnion left+                    assertEqual "union associativity" leftAssociated rightAssociated+                )+                regions+          )+          regions+    )+    regions++restrictionLaws :: Assertion+restrictionLaws = do+  outer <- requireRight (hexLayout (HexCoord (-2) (-2)) 6 5)+  inner <- requireRight (hexLayout (HexCoord 0 (-1)) 3 2)+  source <- requireRight (hexRegionFromCoords outer [HexCoord (-2) (-2), HexCoord 0 (-1), HexCoord 2 0, HexCoord 3 2])+  restricted <- requireRight (restrictHexRegion inner source)+  assertRegion "restriction" (Set.fromList [HexCoord 0 (-1), HexCoord 2 0]) restricted+  assertEqual "reframing back preserves the restricted section" restricted (reframeHexRegion inner (reframeHexRegion outer restricted))+  left <- requireRight (hexRegionFromCoords outer [HexCoord 0 (-1), HexCoord 1 0])+  right <- requireRight (hexRegionFromCoords outer [HexCoord 2 0, HexCoord 0 (-1)])+  unionBefore <- requireRight (hexRegionUnion left right) >>= requireRight . restrictHexRegion inner+  leftRestricted <- requireRight (restrictHexRegion inner left)+  rightRestricted <- requireRight (restrictHexRegion inner right)+  unionAfter <- requireRight (hexRegionUnion leftRestricted rightRestricted)+  assertEqual "restriction commutes with union" unionBefore unionAfter++gluingLaws :: Assertion+gluingLaws = do+  leftLayout <- requireRight (hexLayout (HexCoord 0 0) 2 2)+  rightLayout <- requireRight (hexLayout (HexCoord 1 0) 2 2)+  left <- requireRight (hexRegionFromCoords leftLayout [HexCoord 0 0, HexCoord 1 0])+  right <- requireRight (hexRegionFromCoords rightLayout [HexCoord 1 0, HexCoord 2 1])+  glued <- requireRight (glueCompatibleHexRegions (left NonEmpty.:| [right]))+  assertRegion "glued section" (Set.fromList [HexCoord 0 0, HexCoord 1 0, HexCoord 2 1]) glued+  thirdLayout <- requireRight (hexLayout (HexCoord 2 0) 2 2)+  third <- requireRight (hexRegionFromCoords thirdLayout [HexCoord 2 1, HexCoord 3 0])+  gluedThree <- requireRight (glueCompatibleHexRegions (left NonEmpty.:| [right, third]))+  assertRegion+    "three-section gluing"+    (Set.fromList [HexCoord 0 0, HexCoord 1 0, HexCoord 2 1, HexCoord 3 0])+    gluedThree+  disagreeing <- requireRight (hexRegionFromCoords rightLayout [HexCoord 2 1])+  assertEqual+    "overlap disagreement names its coordinate"+    (Left (HexOverlapDisagreement (HexCoord 1 0)))+    (glueCompatibleHexRegions (left NonEmpty.:| [disagreeing]))++planarLaws :: Assertion+planarLaws = do+  cellLoop <- requireRight (hexCellExactLoop (HexCoord 0 0))+  assertEqual "one cell has six exact vertices" 6 (NonEmpty.length (exactLoopPoints cellLoop))+  layout <- requireRight (hexLayout (HexCoord 0 0) 2 1)+  adjacent <- requireRight (hexRegionFromCoords layout [HexCoord 0 0, HexCoord 1 0])+  adjacentRegion <- requireRight (hexRegionPlanarRegion adjacent)+  case planarRegionComponents adjacentRegion of+    [component] -> do+      assertEqual "shared side is absent from the outer boundary" 10 (NonEmpty.length (exactLoopPoints (polygonOuterLoop component)))+      assertEqual "adjacent cells introduce no hole" [] (polygonHoleLoops component)+    components -> fail ("expected one adjacent-cell component, observed " <> show (length components))++  ringLayout <- requireRight (hexLayout (HexCoord (-1) (-1)) 3 3)+  let ringCoordinates =+        [ coordinate+        | direction <- NonEmpty.toList allHexDirections+        , Just coordinate <- [hexStepCoord (HexCoord 0 0) direction]+        ]+  ring <- requireRight (hexRegionFromCoords ringLayout ringCoordinates)+  ringRegion <- requireRight (hexRegionPlanarRegion ring)+  case planarRegionComponents ringRegion of+    [component] -> assertEqual "six-cell ring retains its hole" 1 (length (polygonHoleLoops component))+    components -> fail ("expected one ring component, observed " <> show (length components))++  nestedLayout <- requireRight (hexLayout (HexCoord (-4) (-4)) 9 9)+  let onRing :: Int -> HexCoord -> Bool+      onRing radius (HexCoord q r) =+        abs q <= radius+          && abs r <= radius+          && (abs q == radius || abs r == radius)+      nestedRings = hexRegionGenerate nestedLayout (\coordinate -> onRing 4 coordinate || onRing 2 coordinate)+  nestedRegion <- requireRight (hexRegionPlanarRegion nestedRings)+  assertEqual "nested rings retain two components" 2 (length (planarRegionComponents nestedRegion))+  assertEqual+    "each nested component owns its nearest hole"+    2+    (sum (fmap (length . polygonHoleLoops) (planarRegionComponents nestedRegion)))++serializationLaws :: Assertion+serializationLaws = do+  layout <- requireRight (hexLayout (HexCoord (-3) 4) 13 7)+  let source = hexRegionGenerate layout (\(HexCoord q r) -> (q + 2 * r) `mod` 5 == 0)+      bytes = encodeHexRegion source+      budget = HexDecodingBudget 4096 1024+  assertEqual "round trip" (Right source) (decodeHexRegion budget bytes)+  assertEqual+    "input byte budget is checked before parsing"+    (Left (HexInputByteBudgetExceeded (fromIntegral (BL.length bytes)) 1))+    (decodeHexRegion (HexDecodingBudget 1 1024) bytes)+  assertBool "wire representation is packed" (BL.length bytes < fromIntegral (hexLayoutCellCount layout))++wordBoundaryLaws :: Assertion+wordBoundaryLaws =+  traverse_+    (\cellCount -> do+        layout <- requireRight (hexLayout (HexCoord 0 0) cellCount 1)+        let region = hexRegionGenerate layout (\(HexCoord q _) -> even q)+            expected = Set.fromList [HexCoord q 0 | q <- [0 .. cellCount - 1], even q]+        assertRegion ("word boundary " <> show cellCount) expected region+        assertRegion ("double complement " <> show cellCount) expected (complementHexRegion (complementHexRegion region))+    )+    [63, 64, 65, 127, 128]++layoutCoords :: HexLayout -> Vector.Vector HexCoord+layoutCoords layout =+  Vector.mapMaybe (hexLayoutCoordAt layout) (Vector.enumFromN 0 (hexLayoutCellCount layout))++regionFromSet :: HexLayout -> Set HexCoord -> IO (Set HexCoord, HexRegion)+regionFromSet layout coordinates =+  fmap ((,) coordinates) (requireRight (hexRegionFromCoords layout coordinates))++assertRegion :: String -> Set HexCoord -> HexRegion -> Assertion+assertRegion label expected actual =+  assertEqual label expected (Set.fromList (Vector.toList (hexRegionCoords actual)))++powerset :: Ord value => Set value -> [Set value]+powerset = foldr (\value rest -> rest <> fmap (Set.insert value) rest) [Set.empty] . Set.toAscList++requireRight :: Show obstruction => Either obstruction value -> IO value+requireRight = either (fail . show) pure++assertEqual :: (Eq value, Show value) => String -> value -> value -> Assertion+assertEqual label expected actual =+  if expected == actual+    then pure ()+    else fail (label <> ": expected " <> show expected <> ", observed " <> show actual)++assertBool :: String -> Bool -> Assertion+assertBool label condition = if condition then pure () else fail label
+ test/native/Main.hs view
@@ -0,0 +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+    >> ExactEmbeddingSpec.tests+    >> OverlaySpec.tests+    >> RegionSpec.tests
+ test/native/Moonlight/Triangulation/ExactEmbeddingSpec.hs view
@@ -0,0 +1,659 @@+{-# 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 qualified Data.List as List+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.Embedding+  ( DraftIncidence (..)+  , DraftId (..)+  , DraftNeighborhood (..)+  , DraftSegmentId+  , DraftVertexId+  , EmbeddingObligation (..)+  , ExactArrangementDraft (..)+  , certificateIncidenceRelationPreservationCount+  , certificateNeighborhoodRotationPreservationCount+  , certificateResidual+  , certificateRoundedVertexDistinctnessCount+  , certificateRoundedVertices+  , certificateSplitOrderPreservationCount+  , OverlayEmbeddingObstruction (..)+  , certifyLocalEmbedding+  , residualUndischargedObligations+  )+import Moonlight.Triangulation.Internal.Predicates (segmentRelation)+import Moonlight.Triangulation.Math+  ( SegmentRelation (..)+  , allSegmentRelations+  )+import Moonlight.Triangulation.Types+  ( CoordinateError (..)+  , Point (..)+  , PointValidationError (..)+  , queryPointValue+  )+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+    , testCollinearNeighborhoodRotation+    , 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+                [ (DraftId 0, firstCrossing)+                , (DraftId 1, secondCrossing)+                , (DraftId 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, innerSegmentId :: DraftSegmentId+      outerSegmentId = DraftId 0+      innerSegmentId = DraftId 1+      draft =+        emptyDraft+          { draftVertices =+              Map.fromList+                [ (DraftId 0, outerFrom)+                , (DraftId 1, outerTo)+                , (DraftId 2, innerFrom)+                , (DraftId 3, innerTo)+                ]+          , draftSegments =+              Map.fromList+                [ (outerSegmentId, (DraftId 0, DraftId 1))+                , (innerSegmentId, (DraftId 2, DraftId 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 (DraftId 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 (queryPointValue 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, center, east, south, north :: DraftVertexId+      west = DraftId 0+      center = DraftId 1+      east = DraftId 2+      south = DraftId 3+      north = DraftId 4+      westCenter, centerEast, southCenter, centerNorth :: DraftSegmentId+      westCenter = DraftId 0+      centerEast = DraftId 1+      southCenter = DraftId 2+      centerNorth = DraftId 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+                [ ( DraftId 0+                  , [ (0, west)+                    , (half, center)+                    , (1, east)+                    ]+                  )+                , ( DraftId 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)+  westEmbedding <-+    maybe+      (fail "ordinary local embedding omitted its admitted west candidate")+      pure+      (Map.lookup west (certificateRoundedVertices certificate))+  assertEqual+    "ordinary certificate retains admitted projection"+    (Point (-1) 0)+    (queryPointValue westEmbedding)+  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+    (certificateNeighborhoodRotationPreservationCount certificate)+  assertEqual+    "ordinary residual"+    (GlobalNoNewCrossing :| [])+    (residualUndischargedObligations (certificateResidual certificate))+  putStrLn+    ( "local embedding certificate counts: "+        <> show+          ( certificateRoundedVertexDistinctnessCount certificate+          , certificateSplitOrderPreservationCount certificate+          , certificateIncidenceRelationPreservationCount certificate+          , certificateNeighborhoodRotationPreservationCount certificate+          )+    )+  putStrLn+    ( "local embedding declared residual: "+        <> show (residualUndischargedObligations (certificateResidual certificate))+    )++-- Independent binary64 projection bends the exact straight-through pair at+-- the center, but the cyclic neighbor order is unchanged. The local topology+-- obligation is rotation preservation, not literal preservation of a zero+-- determinant.+testCollinearNeighborhoodRotation :: IO ()+testCollinearNeighborhoodRotation = do+  oneThird <- requireRight "collinear rotation coordinate" (exactRational 1 3)+  let center, right, branch, left :: DraftVertexId+      center = DraftId 0+      right = DraftId 1+      branch = DraftId 2+      left = DraftId 3+      centerRight, centerBranch, centerLeft :: DraftSegmentId+      centerRight = DraftId 0+      centerBranch = DraftId 1+      centerLeft = DraftId 2+      draft =+        emptyDraft+          { draftVertices =+              Map.fromList+                [ (center, exactPoint 1 oneThird)+                , (right, integerPoint 3 1)+                , (branch, integerPoint 1 2)+                , (left, integerPoint 0 0)+                ]+          , draftSegments =+              Map.fromList+                [ (centerRight, (center, right))+                , (centerBranch, (center, branch))+                , (centerLeft, (center, left))+                ]+          , draftIncidences =+              [ DraftIncidence centerRight centerBranch SegmentsShareEndpoint+              , DraftIncidence centerBranch centerLeft SegmentsShareEndpoint+              , DraftIncidence centerLeft centerRight SegmentsShareEndpoint+              ]+          , draftNeighborhoods =+              [DraftNeighborhood center (right :| [branch, left])]+          }+  certificate <-+    requireRight+      "collinear neighborhood retains its cyclic rotation"+      (certifyLocalEmbedding draft)+  assertEqual+    "collinear neighborhood rotation obligations"+    3+    (certificateNeighborhoodRotationPreservationCount 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+          ( List.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+                [ (DraftId 0, integerPoint 0 0)+                , (DraftId 1, integerPoint 1 0)+                ]+          }+      collisionDraft =+        emptyDraft+          { draftVertices =+              Map.fromList+                [ (DraftId 0, exactPoint firstCollision 0)+                , (DraftId 1, exactPoint secondCollision 0)+                ]+          }+      projectionDraft =+        emptyDraft+          { draftVertices =+              Map.singleton+                (DraftId 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 = List.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/FilteredPredicateOptimizationSpec.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE NumericUnderscores #-}+{-# OPTIONS_GHC -O1 #-}++-- | The allocation law for the optimized filtered-predicate artifact. This+-- module remains at O1 when the surrounding behavioral body is compiled at O0;+-- without the simplifier, the loop does not unbox and the witness is vacuous.+module Moonlight.Triangulation.FilteredPredicateOptimizationSpec+  ( assertFilteredPredicatesSkipExactOracle+  ) where++import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Monad (unless)+import GHC.Stats (allocated_bytes, getRTSStats, getRTSStatsEnabled)+import Moonlight.Triangulation.Math+  ( inCircle+  , inCircleDetApprox+  , orient2d+  , orientDetApprox+  )+import Moonlight.Triangulation.Internal.Types (QueryPoint (..))+import Moonlight.Triangulation.Types (Point (..))+import System.Mem (performGC)+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import Data.Word (Word64)++-- | A filtered predicate must not evaluate its exact oracle when the floating+-- approximation already certifies the sign. The exact path allocates+-- 'Integer's, so equal-shaped certified and degenerate folds expose whether+-- that fallback remains genuinely conditional.+assertFilteredPredicatesSkipExactOracle :: IO ()+assertFilteredPredicatesSkipExactOracle = do+  enabled <- getRTSStatsEnabled+  unless enabled $ fail "allocation counters unavailable: the suite must run with -T"+  let count = 20_000+      bigScale = 2 ^^ (200 :: Int) :: Double+      smallScale = 2 ^^ (-200 :: Int) :: Double+      orientCertified =+        V.generate+          count+          (\index -> QueryPoint (Point (fromIntegral index * bigScale) (if even index then 0 else smallScale)))+      orientDegenerate =+        V.generate+          count+          (\index -> QueryPoint (Point (fromIntegral index * bigScale) (fromIntegral index * smallScale)))+      zigzag = V.generate count (\index -> QueryPoint (Point (fromIntegral index) (if even index then 0 else 1)))+      collinear = V.generate count (\index -> QueryPoint (Point (fromIntegral index) (fromIntegral index)))+      orientationIndices = U.enumFromN 0 (max 0 (count - 2))+      circleIndices = U.enumFromN 0 (max 0 (count - 3))+  _ <- evaluate (force orientCertified)+  _ <- evaluate (force orientDegenerate)+  _ <- evaluate (force zigzag)+  _ <- evaluate (force collinear)+  _ <- evaluate (force orientationIndices)+  _ <- evaluate (force circleIndices)+  certifiedSupport <- allocationOf (sumTripleRelations approximateOrientation orientationIndices orientCertified)+  fallbackSupport <- allocationOf (sumTripleRelations approximateOrientation orientationIndices orientDegenerate)+  certified <- allocationOf (sumTripleRelations orient2d orientationIndices orientCertified)+  fallback <- allocationOf (sumTripleRelations orient2d orientationIndices orientDegenerate)+  let certifiedOracle = allocationBeyondApproximation certified certifiedSupport+      fallbackOracle = allocationBeyondApproximation fallback fallbackSupport+  unless (fallbackOracle > 0) $+    fail "degenerate orientations allocated nothing: the measurement is not observing the oracle"+  unless (certifiedOracle * 8 < fallbackOracle) $+    fail+      ( "orient2d evaluates its exact oracle on certified input: "+          <> show certifiedOracle+          <> " excess bytes certified versus "+          <> show fallbackOracle+          <> " excess bytes degenerate (raw "+          <> show certified+          <> " versus "+          <> show fallback+          <> ")"+      )+  certifiedCircleSupport <- allocationOf (sumQuadRelations approximateInCircle circleIndices zigzag)+  fallbackCircleSupport <- allocationOf (sumQuadRelations approximateInCircle circleIndices collinear)+  certifiedCircle <- allocationOf (sumQuadRelations inCircle circleIndices zigzag)+  fallbackCircle <- allocationOf (sumQuadRelations inCircle circleIndices collinear)+  let certifiedCircleOracle = allocationBeyondApproximation certifiedCircle certifiedCircleSupport+      fallbackCircleOracle = allocationBeyondApproximation fallbackCircle fallbackCircleSupport+  unless (fallbackCircleOracle > 0) $+    fail "degenerate incircles allocated nothing: the measurement is not observing the oracle"+  unless (certifiedCircleOracle * 8 < fallbackCircleOracle) $+    fail+      ( "inCircle evaluates its exact oracle on certified input: "+          <> show certifiedCircleOracle+          <> " excess bytes certified versus "+          <> show fallbackCircleOracle+          <> " excess bytes degenerate (raw "+          <> show certifiedCircle+          <> " versus "+          <> show fallbackCircle+          <> ")"+      )++allocationOf :: Int -> IO Word64+allocationOf work = do+  performGC+  before <- allocated_bytes <$> getRTSStats+  _ <- evaluate work+  performGC+  after <- allocated_bytes <$> getRTSStats+  pure (after - before)++allocationBeyondApproximation :: Word64 -> Word64 -> Word64+allocationBeyondApproximation measured support = measured - min measured support++sumTripleRelations+  :: (QueryPoint -> QueryPoint -> QueryPoint -> Ordering)+  -> U.Vector Int+  -> V.Vector QueryPoint+  -> Int+sumTripleRelations relation indices points =+  U.foldl'+    (\accumulated index ->+       accumulated+         + fromEnum+           ( relation+               (V.unsafeIndex points index)+               (V.unsafeIndex points (index + 1))+               (V.unsafeIndex points (index + 2))+           )+    )+    0+    indices+{-# INLINE sumTripleRelations #-}++sumQuadRelations+  :: (QueryPoint -> QueryPoint -> QueryPoint -> QueryPoint -> Ordering)+  -> U.Vector Int+  -> V.Vector QueryPoint+  -> Int+sumQuadRelations relation indices points =+  U.foldl'+    (\accumulated index ->+       accumulated+         + fromEnum+           ( relation+               (V.unsafeIndex points index)+               (V.unsafeIndex points (index + 1))+               (V.unsafeIndex points (index + 2))+               (V.unsafeIndex points (index + 3))+           )+    )+    0+    indices+{-# INLINE sumQuadRelations #-}++approximateOrientation :: QueryPoint -> QueryPoint -> QueryPoint -> Ordering+approximateOrientation (QueryPoint a) (QueryPoint b) (QueryPoint c) =+  compare (orientDetApprox a b c) 0+{-# INLINE approximateOrientation #-}++approximateInCircle :: QueryPoint -> QueryPoint -> QueryPoint -> QueryPoint -> Ordering+approximateInCircle (QueryPoint a) (QueryPoint b) (QueryPoint c) (QueryPoint d) =+  compare (inCircleDetApprox a b c d) 0+{-# INLINE approximateInCircle #-}
+ test/native/Moonlight/Triangulation/NativeSpec.hs view
@@ -0,0 +1,4426 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | The native core slice: everything that needs no serialization surface.+module Moonlight.Triangulation.NativeSpec+  ( tests+  , 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 qualified Data.IntSet as IntSet+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (isJust)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.List (sort)+import qualified Data.Vector as V+import Data.Primitive.PrimArray (indexPrimArray, primArrayFromList, sizeofPrimArray)+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MUV+import Data.Word (Word32, Word64)+import Moonlight.Triangulation.Alpha+import Moonlight.Triangulation.BulkLoad+import Moonlight.Triangulation.Cdt+import Moonlight.Triangulation.Dcel+import qualified Moonlight.Triangulation.Dcel as Dcel+import Moonlight.Triangulation.FloodFillIterator+import Moonlight.Triangulation.Internal.HandleDefs+import Moonlight.Triangulation.Handles.Iterators.FixedIterators+import Moonlight.Triangulation.HintGenerator+import Moonlight.Triangulation.Interpolation+import Moonlight.Triangulation.IntersectionIterator+import Moonlight.Triangulation.Internal.Session (excise)+import Moonlight.Triangulation.Internal.Validation (validateTopologyClosure)+import Moonlight.Triangulation.Math+import Moonlight.Triangulation.Payload+import Moonlight.Triangulation.FilteredPredicateOptimizationSpec+  ( assertFilteredPredicatesSkipExactOracle+  )+import Moonlight.Triangulation.PointLocation+import Moonlight.Triangulation.Refinement+import Moonlight.Triangulation.Removal+import Moonlight.Triangulation.Scalar+import Moonlight.Triangulation.Session+import Moonlight.Triangulation.Types+import Moonlight.Triangulation.Validation+import Moonlight.Triangulation.Voronoi+import Moonlight.Triangulation.Handles.Dynamic qualified as Dynamic+import Moonlight.Triangulation.Handles.Iterators.DynamicIterators qualified as DynamicIterators+import Moonlight.Triangulation.Internal.BoxedPaged (boxedMaterializedPageCount)+import Moonlight.Triangulation.Internal.Canonical (canonicalize)+import Moonlight.Triangulation.Internal.Paged+  ( Paged+  , PublicationStats (..)+  , fromVector+  , toVector+  )+import Moonlight.Triangulation.Internal.Predicates qualified as Admitted+import Moonlight.Triangulation.Internal.PointIndex+  ( MutablePointIndexUpdate (..)+  , lookupMutablePoint+  , newMutablePointIndex+  , relocateMutablePoint+  , removeMutablePoint+  , seedMutablePointIndex+  )+import Moonlight.Triangulation.Internal.Representation qualified as Internal+import Moonlight.Triangulation.Voronoi.Handles qualified as VoronoiDynamic+import GHC.Generics (Generic)+import Support (assertEqual, assertValid, requireQueryPoint, requireRight)++tests :: IO ()+tests = do+  testConstructors+  testPredicates+  testParaboloidLift+  assertFilteredPredicatesSkipExactOracle+  testValidationRejectsCorruptedMeshes+  testRefinementCompletionIsAFixpoint+  testScalarFormat+  testWideDistanceNearestNeighbor+  testIncrementalLocationDescent+  testPersistentInsertionReusesFrozenLocation+  testVertexSeededSessionInsertion+  testCircleSweepBulkLoad+  testMixedEditSession+  testBulkRemovalAgreement+  testMutablePointIndexWraparoundBackshift+  testBatchIdentityIndexBatchToEmpty+  testBatchIdentityIndexToSingletonActive+  testBulkIdentityIndexDoesNotEscapeRemovalBatch+  testHierarchyRemovalAgreement+  testHandlesAndFiniteDcel+  testDegenerateConstruction+  testPersistentLocalUpdates+  testGenericPayloads+  testPayloadMaps+  testGeometryOnlyPublication+  testPayloadTraversals+  testRewritePayloadIdentity+  testPointLocationAndHints+  testHierarchyNestingLaw+  testSibsonInterpolation+  testVoronoiDual+  testRemoval+  testConstrainedDelaunay+  testAnnotatedConstrainedUnion+  testAsymmetricConstrainedExtension+  testLargeAsymmetricConstrainedExtension+  testSeparatedConstrainedSeam+  testAxisSeparatedConstrainedSeams+  testSeparatedConstrainedSeamRefusesPinnedFrontierRewrite+  testLocalRefinementRejectsEncroachedHullSplit+  testConstrainedRefinement+  testCheckedLocalRefinement+  testMaximumEdgeLengthQuality+  testLocalRefinementRejectsTrueInterfaceCrossing+  testRepeatedBoundaryAdjacentRefinement+  testFaceComponentsAndBoundaries+  testAlphaFaceFiltration+  testTraversal+  testRandomizedConstruction+  testErrors+  putStrLn "all native core tests passed"++data SampleVertex = SampleVertex+  { samplePosition :: !(Point)+  , sampleLabel :: !Int+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++instance HasPosition SampleVertex where+  position = samplePosition+++testConstructors :: IO ()+testConstructors = do+  let vacant = empty unitElementDefaults :: DelaunayTriangulation (Point)+  originQuery <- requireQueryPoint "empty location query" (Point 0 0)+  assertValid "empty" vacant+  assertEqual "empty vertex count" 0 (numVertices vacant)+  assertEqual "empty directed edge count" 0 (numDirectedEdges vacant)+  assertEqual "empty face count" 1 (numFaces vacant)+  assertEqual "empty locates nowhere" EmptyTriangulation (locatePoint vacant originQuery)+  built <- requirePointBuild "clear source" [Point 0 0, Point 1 0, Point 0 1]+  assertEqual "clear returns the origin" vacant (clear (buildTriangulation built))++type NativeMesh = Triangulation 'Unconstrained (Point) () () ()++-- | A named corruption of a mesh that was valid one line earlier, paired with+-- the violation it must provoke. Validation that has never been made to fail is+-- evidence only that it ran.+data Corruption = Corruption+  { corruptionName :: String+  , corruptMesh :: NativeMesh -> NativeMesh+  , provokes :: InvariantViolation -> Bool+  }++-- Sheared so that no four sites are cocircular: on a square grid the diagonal+-- of every cell is a free choice, and a fixture that admits two answers cannot+-- witness a wrong one.+corruptionFixture :: [Point]+corruptionFixture =+  [ Point (fromIntegral column + 0.25 * fromIntegral row) (1.3 * fromIntegral row)+  | column <- [0 .. 3 :: Int]+  , row <- [0 .. 3 :: Int]+  ]++rewritePlane :: (U.Unbox a, Num a) => (U.Vector a -> U.Vector a) -> Paged a -> Paged a+rewritePlane edit = fromVector 0 . edit . toVector++slot :: U.Unbox a => Int -> a -> U.Vector a -> U.Vector a+slot at value = (U.// [(at, value)])++-- Past the end of every plane in the fixture, and far from the sentinels the+-- packed representation reserves for absence.+beyond :: NativeMesh -> Word32+beyond mesh = fromIntegral (numDirectedEdges mesh + numVertices mesh + 64)++onTopology :: (NativeMesh -> U.Vector Word32 -> U.Vector Word32) -> NativeMesh -> NativeMesh+onTopology edit mesh =+  mesh {Internal.triHalfTopology = rewritePlane (edit mesh) (Internal.triHalfTopology mesh)}++-- The half-edge plane has stride four — origin, next, previous, face — so the+-- first four entries below are one surgery distinguished only by which field+-- the out-of-range index lands on.+structuralCorruptions :: [Corruption]+structuralCorruptions =+  [ Corruption+      "edge origin names an absent vertex"+      (onTopology (slot 0 . beyond))+      (\case EdgeOriginOutOfRange {} -> True; _ -> False)+  , Corruption+      "edge next names an absent edge"+      (onTopology (slot 1 . beyond))+      (\case EdgeNextOutOfRange {} -> True; _ -> False)+  , Corruption+      "edge previous names an absent edge"+      (onTopology (slot 2 . beyond))+      (\case EdgePreviousOutOfRange {} -> True; _ -> False)+  , Corruption+      "edge face names an absent face"+      (onTopology (slot 3 . beyond))+      (\case EdgeFaceOutOfRange {} -> True; _ -> False)+  , Corruption+      "vertex outgoing names an absent edge"+      ( \mesh ->+          mesh+            { Internal.triVertexOut =+                rewritePlane (slot 0 (beyond mesh)) (Internal.triVertexOut mesh)+            }+      )+      (\case VertexOutgoingOutOfRange {} -> True; _ -> False)+  , Corruption+      "a coordinate plane is one short"+      (\mesh -> mesh {Internal.triPointX = rewritePlane U.init (Internal.triPointX mesh)})+      (\case CoordinatePlaneLengthMismatch {} -> True; _ -> False)+  , Corruption+      "every inner face wound clockwise"+      (\mesh -> mesh {Internal.triPointY = rewritePlane (U.map negate) (Internal.triPointY mesh)})+      (\case InnerFaceNotCounterClockwise {} -> True; _ -> False)+  ]++-- Structural corruption is caught before geometry is read, so the empty-circle+-- law needs a mesh that stays well formed and merely stops being Delaunay.+delaunayCorruptions :: [Corruption]+delaunayCorruptions =+  [ Corruption+      "one site dragged through its neighbours' circumcircles"+      (\mesh -> mesh {Internal.triPointX = rewritePlane (slot 5 40) (Internal.triPointX mesh)})+      (\case LocallyIllegalDelaunayEdge {} -> True; _ -> False)+  ]++-- A surgery that changed nothing would report the oracle as unarmed when in+-- truth it was never asked anything, so the mutant must differ before its+-- rejection means a thing.+assertRejects+  :: String -> (NativeMesh -> [InvariantViolation]) -> NativeMesh -> Corruption -> IO ()+assertRejects oracle check pristine corruption = do+  let mutant = corruptMesh corruption pristine+      label = oracle <> " / " <> corruptionName corruption+      reported = check mutant+  when (mutant == pristine) $ fail (label <> ": the surgery changed nothing")+  unless (any (provokes corruption) reported) $+    fail (label <> ": admitted, reporting " <> show reported)++testValidationRejectsCorruptedMeshes :: IO ()+testValidationRejectsCorruptedMeshes = do+  built <- requirePointBuild "corruption fixture" corruptionFixture+  let pristine = buildTriangulation built+  assertValid "corruption fixture" pristine+  mapM_ (assertRejects "topology" validateTopology pristine) structuralCorruptions+  mapM_ (assertRejects "delaunay" validateDelaunay pristine) delaunayCorruptions+  case innerFaces pristine of+    [] -> fail "local validation fixture has no inner face"+    witnessFace : _ ->+      case faceDirectedEdges pristine witnessFace of+        [] -> fail "local validation fixture has no face edge"+        DirectedEdgeId rawEdge : _ -> do+          let admitted = IntSet.singleton (fromIntegral (unFaceId witnessFace))+              corrupted =+                pristine+                  { Internal.triHalfTopology =+                      rewritePlane+                        (slot (4 * fromIntegral rawEdge + 1) rawEdge)+                        (Internal.triHalfTopology pristine)+                  }+          assertEqual+            "selected validation accepts valid closure"+            []+            (validateTopologyClosure admitted IntSet.empty pristine)+          unless (not (null (validateTopology corrupted))) $+            fail "global validation missed the locally corrupt face closure"+          unless (not (null (validateTopologyClosure admitted IntSet.empty corrupted))) $+            fail "selected validation missed a locally corrupt face closure"++reverseTraversalEvent :: Intersection -> Intersection+reverseTraversalEvent = \case+  EdgeIntersection edge -> EdgeIntersection (reverseEdge edge)+  EdgeOverlap edge -> EdgeOverlap (reverseEdge edge)+  VertexIntersection vertex -> VertexIntersection vertex++-- | What @refinementComplete@ claims is that the quality worklist drained. The+-- assertable content of that claim is a fixpoint: a second pass under the same+-- parameters can admit nothing. The complementary run is budget-starved, where+-- the run must stop short and spend exactly what it was given.+testRefinementCompletionIsAFixpoint :: IO ()+testRefinementCompletionIsAFixpoint = do+  -- Barrier parity needs constraints to bound a domain: on an unconstrained+  -- mesh every face sits at depth zero, so excluding outer faces excludes all+  -- of them and the worklist drains having refined nothing.+  bounded <-+    requireRight "refinement fixpoint domain" $+      constrainedDelaunay+        unitElementDefaults+        (V.fromList [Point 0 0, Point 8 0, Point 8 8, Point 0 8])+        (V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)])+  let source = buildTriangulation bounded+      parameters =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just 500+          , refineMaxArea = Just 3+          , refineExcludeOuterFaces = True+          }+  drained <- requireRight "drained refinement" (refine id parameters source)+  unless (refinementComplete drained) $+    fail "the refinement budget was too small to drain the worklist"+  -- Without this the fixpoint below is vacuous: a run that refined nothing+  -- trivially admits nothing on a second pass.+  unless (refinementAddedVertices drained > 0) $+    fail "the drained run inserted no Steiner points, so the fixpoint proves nothing"+  assertValid "drained refinement" (refinedTriangulation drained)+  again <- requireRight "second refinement pass" (refine id parameters (refinedTriangulation drained))+  assertEqual+    "a drained worklist admits nothing on a second pass"+    0+    (refinementAddedVertices again)+  starved <-+    requireRight+      "starved refinement"+      (refine id parameters {refineMaxAdditionalVertices = Just 3} source)+  when (refinementComplete starved) $+    fail "a three-vertex budget reported a drained worklist"+  assertEqual "a starved run spends exactly its budget" 3 (refinementAddedVertices starved)++testScalarFormat :: IO ()+testScalarFormat = do+  let binary64 = scalarBinaryFormat+  assertEqual "binary64 radix" 2 (formatRadix binary64)+  assertEqual "binary64 mantissa" 53 (formatMantissaDigits binary64)+  assertEqual "binary64 unit roundoff" (encodeFloat 1 (-53)) (scalarUnitRoundoff :: Double)++testWideDistanceNearestNeighbor :: IO ()+testWideDistanceNearestNeighbor = do+  let largePoints = V.fromList+        [ Point 0 0+        , Point 1.0e20 0+        , Point 2.0e20 0+        , Point 1.0e20 1.0e19+        ] :: V.Vector (Point)+  largeBuild <- requireRight "wide-distance build" (delaunay unitElementDefaults largePoints)+  let largeTriangulation = buildTriangulation largeBuild+  assertValid "wide-distance triangulation" largeTriangulation+  query <- requireQueryPoint "wide-distance query" (Point 1.05e20 0)+  case nearestNeighbor largeTriangulation Nothing query of+    Nothing -> fail "wide-distance nearest-neighbor returned Nothing"+    Just (nearest, _) -> assertEqual "wide-distance nearest-neighbor" (VertexId 1) nearest++data IncrementalLocationEvidence = IncrementalLocationEvidence+  { incrementalTriangulation :: !(DelaunayTriangulation (Point))+  , incrementalWalkSteps :: {-# UNPACK #-} !Int+  , incrementalFallbacks :: {-# UNPACK #-} !Int+  }++testIncrementalLocationDescent :: IO ()+testIncrementalLocationDescent = do+  small <- collectIncrementalLocationEvidence 500+  large <- collectIncrementalLocationEvidence 1000+  assertEqual "incremental location fallbacks/500" 0 (incrementalFallbacks small)+  assertEqual "incremental location fallbacks/1000" 0 (incrementalFallbacks large)+  unless (2 * incrementalWalkSteps large < 7 * incrementalWalkSteps small) $+    fail+      ( "incremental location approached quadratic growth: "+          <> show (incrementalWalkSteps small, incrementalWalkSteps large)+      )+  assertValid "incremental location descent/1000" (incrementalTriangulation large)++collectIncrementalLocationEvidence :: Int -> IO IncrementalLocationEvidence+collectIncrementalLocationEvidence count =+  V.foldM' insertAndAccumulate initialEvidence (V.fromList (randomPoints 0xc1ac_10ca count))+ where+  initialEvidence =+    IncrementalLocationEvidence+      { incrementalTriangulation = empty unitElementDefaults+      , incrementalWalkSteps = 0+      , incrementalFallbacks = 0+      }++  insertAndAccumulate evidence point = do+    result <- requireRight "incremental location descent" (insert (incrementalTriangulation evidence) point)+    let stats = insertionStats result+    pure+      IncrementalLocationEvidence+        { incrementalTriangulation = insertionTriangulation result+        , incrementalWalkSteps = incrementalWalkSteps evidence + statLocationWalkSteps stats+        , incrementalFallbacks = incrementalFallbacks evidence + statLocationFallbacks stats+        }++-- A persistent insertion locates on the frozen mesh before opening its dense+-- transaction. The thaw preserves every extant handle, so a lawful frozen+-- location can be interpreted directly without a second mutable walk. A+-- degenerate-line outside witness lacks the terminal-edge evidence its mutable+-- interpreter requires, so that one stratum deliberately retains the mutable+-- fallback. Exercise every frozen stratum, including the singleton's edge-less+-- outside witness, rather than testing only the ordinary face case.+testPersistentInsertionReusesFrozenLocation :: IO ()+testPersistentInsertionReusesFrozenLocation = do+  let vacant = empty unitElementDefaults :: DelaunayTriangulation (Point)+  emptyLocation <- assertPersistentInsertionFromFrozenLocation "empty" Inserted vacant (Point 0 0)+  assertEqual "empty insertion frozen location" EmptyTriangulation emptyLocation++  singletonBuild <- requirePointBuild "singleton frozen location" [Point 0 0]+  singletonLocation <-+    assertPersistentInsertionFromFrozenLocation+      "singleton outside insertion"+      Inserted+      (buildTriangulation singletonBuild)+      (Point 2 0)+  assertEqual "singleton insertion frozen location" (OutsideConvexHull Nothing) singletonLocation++  lineBuild <- requirePointBuild "line frozen locations" [Point 0 0, Point 2 0, Point 4 0]+  let line = buildTriangulation lineBuild+  lineEdgeLocation <- assertPersistentInsertionFromFrozenLocation "line edge insertion" Inserted line (Point 1 0)+  case lineEdgeLocation of+    OnEdge _ -> pure ()+    other -> fail ("line edge insertion located " <> show other)+  lineOutsideLocation <- assertPersistentInsertionFromFrozenLocation "line extension" Inserted line (Point 6 0)+  case lineOutsideLocation of+    OutsideConvexHull (Just _) -> pure ()+    other -> fail ("line extension located " <> show other)++  triangleBuild <- requirePointBuild "area frozen locations" [Point 0 0, Point 4 0, Point 0 4]+  let triangle = buildTriangulation triangleBuild+  faceLocation <- assertPersistentInsertionFromFrozenLocation "face insertion" Inserted triangle (Point 1 1)+  case faceLocation of+    InFace _ -> pure ()+    other -> fail ("face insertion located " <> show other)+  edgeLocation <- assertPersistentInsertionFromFrozenLocation "area edge insertion" Inserted triangle (Point 2 0)+  case edgeLocation of+    OnEdge _ -> pure ()+    other -> fail ("area edge insertion located " <> show other)+  hullLocation <- assertPersistentInsertionFromFrozenLocation "hull insertion" Inserted triangle (Point 5 1)+  case hullLocation of+    OutsideConvexHull (Just _) -> pure ()+    other -> fail ("hull insertion located " <> show other)+  duplicateLocation <- assertPersistentInsertionFromFrozenLocation "duplicate insertion" AlreadyPresent triangle (Point 0 0)+  assertEqual "duplicate insertion frozen location" (OnVertex (VertexId 0)) duplicateLocation++assertPersistentInsertionFromFrozenLocation+  :: String+  -> InsertionDisposition+  -> DelaunayTriangulation (Point)+  -> Point+  -> IO Location+assertPersistentInsertionFromFrozenLocation label expectedDisposition source point = do+  query <- requireQueryPoint (label <> " frozen query") point+  let (located, walked) = locatePointWithHint source Nothing query+      sourceVertices = numVertices source+      usesMutableFallback =+        case located of+          OutsideConvexHull (Just _) -> numInnerFaces source == 0+          _ -> False+  result <- requireRight (label <> " insert") (insert source point)+  ((referenceVertex, referenceDisposition), reference, _) <-+    requireRight (label <> " session reference") $+      withSession source 1 (insertVertexAt point point)+  let stats = insertionStats result+      expectedVertices =+        case expectedDisposition of+          Inserted -> sourceVertices + 1+          AlreadyPresent -> sourceVertices+      expectedUnique =+        case expectedDisposition of+          Inserted -> 1+          AlreadyPresent -> 0+      expectedExisting =+        case expectedDisposition of+          Inserted -> 0+          AlreadyPresent -> 1+  assertEqual (label <> " disposition") expectedDisposition (insertionDisposition result)+  assertEqual (label <> " session disposition") referenceDisposition (insertionDisposition result)+  assertEqual (label <> " session vertex") referenceVertex (insertionVertex result)+  assertEqual+    (label <> " exact-location topology matches session")+    (canonicalEdges reference)+    (canonicalEdges (insertionTriangulation result))+  assertEqual (label <> " source remains unchanged") sourceVertices (numVertices source)+  assertEqual (label <> " result vertex count") expectedVertices (numVertices (insertionTriangulation result))+  assertEqual (label <> " input count") 1 (statInputPoints stats)+  assertEqual (label <> " unique count") expectedUnique (statUniquePoints stats)+  assertEqual (label <> " existing count") expectedExisting (statExistingPoints stats)+  assertEqual (label <> " duplicate count") expectedExisting (statDuplicatePoints stats)+  if usesMutableFallback+    then do+      let assertAtLeast counter expected actual =+            unless+              (actual >= expected)+              ( fail+                  ( label+                      <> " "+                      <> counter+                      <> " includes frozen evidence: expected at least "+                      <> show expected+                      <> ", got "+                      <> show actual+                  )+              )+      assertAtLeast "walk steps" (locationWalkSteps walked) (statLocationWalkSteps stats)+      assertAtLeast "walk maximum" (locationWalkSteps walked) (statLocationMaxWalk stats)+      assertAtLeast+        "fallback count"+        (if locationUsedFallback walked then 1 else 0)+        (statLocationFallbacks stats)+    else do+      assertEqual (label <> " frozen walk steps") (locationWalkSteps walked) (statLocationWalkSteps stats)+      assertEqual (label <> " frozen walk maximum") (locationWalkSteps walked) (statLocationMaxWalk stats)+      assertEqual+        (label <> " frozen fallback count")+        (if locationUsedFallback walked then 1 else 0)+        (statLocationFallbacks stats)+  assertValid (label <> " result") (insertionTriangulation result)+  pure located++-- A vertex hint restricts to one incident face and then relinquishes+-- authority to the exact mutable walk. Valid, stale, occupied, and face-less+-- local sections must therefore glue to the same published result as the+-- unhinted entrance.+testVertexSeededSessionInsertion :: IO ()+testVertexSeededSessionInsertion = do+  area <- sampleMesh "vertex-seeded area" [Point 0 0, Point 4 0, Point 0 4]+  seed <- vertexAt "vertex-seeded area seed" area (Point 0 0)+  assertVertexSeededInsertionAgreement+    "vertex-seeded interior insertion"+    area+    seed+    (SampleVertex (Point 1 1) 40)+  assertVertexSeededInsertionAgreement+    "vertex-seeded invalid hint"+    area+    (VertexId maxBound)+    (SampleVertex (Point 3 3) 41)+  assertVertexSeededInsertionAgreement+    "vertex-seeded duplicate"+    area+    seed+    (SampleVertex (Point 4 0) 42)++  line <- sampleMesh "vertex-seeded line" [Point 0 0, Point 2 0, Point 4 0]+  lineSeed <- vertexAt "vertex-seeded line seed" line (Point 2 0)+  assertVertexSeededInsertionAgreement+    "vertex-seeded face-less fallback"+    line+    lineSeed+    (SampleVertex (Point 3 0) 43)+ where+  sampleMesh+    :: String+    -> [Point]+    -> IO (Triangulation 'Unconstrained SampleVertex () () ())+  sampleMesh label points = do+    built <-+      requireRight label $+        delaunay+          unitElementDefaults+          (V.imap (\index point -> SampleVertex point index) (V.fromList points))+    pure (buildTriangulation built)++  vertexAt+    :: String+    -> Triangulation 'Unconstrained SampleVertex () () ()+    -> Point+    -> IO VertexId+  vertexAt label triangulation point = do+    query <- requireQueryPoint label point+    case locatePoint triangulation query of+      OnVertex vertex -> pure vertex+      location -> fail (label <> " did not locate a vertex: " <> show location)++assertVertexSeededInsertionAgreement+  :: String+  -> Triangulation 'Unconstrained SampleVertex () () ()+  -> VertexId+  -> SampleVertex+  -> IO ()+assertVertexSeededInsertionAgreement label source seed payload = do+  ((referenceVertex, referenceDisposition), reference, _) <-+    requireRight (label <> " unhinted") $+      withSession source 1 (insertVertexAt (samplePosition payload) payload)+  ((hintedVertex, hintedDisposition), hinted, _) <-+    requireRight (label <> " hinted") $+      withSession source 1 (insertVertexAtNearVertex seed (samplePosition payload) payload)+  assertEqual (label <> " vertex") referenceVertex hintedVertex+  assertEqual (label <> " disposition") referenceDisposition hintedDisposition+  assertEqual (label <> " topology") (canonicalEdges reference) (canonicalEdges hinted)+  assertEqual (label <> " payload") payload (vertexData hinted hintedVertex)+  assertValid label hinted++-- Circle sweep must be a construction schedule, not a second topology. It is+-- compared against the arrival-order session kernel on the same exact inputs.+-- | One session, both verbs. The reason the two published sessions became one:+-- a caller who removes and inserts had to thaw twice and pay the O(n)+-- publication a session exists to delete.+--+-- Graded against the oracle that needs no second implementation — the Delaunay+-- triangulation of a point set in general position is unique, so a mixed edit+-- must land exactly where a fresh bulk load of the surviving set lands.+testMixedEditSession :: IO ()+testMixedEditSession = do+  let original = V.fromList (randomPoints 0x5eed1e 400)+      doomed = V.take 120 original+      survivors = V.drop 120 original+      arrivals = V.fromList (randomPoints 0xa7717a1 90)+  (_, edited, stats) <-+    requireRight "mixed session" $+      withSession+        (buildTriangulation (either (error . show) id (delaunay unitElementDefaults original)))+        (V.length arrivals)+        ( do+            V.mapM_ (\point -> removeAt point >>= maybe (refuse (RemovalVertexOutOfRange (VertexId 0) 0)) (const (pure ()))) doomed+            V.mapM_ insertVertex arrivals+        )+  fresh <- requireRight "fresh rebuild" (delaunay unitElementDefaults (survivors <> arrivals))+  assertEqual+    "mixed edit equals a fresh build of the surviving set"+    (canonicalEdges (buildTriangulation fresh))+    (canonicalEdges edited)+  assertValid "mixed edit session" edited+  assertEqual+    "the whole transaction charged one counter set"+    (V.length arrivals)+    (statInputPoints stats)++-- The bulk removal verb must land exactly where the singleton fold lands, on+-- both sides of its locate-strategy crossover: a small batch keeps the+-- per-question walk, a large one buys the identity index once. Same removals,+-- same order, same survivor either way.+testBulkRemovalAgreement :: IO ()+testBulkRemovalAgreement = do+  let original = V.fromList (randomPoints 0xb01dca7 400)+      base = buildTriangulation (either (error . show) id (delaunay unitElementDefaults original))+      run label doomed = do+        (outcomes, survived, _) <-+          requireRight (label <> " bulk removal") (withSession base 0 (removeManyAt doomed))+        V.imapM_+          ( \index outcome ->+              maybe (fail (label <> " bulk removal missed index " <> show index)) (const (pure ())) outcome+          )+          outcomes+        (_, folded, _) <-+          requireRight (label <> " singleton removal fold") $+            withSession+              base+              0+              ( V.mapM_+                  (\point -> removeAt point >>= maybe (refuse (RemovalVertexOutOfRange (VertexId 0) 0)) (const (pure ())))+                  doomed+              )+        assertEqual+          (label <> " bulk removal equals singleton descent")+          (canonicalEdges folded)+          (canonicalEdges survived)+        assertValid (label <> " bulk removal") survived+  run "walking" (V.take 40 original)+  run "indexed" (V.take 120 original)++-- The three fixture positions hash to home slot 15 in the 16-slot table made+-- for three keys. They therefore occupy 15, 0, and 1 in insertion order. The+-- middle deletion exercises both wraparound and backward shift, while the+-- coordinate overwrite models the tail move performed before the table handle+-- is renamed by 'swapRemoveVertex'.+testMutablePointIndexWraparoundBackshift :: IO ()+testMutablePointIndexWraparoundBackshift = do+  (removed, first, movedBeforeRelocation, relocated, movedAfterRelocation) <-+    requireRight "mutable point-index wraparound/backshift law" wraparoundLaw+  case removed of+    MutablePointIndexUpdated -> pure ()+    MutablePointIndexInvalidated -> fail "mutable point-index middle delete invalidated a valid table"+  assertEqual "mutable point-index first wraparound occupant" (Just 0) first+  assertEqual "mutable point-index shifted tail before relocation" (Just 2) movedBeforeRelocation+  case relocated of+    MutablePointIndexUpdated -> pure ()+    MutablePointIndexInvalidated -> fail "mutable point-index tail relocation invalidated a valid table"+  assertEqual "mutable point-index relocated tail" (Just 1) movedAfterRelocation+ where+  wraparoundLaw = runST $ do+    pointXs <- MUV.replicate 3 (0 :: Double)+    pointYs <- MUV.replicate 3 (0 :: Double)+    MUV.unsafeWrite pointXs 0 (-20)+    MUV.unsafeWrite pointYs 0 (-15)+    MUV.unsafeWrite pointXs 1 (-20)+    MUV.unsafeWrite pointYs 1 0+    MUV.unsafeWrite pointXs 2 (-20)+    MUV.unsafeWrite pointYs 2 7+    table <- newMutablePointIndex 3+    seeded <- seedMutablePointIndex table 3 (MUV.unsafeRead pointXs) (MUV.unsafeRead pointYs)+    case seeded of+      Left failure -> pure (Left failure)+      Right () -> do+        -- The tail has moved into slot one before identity transport begins.+        MUV.unsafeWrite pointXs 1 (-20)+        MUV.unsafeWrite pointYs 1 7+        removed <-+          removeMutablePoint table (MUV.unsafeRead pointXs) (MUV.unsafeRead pointYs) (-20) 0 1+        first <-+          lookupMutablePoint table (MUV.unsafeRead pointXs) (MUV.unsafeRead pointYs) (-20) (-15)+        movedBeforeRelocation <-+          lookupMutablePoint table (MUV.unsafeRead pointXs) (MUV.unsafeRead pointYs) (-20) 7+        relocated <- relocateMutablePoint table (-20) 7 2 1+        movedAfterRelocation <-+          lookupMutablePoint table (MUV.unsafeRead pointXs) (MUV.unsafeRead pointYs) (-20) 7+        pure+          ( Right+              ( removed+              , first+              , movedBeforeRelocation+              , relocated+              , movedAfterRelocation+              )+          )++-- A dense table must also close lawfully when it removes every vertex. The+-- point-keyed query after freeze forces the empty published derivation rather+-- than retaining an impossible ST table.+testBatchIdentityIndexBatchToEmpty :: IO ()+testBatchIdentityIndexBatchToEmpty = do+  let points = V.fromList (randomPoints 0x7a110bad 32)+  built <- requireRight "batch identity empty base" (delaunay unitElementDefaults points)+  (outcomes, emptied, _) <-+    requireRight "batch identity removes every point" $+      withSession (buildTriangulation built) 0 (removeManyAt points)+  unless (V.all isJust outcomes) $+    fail "batch identity table missed a point while removing to empty"+  assertEqual "batch identity empty vertex count" 0 (numVertices emptied)+  assertValid "batch identity empty result" emptied+  absent <- requireRight "empty published identity lookup" (locateAndRemove emptied (Point 0 0))+  case absent of+    Nothing -> pure ()+    Just _ -> fail "empty published identity lookup manufactured a removal"++-- A dense batch discards its ST table before the next singleton handle rewrite.+-- 'excise' must therefore activate and transport the ordinary persistent index+-- without consulting the expired batch representation.+testBatchIdentityIndexToSingletonActive :: IO ()+testBatchIdentityIndexToSingletonActive = do+  let original = V.fromList (randomPoints 0x51a91e 64)+      doomed = V.take 32 original+      survivors = V.drop 32 original+  built <- requireRight "batch-to-singleton identity base" (delaunay unitElementDefaults original)+  (singletonOutcome, transitioned, _) <-+    requireRight "batch-to-singleton identity session" $+      withSession (buildTriangulation built) 0 $ do+        _ <- removeManyAt doomed+        excise (VertexId 0)+  let singletonPoint = removalOutcomePoint singletonOutcome+      expected = V.filter (/= singletonPoint) survivors+  fresh <- requireRight "batch-to-singleton fresh rebuild" (delaunay unitElementDefaults expected)+  assertEqual+    "batch-to-singleton identity topology"+    (canonicalEdges (buildTriangulation fresh))+    (canonicalEdges transitioned)+  assertValid "batch-to-singleton identity result" transitioned+  case V.find (/= singletonPoint) survivors of+    Nothing -> fail "batch-to-singleton fixture exhausted every survivor"+    Just remaining -> do+      located <- requireRight "batch-to-singleton published lookup" (locateAndRemove transitioned remaining)+      case located of+        Nothing -> fail "batch-to-singleton published lookup missed a survivor"+        Just removal -> assertValid "batch-to-singleton published removal" (removalTriangulation removal)++-- The mutable identity table is an internal section of @removeManyAt@, never a+-- session-wide owner. An insertion after the dense batch invalidates it, the+-- subsequent removal walks correctly, and the frozen mesh must rederive the+-- published identity cache from its final coordinate authority.+testBulkIdentityIndexDoesNotEscapeRemovalBatch :: IO ()+testBulkIdentityIndexDoesNotEscapeRemovalBatch = do+  let original = V.fromList (randomPoints 0x5a11ce 400)+      doomed = V.take 120 original+      survivors = V.drop 120 original+      arrival = Point (-0.25) 0.75+  baseBuild <- requireRight "bulk identity section base" (delaunay unitElementDefaults original)+  (_, edited, _) <-+    requireRight "bulk identity section mixed session" $+      withSession (buildTriangulation baseBuild) 1 $ do+        _ <- removeManyAt doomed+        _ <- insertVertexAt arrival arrival+        removeAt arrival >>= maybe (refuse (RemovalVertexOutOfRange (VertexId 0) 0)) (const (pure ()))+  fresh <- requireRight "bulk identity section fresh survivor rebuild" (delaunay unitElementDefaults survivors)+  assertEqual+    "bulk identity section mixed program equals fresh survivors"+    (canonicalEdges (buildTriangulation fresh))+    (canonicalEdges edited)+  assertValid "bulk identity section mixed session" edited+  case V.uncons survivors of+    Nothing -> fail "bulk identity section test has no survivor"+    Just (survivor, _) -> do+      located <- requireRight "published lazy identity lookup" (locateAndRemove edited survivor)+      case located of+        Nothing -> fail "published lazy identity lookup missed survivor"+        Just removal -> assertValid "published lazy identity removal" (removalTriangulation removal)++-- The hierarchy-hinted removal program must land exactly where the unhinted+-- session lands. The guesses are all computed against the original base, so+-- later removals in the batch answer for guesses whose slots swap-compaction+-- has renamed — the walk must correct every one of them. The repaired+-- hierarchy must equal the reference rebuild over the same survivor.+testHierarchyRemovalAgreement :: IO ()+testHierarchyRemovalAgreement = do+  let original = V.fromList (randomPoints 0x5eed1e55 400)+      base = buildTriangulation (either (error . show) id (delaunay unitElementDefaults original))+  hierarchy <- requireRight "hierarchy build" (buildHierarchyHint defaultHierarchyBranchFactor base)+  let run label doomed = do+        (outcomes, survived, repaired) <-+          requireRight (label <> " hinted removal") (removeManyWithHierarchy hierarchy base doomed)+        V.imapM_+          ( \index outcome ->+              maybe (fail (label <> " hinted removal missed index " <> show index)) (const (pure ())) outcome+          )+          outcomes+        (_, folded, _) <-+          requireRight (label <> " unhinted session") (withSession base 0 (removeManyAt doomed))+        reference <- requireRight (label <> " reference rebuild") (rebuildHierarchyHint hierarchy folded)+        assertEqual+          (label <> " hinted removal equals unhinted session")+          (canonicalEdges folded)+          (canonicalEdges survived)+        assertEqual (label <> " repaired hierarchy equals reference rebuild") reference repaired+        assertValid (label <> " hinted removal") survived+  run "sparse" (V.take 40 original)+  run "dense" (V.take 120 original)++testCircleSweepBulkLoad :: IO ()+testCircleSweepBulkLoad = do+  let points = V.fromList (randomPoints 0xc1ac1e 1500)+  swept <- requireRight "circle-sweep build" (delaunay unitElementDefaults points)+  (_, sessioned, _) <-+    requireRight "session build" $+      withSession (empty unitElementDefaults) (V.length points) $+        V.mapM_ insertVertex points+  assertEqual+    "circle-sweep/session topology"+    (canonicalEdges sessioned)+    (canonicalEdges (buildTriangulation swept))+  assertValid "circle-sweep build" (buildTriangulation swept)+  assertValid "session build" sessioned++testPredicates :: IO ()+testPredicates = do+  let rawA, rawB, rawC :: Point+      rawA = Point 0 0+      rawB = Point 1 0+      rawC = Point 0 1+  a <- requireRight "predicate point a" (mkQueryPoint rawA)+  b <- requireRight "predicate point b" (mkQueryPoint rawB)+  c <- requireRight "predicate point c" (mkQueryPoint rawC)+  midpointQuery <- requireRight "predicate midpoint" (mkQueryPoint (Point 0.5 0))+  inside <- requireRight "incircle inside point" (mkQueryPoint (Point 0.25 0.25))+  boundary <- requireRight "incircle boundary point" (mkQueryPoint (Point 1 1))+  outside <- requireRight "incircle outside point" (mkQueryPoint (Point 2 2))+  assertEqual "orientation left" GT (orient2d a b c)+  assertEqual "orientation right" LT (orient2d b a c)+  assertEqual "orientation collinear" EQ (orient2d a b midpointQuery)+  assertEqual "incircle inside" GT (inCircle a b c inside)+  assertEqual "incircle boundary" EQ (inCircle a b c boundary)+  assertEqual "incircle outside" LT (inCircle a b c outside)+  assertEqual "underflow mitigation" (Point 0 1) (mitigateUnderflow (Point 1.0e-44 1 :: Point))+  _ <- requireRight "point validation" (validatePoint Nothing (Point 0 1 :: Point))+  let large = encodeFloat 1 180 :: Double+      ulp = encodeFloat 1 128 :: Double+  largeA <- requireRight "large predicate point a" (mkQueryPoint (Point large large))+  largeB <- requireRight "large predicate point b" (mkQueryPoint (Point (large + ulp) large))+  largeC <- requireRight "large predicate point c" (mkQueryPoint (Point large (large + ulp)))+  largeD <- requireRight "large predicate point d" (mkQueryPoint (Point (large + ulp) (large + ulp)))+  assertEqual+    "large exact orientation"+    GT+    (orient2d largeA largeB largeC)+  assertEqual+    "large exact cocircularity"+    EQ+    (inCircle largeA largeB largeC largeD)++testHandlesAndFiniteDcel :: IO ()+testHandlesAndFiniteDcel = do+  built <- requirePointBuild "handle algebra" [Point 0 0, Point 3 0, Point 0 2, Point 0.4 0.7]+  let triangulation = buildTriangulation built+  assertValid "handle algebra" triangulation+  assertEqual "one outer face" (numInnerFaces triangulation + 1) (numFaces triangulation)+  forM_ (directedEdges triangulation) $ \edge -> do+    assertEqual "double reversal" edge (reverseEdge (reverseEdge edge))+    assertEqual "next/previous" edge (previous triangulation (next triangulation edge))+    assertEqual "previous/next" edge (next triangulation (previous triangulation edge))+  forM_ (undirectedEdges triangulation) $ \edge -> do+    let (forward, backward) = directedPair edge+    assertEqual "pair reversal" backward (reverseEdge forward)+    assertEqual "undirected projection" edge (asUndirected forward)+  assertEqual "vertex iterator" (numVertices triangulation) (length (vertices triangulation))+  assertEqual+    "dense vertex projection"+    (V.fromList (fmap (vertexPoint triangulation) (vertices triangulation)))+    (vertexPoints triangulation)+  assertEqual "edge iterator" (numUndirectedEdges triangulation) (length (undirectedEdges triangulation))+  assertEqual "face iterator" (numInnerFaces triangulation) (length (innerFaces triangulation))+  assertEqual+    "dense inner-face 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))+  assertEqual "dynamic vertex iterator" (numVertices triangulation) (length (DynamicIterators.vertexHandles triangulation))+  assertEqual "dynamic edge iterator" (numDirectedEdges triangulation) (length (DynamicIterators.directedEdgeHandles triangulation))+  assertEqual "dynamic face iterator" (numInnerFaces triangulation) (length (DynamicIterators.innerFaceHandles triangulation))+  unless (geometryTopologyBytes triangulation > topologyIndexBytes triangulation) $+    fail "geometry byte accounting omitted coordinates"+  vertex0 <- requireJust "dynamic vertex handle" (Dynamic.vertexHandle triangulation (VertexId 0))+  assertEqual "dynamic vertex fix" (VertexId 0) (Dynamic.fixVertex vertex0)+  assertEqual "dynamic vertex position" (vertexPoint triangulation (VertexId 0)) (Dynamic.vertexHandlePosition vertex0)+  case Dynamic.vertexHandleOutEdge vertex0 of+    Nothing -> fail "connected dynamic vertex has no outgoing edge"+    Just edge -> do+      assertEqual "dynamic edge reversal" (Dynamic.fixDirectedEdge edge) (Dynamic.fixDirectedEdge (Dynamic.directedEdgeReverse (Dynamic.directedEdgeReverse edge)))+      assertEqual "dynamic edge next/previous" (Dynamic.fixDirectedEdge edge) (Dynamic.fixDirectedEdge (Dynamic.directedEdgePrevious (Dynamic.directedEdgeNext edge)))+      let face = Dynamic.directedEdgeFace edge+      if Dynamic.faceIsOuter face+        then pure ()+        else case Dynamic.faceAsInner face of+          Nothing -> fail "non-outer dynamic face did not refine to InnerTag"+          Just inner -> do+            _ <- requireJust "inner dynamic face vertices" (Dynamic.innerFaceVertices inner)+            case Dynamic.innerFaceCircumcenter inner of+              Nothing -> fail "inner dynamic face has no circumcenter"+              Just _ -> pure ()++testDegenerateConstruction :: IO ()+testDegenerateConstruction = do+  emptyBuild <- requirePointBuild "empty" []+  emptyQuery <- requireQueryPoint "empty location" (Point 0 0)+  assertEqual "empty vertices" 0 (numVertices (buildTriangulation emptyBuild))+  assertEqual "empty location" EmptyTriangulation (locatePoint (buildTriangulation emptyBuild) emptyQuery)+  assertValid "empty" (buildTriangulation emptyBuild)++  singleton <- requirePointBuild "singleton" [Point 2 3]+  singletonQuery <- requireQueryPoint "singleton lookup" (Point 2 3)+  assertEqual "singleton lookup" (OnVertex (VertexId 0)) (locatePoint (buildTriangulation singleton) singletonQuery)+  assertValid "singleton" (buildTriangulation singleton)++  duplicates <- requirePointBuild "duplicates" [Point 0 0, Point 1 0, Point (-0.0) 0, Point 1 0, Point 2 0]+  assertEqual "deduplicated count" 3 (numVertices (buildTriangulation duplicates))+  assertEqual+    "stable duplicate mapping"+    (primArrayFromList [0, 1, 0, 1, 2])+    (buildInputVertices duplicates)+  assertValid "duplicates" (buildTriangulation duplicates)++  -- Deduplicating a signed zero is not the same claim as storing it canonically:+  -- the first only needs '==', which already identifies the two, while anything+  -- reading the bit pattern — a radix ordering, a byte-for-byte cross-check —+  -- reads the sign bit and gets a coordinate below every other. Both ingest+  -- paths canonicalize, and both are held to it here rather than to the weaker+  -- statement that comparison happens to survive.+  let bits point = (castDoubleToWord64 (pointX point), castDoubleToWord64 (pointY point))+  signedZero <- requirePointBuild "signed zero" [Point (-0.0) (-0.0), Point 1 0, Point 0 1]+  assertEqual "bulk load stores a canonical zero"+    (0, 0) (bits (vertexPoint (buildTriangulation signedZero) (VertexId 0)))+  incremental <-+    requireRight "signed zero insert"+      (insert (empty unitElementDefaults :: DelaunayTriangulation (Point)) (Point (-0.0) (-0.0)))+  assertEqual "insertion stores a canonical zero"+    (0, 0) (bits (vertexPoint (insertionTriangulation incremental) (VertexId 0)))++  traverse_+    assertBulkLine+    [ ("vertical", [Point 0 4, Point 0 0, Point 0 3, Point 0 2, Point 0 1])+    , ("horizontal reversed", reverse [Point x 7 | x <- [0 .. 8]])+    , ("oblique scrambled", [Point 3 8, Point (-2) (-2), Point 1 4, Point (-1) 0, Point 2 6, Point 0 2])+    , ("duplicate-bearing", [Point 2 5, Point 0 1, Point 1 3, Point 2 5, Point (-0.0) 1, Point 3 7])+    ]+  areaBase <- requirePointBuild "resident area before collinear batch" [Point 0 0, Point 4 0, Point 0 4]+  areaExtended <-+    requireRight+      "collinear batch into resident area"+      (insertMany (buildTriangulation areaBase) (V.fromList [Point 1 1, Point 2 2, Point 3 3]))+  assertEqual "resident area collinear batch count" 6 (numVertices (buildTriangulation areaExtended))+  assertValid "resident area collinear batch" (buildTriangulation areaExtended)+ where+  assertBulkLine (label, points) = do+    annotated <- requirePointBuild (label <> " annotated line") points+    geometry <- requireRight (label <> " geometry line") (delaunayGeometry (V.fromList points))+    batched <-+      requireRight+        (label <> " empty-base batch line")+        (insertMany (empty unitElementDefaults) (V.fromList points))+    let line = buildTriangulation annotated+        batchLine = buildTriangulation batched+        ascending = Set.toAscList (Set.fromList points)+        expectedEdges = Set.fromList (zip ascending (drop 1 ascending))+        uniqueCount = length ascending+        stats = buildStats annotated+    assertEqual (label <> " annotated edge set") expectedEdges (canonicalEdges line)+    assertEqual (label <> " geometry edge set") expectedEdges (canonicalEdges geometry)+    assertEqual (label <> " empty-base batch edge set") expectedEdges (canonicalEdges batchLine)+    assertEqual (label <> " edge count") (max 0 (uniqueCount - 1)) (numUndirectedEdges line)+    assertEqual (label <> " face count") 0 (numInnerFaces line)+    assertEqual (label <> " spatial seed count") uniqueCount (statSpatialSeedPoints stats)+    assertEqual (label <> " aggregate extension count") (max 0 (uniqueCount - 2)) (statLineExtensions stats)+    assertValid (label <> " annotated line") line+    assertValid (label <> " geometry line") geometry+    assertValid (label <> " empty-base batch line") batchLine++testPersistentLocalUpdates :: IO ()+testPersistentLocalUpdates = do+  base <- requirePointBuild "persistent base" (randomPoints 0x5eed 4095)+  let triangulation = buildTriangulation base+      query = Point 0.000_123 (-0.000_271)+  inserted <- requireRight "persistent insert" (insert triangulation query)+  assertEqual "persistent source remains unchanged" 4095 (numVertices triangulation)+  assertEqual "persistent result appends one vertex" 4096 (numVertices (insertionTriangulation inserted))+  assertValid "persistent insertion result" (insertionTriangulation inserted)++  let payloads = V.fromList+        [ SampleVertex (Point 0 0) 10+        , SampleVertex (Point 1 0) 20+        , SampleVertex (Point 0 1) 30+        ]+      defaults = ElementDefaults (0 :: Int) False ("face" :: String)+  payloadBuild <- requireRight "payload base" (delaunay defaults payloads)+  duplicate <- requireRight "payload-only replacement" (insert (buildTriangulation payloadBuild) (SampleVertex (Point 1 0) 99))+  assertEqual "payload update disposition" AlreadyPresent (insertionDisposition duplicate)+  assertEqual "payload replacement" 99 (sampleLabel (vertexData (insertionTriangulation duplicate) (VertexId 1)))++testGenericPayloads :: IO ()+testGenericPayloads = do+  let defaults = ElementDefaults (7 :: Int) False ("new-face" :: String)+      payloads = V.fromList+        [ SampleVertex (Point 0 0) 1+        , SampleVertex (Point 2 0) 2+        , SampleVertex (Point 0 2) 3+        , SampleVertex (Point 0.5 0.5) 4+        ]+  built <- requireRight "generic payload build" (delaunay defaults payloads)+  let triangulation = buildTriangulation built+  assertValid "generic payload build" triangulation+  assertEqual "vertex payload" 4 (sampleLabel (vertexData triangulation (VertexId 3)))+  forM_ (directedEdges triangulation) $ \edge -> assertEqual "directed default" 7 (directedEdgeData triangulation edge)+  forM_ (undirectedEdges triangulation) $ \edge -> assertEqual "undirected default" False (undirectedEdgeData triangulation edge)+  forM_ (allFaces triangulation) $ \face -> assertEqual "face default" "new-face" (faceData triangulation face)+  (firstEdge, firstFace) <- case (directedEdges triangulation, innerFaces triangulation) of+    (edge : _, face : _) -> pure (edge, face)+    _ -> fail "generic payload build produced no inner topology"+  let firstUndirected = asUndirected firstEdge+      changed = setFaceData (setUndirectedEdgeData (setDirectedEdgeData triangulation firstEdge 42) firstUndirected True) firstFace "changed"+  assertEqual "directed payload update" 42 (directedEdgeData changed firstEdge)+  assertEqual "undirected payload update" True (undirectedEdgeData changed firstUndirected)+  assertEqual "face payload update" "changed" (faceData changed firstFace)+  -- Geometry owns the points, so a payload carrying a different position is not+  -- a contradiction to be refused — it is a payload whose position nobody reads.+  let moved = setVertexData triangulation (VertexId 0) (SampleVertex (Point 9 9) 0)+  assertEqual "a payload position does not site a vertex"+    (vertexPoint triangulation (VertexId 0)) (vertexPoint moved (VertexId 0))+  assertEqual "the payload is stored as given"+    (Point 9 9) (samplePosition (vertexData moved (VertexId 0)))++-- The payload layer over a fixed geometry is a product of four free components.+-- Each is a functor and each is checked as such; nothing in the product can+-- disturb the geometry underneath it.+testPayloadMaps :: IO ()+testPayloadMaps = do+  let defaults = ElementDefaults (7 :: Int) ("new-undirected" :: String) ("new-face" :: String)+      payloads = V.fromList+        [ SampleVertex (Point 0 0) 1+        , SampleVertex (Point 4 0) 2+        , SampleVertex (Point 4 4) 3+        , SampleVertex (Point 0 4) 4+        , SampleVertex (Point 1 2) 5+        ]+  built <- requireRight "payload map build" (delaunay defaults payloads)+  let plain = buildTriangulation built+      -- Distinct payloads everywhere: a map that permuted its component would+      -- be invisible against uniform defaults.+      withDirected = List.foldl' (\t (label, edge) -> setDirectedEdgeData t edge label) plain (zip [100 ..] (directedEdges plain))+      withUndirected = List.foldl' (\t (label, edge) -> setUndirectedEdgeData t edge ("u-" <> show label)) withDirected (zip [(0 :: Int) ..] (undirectedEdges withDirected))+      sample = List.foldl' (\t (label, face) -> setFaceData t face ("f-" <> show label)) withUndirected (zip [(0 :: Int) ..] (allFaces withUndirected))+      endpoints ::+        Triangulation mode vertex directed undirected face ->+        [(VertexId, VertexId)]+      endpoints t = [(origin t edge, destination t edge) | edge <- directedEdges t]++  -- Identity. Equality on a triangulation compares geometry, topology,+  -- constraint flags and element defaults as well as payloads, so this single+  -- equation states that each map disturbs nothing but the component it names.+  assertEqual "mapDirectedEdges identity" sample (mapDirectedEdges id sample)+  assertEqual "mapUndirectedEdges identity" sample (mapUndirectedEdges id sample)+  assertEqual "mapFaces identity" sample (mapFaces id sample)+  assertEqual "mapVertices identity" sample (mapVertices id sample)++  assertEqual "mapDirectedEdges composition"+    (mapDirectedEdges ((* 2) . (+ 1)) sample)+    (mapDirectedEdges (* 2) (mapDirectedEdges (+ 1) sample))+  assertEqual "mapFaces composition"+    (mapFaces (("<" <>) . (<> ">")) sample)+    (mapFaces ("<" <>) (mapFaces (<> ">") sample))++  -- Commutation with the accessors. Identity and composition are blind to the+  -- indexing; this is the law that pins each payload to its own handle.+  let directedMapped = mapDirectedEdges (+ 1) sample+      undirectedMapped = mapUndirectedEdges ("<" <>) sample+      facesMapped = mapFaces ("<" <>) sample+  forM_ (directedEdges sample) $ \edge ->+    assertEqual "mapDirectedEdges commutes with directedEdgeData"+      (directedEdgeData sample edge + 1) (directedEdgeData directedMapped edge)+  forM_ (undirectedEdges sample) $ \edge ->+    assertEqual "mapUndirectedEdges commutes with undirectedEdgeData"+      ("<" <> undirectedEdgeData sample edge) (undirectedEdgeData undirectedMapped edge)+  forM_ (allFaces sample) $ \face ->+    assertEqual "mapFaces commutes with faceData"+      ("<" <> faceData sample face) (faceData facesMapped face)++  -- The components are independent, and none of them is geometry.+  assertEqual "face and directed maps commute"+    (mapFaces ("<" <>) (mapDirectedEdges (+ 1) sample))+    (mapDirectedEdges (+ 1) (mapFaces ("<" <>) sample))+  assertEqual "mapFaces preserves topology" (endpoints sample) (endpoints facesMapped)+  assertEqual "mapFaces preserves the face count" (numFaces sample) (numFaces facesMapped)+  forM_ (vertices sample) $ \vertex ->+    assertEqual "mapFaces preserves geometry" (vertexPoint sample vertex) (vertexPoint facesMapped vertex)++  -- The element default is a payload and must travel with them: every element a+  -- later insertion creates is handed the default, so a map that reindexed the+  -- stored payloads and left the default behind would produce a triangulation+  -- whose future elements disagree with its present ones. Every stored payload+  -- here differs from the default, so carrying the wrong one is visible.+  grownFaces <- insertionTriangulation <$> requireRight "insertion into mapped faces" (insert facesMapped (SampleVertex (Point 2 1) 6))+  grownUndirected <- insertionTriangulation <$> requireRight "insertion into mapped undirected edges" (insert undirectedMapped (SampleVertex (Point 2 1) 6))+  grownDirected <- insertionTriangulation <$> requireRight "insertion into mapped directed edges" (insert directedMapped (SampleVertex (Point 2 1) 6))+  unless (numFaces grownFaces > numFaces facesMapped) $ fail "the insertion created no face"+  unless ("<new-face" `elem` map (faceData grownFaces) (allFaces grownFaces)) $+    fail ("new faces did not receive the mapped default: " <> show (map (faceData grownFaces) (allFaces grownFaces)))+  unless ("<new-undirected" `elem` map (undirectedEdgeData grownUndirected) (undirectedEdges grownUndirected)) $+    fail "new undirected edges did not receive the mapped default"+  unless (8 `elem` map (directedEdgeData grownDirected) (directedEdges grownDirected)) $+    fail "new directed edges did not receive the mapped default"++  -- Vertices, the component that used to be special. The map is total, and the+  -- one thing worth insisting on is that a function which does its worst to the+  -- stored position still cannot move a vertex.+  let relabelled = mapVertices (\v -> v{sampleLabel = sampleLabel v * 10}) sample+      collapsed = mapVertices (\v -> v{samplePosition = Point 9 9}) sample+  forM_ (vertices sample) $ \vertex -> do+    assertEqual "mapVertices commutes with vertexData"+      (sampleLabel (vertexData sample vertex) * 10) (sampleLabel (vertexData relabelled vertex))+    assertEqual "mapVertices preserves geometry" (vertexPoint sample vertex) (vertexPoint relabelled vertex)+    assertEqual "a payload map cannot move a vertex"+      (vertexPoint sample vertex) (vertexPoint collapsed vertex)+  assertEqual "mapVertices composes"+    (mapVertices (\v -> v{sampleLabel = sampleLabel v + 1}) relabelled)+    (mapVertices (\v -> v{sampleLabel = sampleLabel v * 10 + 1}) sample)++  -- The sharpest statement of freedom available: the image type has no+  -- 'HasPosition' instance at all. This does not typecheck under a vertex+  -- component that geometry reads through.+  let projected = mapVertices sampleLabel sample+  forM_ (vertices sample) $ \vertex -> do+    assertEqual "a vertex payload need not have a position"+      (sampleLabel (vertexData sample vertex)) (vertexData projected vertex)+    assertEqual "projecting payloads away preserves geometry"+      (vertexPoint sample vertex) (vertexPoint projected vertex)++-- Geometry publication is payload forgetting, not a dense payload map.  The+-- polymorphic entrance accepts all four non-unit payload planes and publishes+-- zero materialized pages while retaining the exact structural planes.+testGeometryOnlyPublication :: IO ()+testGeometryOnlyPublication = do+  let defaults = ElementDefaults (17 :: Int) False ("source-face" :: String)+      payloads =+        V.fromList+          [ SampleVertex (Point 0 0) 11+          , SampleVertex (Point 4 0) 22+          , SampleVertex (Point 4 4) 33+          , SampleVertex (Point 0 4) 44+          , SampleVertex (Point 1 2) 55+          ]+  built <- requireRight "geometry-only payload source" (delaunay defaults payloads)+  let source = buildTriangulation built+      published = Internal.geometryOnlyPublication source+      republished = Internal.geometryOnlyPublication published+      structuralPlanes triangulation =+        ( Internal.triPointX triangulation+        , Internal.triPointY triangulation+        , Internal.triVertexOut triangulation+        , Internal.triHalfTopology triangulation+        , Internal.triFaceEdge triangulation+        , Internal.triConstraint triangulation+        , Internal.triConstraintCount triangulation+        , Internal.triConstraintEdges triangulation+        )+      payloadPageCounts triangulation =+        ( boxedMaterializedPageCount (Internal.triVertexData triangulation)+        , boxedMaterializedPageCount (Internal.triDirectedData triangulation)+        , boxedMaterializedPageCount (Internal.triUndirectedData triangulation)+        , boxedMaterializedPageCount (Internal.triFaceData triangulation)+        )+  unless (sumPayloadPages (payloadPageCounts source) > 0) $+    fail "geometry-only payload fixture did not materialize a source payload page"+  assertEqual+    "geometry-only publication preserves structural planes"+    (structuralPlanes source)+    (structuralPlanes published)+  assertEqual+    "geometry-only publication replaces every payload plane with a zero-page store"+    (0, 0, 0, 0)+    (payloadPageCounts published)+  assertEqual+    "geometry-only publication installs unit element defaults"+    unitElementDefaults+    (Internal.triElementDefaults published)+  assertEqual+    "geometry-only publication prepares the exact seam frontier"+    (Internal.prepareSeamFrontierIndex source)+    (Internal.triSeamFrontier published)+  assertEqual+    "geometry-only publication preserves an existing seam frontier"+    (Internal.triSeamFrontier published)+    (Internal.triSeamFrontier republished)+  assertValid "geometry-only publication" published+ where+  sumPayloadPages (vertexPages, directedPages, undirectedPages, facePages) =+    vertexPages + directedPages + undirectedPages + facePages+testPayloadTraversals :: IO ()+testPayloadTraversals = do+  let defaults = ElementDefaults (7 :: Int) ("new-undirected" :: String) ("new-face" :: String)+      payloads = V.fromList+        [ SampleVertex (Point 0 0) 1+        , SampleVertex (Point 4 0) 2+        , SampleVertex (Point 4 4) 3+        , SampleVertex (Point 0 4) 4+        , SampleVertex (Point 1 2) 5+        ]+  built <- requireRight "payload traversal build" (delaunay defaults payloads)+  let plain = buildTriangulation built+      withDirected = List.foldl' (\t (label, edge) -> setDirectedEdgeData t edge label) plain (zip [100 ..] (directedEdges plain))+      withUndirected = List.foldl' (\t (label, edge) -> setUndirectedEdgeData t edge ("u-" <> show label)) withDirected (zip [(0 :: Int) ..] (undirectedEdges withDirected))+      sample = List.foldl' (\t (label, face) -> setFaceData t face ("f-" <> show label)) withUndirected (zip [(0 :: Int) ..] (allFaces withUndirected))++  -- 'overPayloads' is the traversal under 'Identity', so this is the traversal+  -- identity law. It also says that rebuilding a payload store from its own+  -- contents is not observable, which is the part a paged store could get+  -- wrong: the traversal materializes pages the map would have left absent.+  assertEqual "vertexPayloads identity" sample (overPayloads vertexPayloads id sample)+  assertEqual "directedPayloads identity" sample (overPayloads directedPayloads id sample)+  assertEqual "undirectedPayloads identity" sample (overPayloads undirectedPayloads id sample)+  assertEqual "facePayloads identity" sample (overPayloads facePayloads id sample)++  -- Each traversal and its named map are one function. The effectful+  -- generalization is not allowed a second opinion about what relabeling means.+  assertEqual "vertexPayloads agrees with mapVertices"+    (mapVertices sampleLabel sample) (overPayloads vertexPayloads sampleLabel sample)+  assertEqual "directedPayloads agrees with mapDirectedEdges"+    (mapDirectedEdges (* 2) sample) (overPayloads directedPayloads (* 2) sample)+  assertEqual "undirectedPayloads agrees with mapUndirectedEdges"+    (mapUndirectedEdges ("<" <>) sample) (overPayloads undirectedPayloads ("<" <>) sample)+  assertEqual "facePayloads agrees with mapFaces"+    (mapFaces ("<" <>) sample) (overPayloads facePayloads ("<" <>) sample)++  assertEqual "facePayloads composes"+    (overPayloads facePayloads (("<" <>) . (<> ">")) sample)+    (overPayloads facePayloads ("<" <>) (overPayloads facePayloads (<> ">") sample))++  -- The class instances range over the face payload, being the last parameter.+  assertEqual "fmap is the face payload map" (mapFaces ("<" <>) sample) (fmap ("<" <>) sample)+  assertEqual "traverse is facePayloads"+    (Just (overPayloads facePayloads ("<" <>) sample))+    (traverse (Just . ("<" <>)) sample)+  assertEqual "the Foldable instance is the face traversal"+    (payloadList facePayloads sample) (foldr (:) [] sample)++  -- Visit order, and the element default's place in it. A fold that skipped+  -- the default would report the triangulation as holding one fewer face+  -- payload than it holds.+  assertEqual "vertexPayloads visits the vertices in order"+    (map (vertexData sample) (vertices sample))+    (payloadList vertexPayloads sample)+  assertEqual "facePayloads visits the faces and then the default"+    (map (faceData sample) (allFaces sample) <> [defaultFaceData (Internal.triElementDefaults sample)])+    (payloadList facePayloads sample)++  -- The point of the exercise: relabeling under an effect, with a refusal+  -- reaching the caller instead of a half-relabelled triangulation.+  let refuseAtThree :: SampleVertex -> Either String Int+      refuseAtThree v = if sampleLabel v == 3 then Left "vertex three refuses" else Right (sampleLabel v * 10)+      keepLabel :: SampleVertex -> Either String Int+      keepLabel = Right . sampleLabel+      decorate :: String -> Either String String+      decorate = Right . ("<" <>)+  assertEqual "an effectful relabel short-circuits"+    (Left "vertex three refuses") (vertexPayloads refuseAtThree sample)+  relabelled <- requireRight "effectful relabel" (vertexPayloads keepLabel sample)+  assertEqual "a successful effectful relabel is the pure one"+    (mapVertices sampleLabel sample) relabelled++  -- The default travels through the traversal, and travels exactly once: the+  -- store's fill and the element defaults are written from a single visit, so+  -- an element created afterwards inherits precisely what the traversal made.+  traversedFaces <- requireRight "effectful face relabel" (facePayloads decorate sample)+  grown <- insertionTriangulation <$> requireRight "insertion after traversal" (insert traversedFaces (SampleVertex (Point 2 1) 6))+  unless (numFaces grown > numFaces traversedFaces) $ fail "the insertion created no face"+  unless ("<new-face" `elem` map (faceData grown) (allFaces grown)) $+    fail ("new faces did not receive the traversed default: " <> show (map (faceData grown) (allFaces grown)))++-- | The in-circle predicate is the orientation of the four points lifted to+-- the paraboloid @z = x² + y²@. The referent is that 4×4 determinant evaluated+-- exactly over 'Rational' — deliberately not the translated 3×3 the instances+-- expand, which would only be the implementation checking its own algebra.+testParaboloidLift :: IO ()+testParaboloidLift = do+  let lifted :: Point -> (Rational, Rational, Rational)+      lifted (Point x y) =+        let (rx, ry) = (toRational x, toRational y) in (rx, ry, rx * rx + ry * ry)+      minor3+        :: (Rational, Rational, Rational)+        -> (Rational, Rational, Rational)+        -> (Rational, Rational, Rational)+        -> Rational+      minor3 (a1, a2, a3) (b1, b2, b3) (c1, c2, c3) =+        a1 * (b2 * c3 - b3 * c2) - a2 * (b1 * c3 - b3 * c1) + a3 * (b1 * c2 - b2 * c1)+      -- Laplace expansion of the lifted determinant along its column of ones.+      liftedOrientation+        :: (Rational, Rational, Rational)+        -> (Rational, Rational, Rational)+        -> (Rational, Rational, Rational)+        -> (Rational, Rational, Rational)+        -> Rational+      liftedOrientation a b c d =+        negate (minor3 b c d) + minor3 a c d - minor3 a b d + minor3 a b c+      predicted :: Point -> Point -> Point -> Point -> Ordering+      predicted a b c d = compare (liftedOrientation (lifted a) (lifted b) (lifted c) (lifted d)) 0+      measured :: Point -> Point -> Point -> Point -> Ordering+      measured (Point ax ay) (Point bx by) (Point cx cy) (Point dx dy) =+        Admitted.inCircleCoordinates ax ay bx by cx cy dx dy+      quadruples :: [Point] -> [(Point, Point, Point, Point)]+      quadruples (a : b : c : d : rest) = (a, b, c, d) : quadruples rest+      quadruples _ = []++  forM_ (quadruples (randomPoints 0x51ca_0b17 1600)) $ \(a, b, c, d) ->+    assertEqual ("in-circle is the lifted orientation at " <> show (a, b, c, d))+      (predicted a b c d) (measured a b c d)++  -- Exactly cocircular quadruples, which are exactly the ones the floating+  -- filter must decline to answer. Every Pythagorean point of the radius-5+  -- circle is representable without rounding, so 'EQ' here is a fact about the+  -- geometry rather than about the arithmetic.+  let ring =+        [ Point x y+        | (x, y) <-+            [ (5, 0), (0, 5), (-5, 0), (0, -5)+            , (3, 4), (4, 3), (-3, 4), (-4, 3)+            , (3, -4), (4, -3), (-3, -4), (-4, -3)+            ]+        ] :: [Point]+      indexed = zip [(0 :: Int) ..] ring+      cocircular =+        [ (a, b, c, d)+        | (i, a) <- indexed, (j, b) <- indexed, j > i+        , (k, c) <- indexed, k > j, (l, d) <- indexed, l > k+        ]+  unless (length cocircular == 495) $ fail ("expected 495 cocircular quadruples, got " <> show (length cocircular))+  forM_ cocircular $ \(a, b, c, d) -> do+    assertEqual ("cocircular points are cocircular at " <> show (a, b, c, d)) EQ (measured a b c d)+    assertEqual ("the lift agrees on cocircularity at " <> show (a, b, c, d)) EQ (predicted a b c d)++  -- The geometry the sign means, stated once against a circle anyone can read.+  let (a, b, c) = (Point 1 0, Point 0 1, Point (-1) 0) :: (Point, Point, Point)+  assertEqual "the centre is inside the circle" GT (measured a b c (Point 0 0))+  assertEqual "the antipode is on the circle" EQ (measured a b c (Point 0 (-1)))+  assertEqual "a distant point is outside" LT (measured a b c (Point 2 2))++-- | A payload labels an element, and an element is its geometry. Every rewrite+-- an insertion performs — an edge split, a face split, a Lawson flip — hands+-- some slot a different element to hold, and the label the displaced one+-- carried does not describe what took its place.+--+-- So: label every element of a triangulation by its own key, insert a point,+-- and demand that an element whose key survives still carries exactly the label+-- it was given while every element whose key is new carries the default and+-- nothing else. Both directions are checked; either alone is satisfiable by a+-- store that throws everything away.+--+-- The flip is the load-bearing case. Legalization is confluent, so which flips+-- fire and in what order is not observable in the topology that comes out. A+-- payload that rode through a flip would make it observable in the payload+-- plane, and a triangulation that is a normal form in one component and a+-- history in another is not a normal form.+testRewritePayloadIdentity :: IO ()+testRewritePayloadIdentity = do+  let defaults = ElementDefaults (0 :: Int) (0 :: Int) (0 :: Int)+      target = Point 0.001_37 (-0.002_11)+      corpus = randomPoints 0x1a2b3c4d 512+  built <- requireRight "rewrite identity base" (delaunay defaults (V.fromList corpus))+  let base = buildTriangulation built+      directedTable = labelTable (map (directedKeyOf base) (directedEdges base))+      undirectedTable = labelTable (map (undirectedKeyOf base) (undirectedEdges base))+      faceTable = labelTable (map (faceKeyOf base) (innerFaces base))++  -- Keys identify elements only if they are unique, so the premise is checked+  -- rather than assumed: a collapsed table would silently weaken everything+  -- below it into a test of nothing.+  assertEqual "directed keys are unique" (length (directedEdges base)) (Map.size directedTable)+  assertEqual "undirected keys are unique" (length (undirectedEdges base)) (Map.size undirectedTable)+  assertEqual "face keys are unique" (length (innerFaces base)) (Map.size faceTable)++  let withDirected =+        List.foldl' (\t e -> setDirectedEdgeData t e (directedTable Map.! directedKeyOf base e)) base (directedEdges base)+      withUndirected =+        List.foldl' (\t e -> setUndirectedEdgeData t e (undirectedTable Map.! undirectedKeyOf base e)) withDirected (undirectedEdges base)+      labelled =+        List.foldl' (\t f -> setFaceData t f (faceTable Map.! faceKeyOf base f)) withUndirected (innerFaces base)+  inserted <- requireRight "rewrite identity insert" (insert labelled target)+  let result = insertionTriangulation inserted+  assertValid "rewrite identity result" result+  assertEqual "the point was genuinely inserted" Inserted (insertionDisposition inserted)++  -- Both directions, on every plane. A surviving element keeps exactly its+  -- label; everything else holds the default and nothing else.+  assertPayloadSurvival "directed" directedTable+    [(directedKeyOf result e, directedEdgeData result e) | e <- directedEdges result]+  assertPayloadSurvival "undirected" undirectedTable+    [(undirectedKeyOf result e, undirectedEdgeData result e) | e <- undirectedEdges result]+  assertPayloadSurvival "face" faceTable+    [(faceKeyOf result f, faceData result f) | f <- innerFaces result]++  -- The flip signature. Every flip after an insertion joins the new vertex to+  -- the far corner of a cavity quad, so a new edge is not evidence of one — a+  -- split produces those too. A DESTROYED edge is: splitting a face destroys+  -- nothing and adds exactly three edges and two faces, which is asserted here+  -- so that the arithmetic holds, and under it every base key that is gone from+  -- the result was flipped away. Without this the paragraphs above are a claim+  -- about splits alone.+  assertEqual "the point landed strictly inside a face"+    (numUndirectedEdges base + 3, numFaces base + 2)+    (numUndirectedEdges result, numFaces result)+  let surviving = Set.fromList (map (undirectedKeyOf result) (undirectedEdges result))+      flippedAway = filter (`Set.notMember` surviving) (Map.keys undirectedTable)+  when (null flippedAway) (fail "the insertion caused no flip, so the flip case went unchecked")++  -- The same claim across one transaction that both retires and creates.+  -- Removal swap-compacts, which leaves a retired element's payload sitting in+  -- the slot it vacated; the inserts that follow are handed those slots back.+  -- Nothing else in the suite makes an allocation reissue a used slot.+  let doomed = take 60 corpus+      arrivals = randomPoints 0x5f3a19c2 60+  (_, edited, _) <-+    requireRight "rewrite identity session" $+      withSession labelled (length arrivals) $ do+        mapM_+          (\point -> removeAt point >>= maybe (refuse (RemovalVertexOutOfRange (VertexId 0) 0)) (const (pure ())))+          doomed+        mapM_ insertVertex arrivals+  assertValid "rewrite identity session" edited+  assertPayloadSurvival "session directed" directedTable+    [(directedKeyOf edited e, directedEdgeData edited e) | e <- directedEdges edited]+  assertPayloadSurvival "session undirected" undirectedTable+    [(undirectedKeyOf edited e, undirectedEdgeData edited e) | e <- undirectedEdges edited]+  assertPayloadSurvival "session face" faceTable+    [(faceKeyOf edited f, faceData edited f) | f <- innerFaces edited]++directedKeyOf+  :: Triangulation mode vertex directed undirected face+  -> DirectedEdgeId+  -> (Point, Point)+directedKeyOf triangulation edge =+  ( vertexPoint triangulation (origin triangulation edge)+  , vertexPoint triangulation (destination triangulation edge)+  )++undirectedKeyOf+  :: Triangulation mode vertex directed undirected face+  -> UndirectedEdgeId+  -> (Point, Point)+undirectedKeyOf triangulation edge =+  case undirectedEndpoints triangulation edge of+    (from, to) ->+      let (left, right) = (vertexPoint triangulation from, vertexPoint triangulation to)+       in if left <= right then (left, right) else (right, left)++faceKeyOf+  :: Triangulation mode vertex directed undirected face+  -> FaceId+  -> [Point]+faceKeyOf triangulation face = sort (map (vertexPoint triangulation) (faceVertices triangulation face))++labelTable :: Ord key => [key] -> Map.Map key Int+labelTable keys = Map.fromList (zip keys [1 ..])++-- | Every element carries the label its key was given, or the default if its+-- key is new. Both counts are asserted too: a store that kept everything and a+-- store that kept nothing each satisfy one half of this on its own.+assertPayloadSurvival :: (Ord key, Show key) => String -> Map.Map key Int -> [(key, Int)] -> IO ()+assertPayloadSurvival plane labels elements = do+  let kept = length (filter ((`Map.member` labels) . fst) elements)+  when (kept == 0) (fail (plane <> ": the insertion perturbed every element"))+  when (kept == length elements) (fail (plane <> ": the insertion perturbed no element"))+  forM_ elements $ \(key, payload) ->+    assertEqual (plane <> " label at " <> show key) (Map.findWithDefault 0 key labels) payload++testPointLocationAndHints :: IO ()+testPointLocationAndHints = do+  built <- requirePointBuild "location" (randomPoints 0x1234_5678 1200)+  let triangulation = buildTriangulation built+  queries <- traverse (requireQueryPoint "location query") (take 250 (randomPoints 0xdead_beef 250))+  let+      baseline = sum [locationWalkSteps stats | query <- queries, let (_, stats) = locatePointWithHint triangulation Nothing query]+  hierarchy <- requireRight "hierarchy build" (buildHierarchyHint 16 triangulation)+  let hinted = sum+        [ locationWalkSteps stats+        | query <- queries+        , let hint = hierarchyHint hierarchy query+              (_, stats) = locatePointWithHint triangulation hint query+        ]+  unless (hinted <= baseline) $+    fail ("hierarchy hint increased aggregate walking: " <> show (baseline, hinted))+  staleHintQuery <- requireQueryPoint "stale hint query" (Point 0.125 (-0.375))+  let staleVertexHint = VertexHint (VertexId (fromIntegral (numVertices triangulation)))+  assertEqual+    "stale vertex hint falls back to the canonical start face"+    (locatePointWithHint triangulation Nothing staleHintQuery)+    (locatePointWithHint triangulation (Just staleVertexHint) staleHintQuery)+  forM_ (vertices triangulation) $ \vertex -> do+    vertexQuery <- requireQueryPoint "vertex lookup" (vertexPoint triangulation vertex)+    assertEqual "vertex lookup" (OnVertex vertex) (locatePoint triangulation vertexQuery)+  let insertedPoint = Point 0.1234567 (-0.2345678)+  inserted <- requireRight "hierarchy incremental source" (insert triangulation insertedPoint)+  let updatedTriangulation = insertionTriangulation inserted+  updatedHierarchy <-+    requireRight+      "hierarchy incremental update"+      ( updateHierarchyAfterInsertion+          hierarchy+          insertedPoint+          (insertionVertex inserted)+          (insertionDisposition inserted)+      )+  rebuiltHierarchy <- requireRight "hierarchy reference rebuild" (buildHierarchyHint 16 updatedTriangulation)+  assertEqual "incremental hierarchy equals canonical rebuild" rebuiltHierarchy updatedHierarchy++-- The hierarchy replaces its level-to-base correspondence with the arithmetic+-- claim that level-local handle @j@ names base vertex @j * branch@. Query each+-- sampled vertex with its own position: the descent must return that very+-- vertex, at every branch factor and along the whole of level 0. A stride the+-- construction does not actually obey shows up here as a named mismatch.+testHierarchyNestingLaw :: IO ()+testHierarchyNestingLaw = do+  built <- requirePointBuild "hierarchy nesting" (randomPoints 0x0f1e_2d3c 900)+  let triangulation = buildTriangulation built+  forM_ [2, 3, 16] $ \branch -> do+    hierarchy <- requireRight ("hierarchy build at branch " <> show branch) (buildHierarchyHint branch triangulation)+    let sampled = [0, branch .. numVertices triangulation - 1]+    forM_ sampled $ \index -> do+      let vertex = VertexId (fromIntegral index)+      vertexQuery <- requireQueryPoint "sampled hierarchy vertex" (vertexPoint triangulation vertex)+      assertEqual+        ("branch " <> show branch <> " descent onto sampled vertex " <> show index)+        (Just (VertexHint vertex))+        (hierarchyHint hierarchy vertexQuery)++testSibsonInterpolation :: IO ()+testSibsonInterpolation = do+  built <- requirePointBuild "sibson" (gridPoints 9 9)+  let triangulation = buildTriangulation built+      queryPoint = Point 3.25 4.4+      linear vertex = let Point x y = vertexPoint triangulation vertex in 2 * x - 3 * y + 5+      expected = let Point x y = queryPoint in 2 * x - 3 * y + 5+  query <- requireQueryPoint "Sibson query" queryPoint+  workspace <- stToIO (newNaturalNeighborWorkspace triangulation)+  result <- stToIO (naturalNeighborWeights workspace Nothing query)+  let weights = naturalNeighborValues result+  unless (V.length weights >= 3) $ fail "Sibson query did not discover a natural-neighbor cavity"+  assertNear "Sibson partition" 1.0e-11 1 (V.sum (V.map snd weights))+  unless (V.all ((>= (-1.0e-12)) . snd) weights) $ fail "Sibson produced a negative weight"+  (folded, _, foldedStats) <- stToIO (foldNaturalNeighborWeights+    (\total vertex weight -> total + weight * linear vertex)+    0+    workspace+    Nothing+    query)+  assertNear "allocation-free Sibson fold" 2.0e-9 expected folded+  assertEqual "Sibson fold neighbor count" (V.length weights) (interpolationNaturalNeighbors foldedStats)+  (interpolated, _) <- stToIO (interpolateNaturalNeighbor linear workspace Nothing query)+  case interpolated of+    Nothing -> fail "Sibson interpolation rejected an interior query"+    Just value -> assertNear "Sibson affine precision" 2.0e-9 expected value+  let gradients = estimateGradients linear triangulation+  V.forM_ gradients $ \(gx, gy) -> do+    assertNear "planar gradient x" 1.0e-9 2 gx+    assertNear "planar gradient y" 1.0e-9 (-3) gy+  let gradient (VertexId raw) = gradients V.! fromIntegral raw+  (gradientValue, _) <- stToIO (interpolateNaturalNeighborGradient linear gradient 0.5 workspace Nothing query)+  case gradientValue of+    Nothing -> fail "gradient natural-neighbor interpolation rejected an interior query"+    Just value -> assertNear "gradient affine precision" 2.0e-9 expected value+  unless (workspaceBytes workspace > 0) $ fail "Sibson workspace byte accounting is empty"++testVoronoiDual :: IO ()+testVoronoiDual = do+  built <- requirePointBuild "voronoi" [Point 0 0, Point 2 0, Point 0 2, Point 2 2, Point 1 1]+  let triangulation = buildTriangulation built+  assertEqual "Voronoi face count" (numVertices triangulation) (length (voronoiFaces triangulation))+  assertEqual "directed dual edge count" (numDirectedEdges triangulation) (length (directedVoronoiEdges triangulation))+  assertEqual "undirected dual edge count" (numUndirectedEdges triangulation) (length (undirectedVoronoiEdges triangulation))+  forM_ (directedVoronoiEdges triangulation) $ \edge -> do+    assertEqual "dual double reversal" edge (reverseVoronoiEdge (reverseVoronoiEdge edge))+    assertEqual "dual next/previous" edge (voronoiPrevious triangulation (voronoiNext triangulation edge))+    assertEqual+      "dual face/site"+      (origin triangulation (asDelaunayDirectedEdge edge))+      (voronoiFaceSite (voronoiIncidentFace triangulation edge))+    case voronoiEdgeGeometry triangulation edge of+      Nothing -> fail "valid dual edge has no geometry"+      fixedGeometry@(Just _) -> do+        owning <- requireJust "dynamic Voronoi edge" (VoronoiDynamic.directedVoronoiEdgeHandle triangulation edge)+        assertEqual "fixed/owning dual geometry" fixedGeometry (VoronoiDynamic.voronoiEdgeGeometryH owning)+  case directedVoronoiEdges triangulation of+    [] -> fail "Voronoi test produced no directed dual edge"+    first : _ -> do+      handle <- requireJust "dynamic Voronoi edge" (VoronoiDynamic.directedVoronoiEdgeHandle triangulation first)+      assertEqual "dynamic dual fix" first (VoronoiDynamic.fixDirectedVoronoiEdge handle)+      assertEqual "dynamic dual reversal" first (VoronoiDynamic.fixDirectedVoronoiEdge (VoronoiDynamic.voronoiEdgeReverseH (VoronoiDynamic.voronoiEdgeReverseH handle)))+      assertEqual "dynamic dual/primal conversion" (asDelaunayDirectedEdge first) (Dynamic.fixDirectedEdge (VoronoiDynamic.voronoiEdgeAsDelaunayH handle))+      let dualFace = VoronoiDynamic.voronoiEdgeFaceH handle+      assertEqual "dynamic dual face site" (origin triangulation (asDelaunayDirectedEdge first)) (Dynamic.fixVertex (VoronoiDynamic.voronoiFaceSiteH dualFace))+      let source = VoronoiDynamic.voronoiEdgeFromH handle+      case VoronoiDynamic.voronoiVertexAsDelaunayFaceH source of+        Just inner -> case VoronoiDynamic.voronoiVertexPositionH source of+          Nothing -> fail "inner dynamic Voronoi vertex has no position"+          Just voronoiPosition -> assertEqual "inner dynamic Voronoi position" (Dynamic.innerFaceCircumcenter inner) (Just voronoiPosition)+        Nothing -> unless (isJust (VoronoiDynamic.voronoiVertexAsOuterEdgeH source)) $+          fail "outer dynamic Voronoi vertex has no defining edge"++testRemoval :: IO ()+testRemoval = do+  built <- requirePointBuild "removal" [Point 0 0, Point 3 0, Point 3 3, Point 0 3, Point 1.5 1.5]+  let triangulation = buildTriangulation built+  assertEqual+    "out-of-range removal obstruction"+    (Left (RemovalVertexOutOfRange (VertexId 5) 5))+    (void (removeVertex triangulation (VertexId 5)))+  removedInterior <- requireRight "interior removal" (removeVertex triangulation (VertexId 4))+  assertEqual "interior removed point" (Point 1.5 1.5) (removalOutcomePoint (removalOutcome removedInterior))+  assertEqual "interior removal count" 4 (numVertices (removalTriangulation removedInterior))+  assertValid "interior removal" (removalTriangulation removedInterior)+  let beforeHullRemoval = removalTriangulation removedInterior+      previousLastVertex = VertexId (fromIntegral (numVertices beforeHullRemoval - 1))+      swappedPoint = vertexPoint beforeHullRemoval previousLastVertex+      swappedData = vertexData beforeHullRemoval previousLastVertex+  removedHull <- requireRight "hull removal" (removeVertex beforeHullRemoval (VertexId 0))+  assertEqual "hull removal count" 3 (numVertices (removalTriangulation removedHull))+  case removalOutcomeSwap (removalOutcome removedHull) of+    Nothing -> fail "hull removal omitted the swap-compacted vertex handle"+    Just (swappedIn, swappedInPoint) -> do+      assertEqual "hull swapped-in handle" (VertexId 0) swappedIn+      assertEqual "hull swapped-in point" swappedPoint (vertexPoint (removalTriangulation removedHull) swappedIn)+      assertEqual "hull swapped-in payload" swappedData (vertexData (removalTriangulation removedHull) swappedIn)+      -- The reported position must be the one the arena now holds, bit for+      -- bit: a caller seeding a search from it is seeding from the mesh.+      assertEqual "hull swapped-in reported position" swappedPoint swappedInPoint+  assertValid "hull removal" (removalTriangulation removedHull)++  let afterHullRemoval = removalTriangulation removedHull+      lastVertex = VertexId (fromIntegral (numVertices afterHullRemoval - 1))+  removedLast <- requireRight "last-vertex removal" (removeVertex afterHullRemoval lastVertex)+  assertEqual+    "removing the last vertex relocates nothing"+    Nothing+    (removalOutcomeSwap (removalOutcome removedLast))+  assertEqual "last-vertex removal count" 2 (numVertices (removalTriangulation removedLast))+  assertValid "last-vertex removal" (removalTriangulation removedLast)++  lineBuild <- requirePointBuild "line removal" [Point 0 0, Point 1 0, Point 2 0, Point 3 0]+  lineMiddle <- requireRight "line middle removal" (removeVertex (buildTriangulation lineBuild) (VertexId 1))+  assertEqual "line middle count" 3 (numVertices (removalTriangulation lineMiddle))+  assertValid "line middle removal" (removalTriangulation lineMiddle)++  degreeThreeBuild <-+    requirePointBuild+      "degree-three removal"+      [Point 0 0, Point 4 0, Point 0 4, Point 1 1]+  let degreeThreeMapping = buildInputVertices degreeThreeBuild+  case if 3 < sizeofPrimArray degreeThreeMapping+        then Just (VertexId (indexPrimArray degreeThreeMapping 3))+        else Nothing of+    Nothing -> fail "degree-three removal input mapping omitted the interior vertex"+    Just centerVertex -> do+      degreeThree <-+        requireRight+          "degree-three interior removal"+          (removeVertex (buildTriangulation degreeThreeBuild) centerVertex)+      assertEqual "degree-three removal count" 3 (numVertices (removalTriangulation degreeThree))+      assertValid "degree-three interior removal" (removalTriangulation degreeThree)++  -- A removal hands its vertex's whole ring to edge/face cleanup, so a+  -- high-degree star is the only shape that exercises the ordered-set path+  -- there; an ordinary mesh keeps degrees near six and never leaves the+  -- insertion sort. Radii are jittered so no four rim points are cocircular.+  let rimCount = 48+      rimPoint index =+        let angle = 2 * pi * fromIntegral index / fromIntegral rimCount+            radius = 1 + 0.001 * fromIntegral (index `mod` 7)+         in Point (radius * cos angle) (radius * sin angle)+  starBuild <-+    requirePointBuild+      "high-degree removal"+      (Point 0 0 : map rimPoint [0 .. rimCount - 1])+  let starTriangulation = buildTriangulation starBuild+      starCentre = VertexId (indexPrimArray (buildInputVertices starBuild) 0)+      centreDegree =+        length+          [ ()+          | edge <- undirectedEdges starTriangulation+          , let (from, to) = undirectedEndpoints starTriangulation edge+          , from == starCentre || to == starCentre+          ]+  assertEqual "high-degree centre ring" rimCount centreDegree+  starRemoved <-+    requireRight "high-degree interior removal" (removeVertex starTriangulation starCentre)+  assertEqual "high-degree removal count" rimCount (numVertices (removalTriangulation starRemoved))+  assertEqual+    "high-degree removed point"+    (Point 0 0)+    (removalOutcomePoint (removalOutcome starRemoved))+  assertValid "high-degree interior removal" (removalTriangulation starRemoved)++  -- A transaction that refuses publishes nothing: the refusal is the whole+  -- answer, so no half-remeshed arena can reach a caller as a triangulation.+  let sessionRefusal = RemovalVertexOutOfRange (VertexId 99) 5+  assertEqual+    "a refused session publishes nothing"+    (Left sessionRefusal)+    (void (withSession triangulation 1 (refuse sessionRefusal :: Session s (Point) () () () ())))++  -- Refusal short-circuits: an edit after it never runs, so the mesh the+  -- transaction abandoned is the mesh it was handed.+  assertEqual+    "a refusal abandons the edits behind it"+    (Left sessionRefusal)+    ( void+        ( withSession+            triangulation+            1+            ( ( do+                  _ <- removeAt (Point 0 0)+                  _ <- refuse sessionRefusal+                  removeAt (Point 1 1)+              ) ::+                Session s (Point) () () () (Maybe (RemovalOutcome (Point)))+            )+        )+    )++  -- The two point-keyed entries must publish one story. A handle-keyed removal+  -- locates nothing, while the coordinate-keyed route resolves the same site+  -- through the exact derived identity section rather than a topological walk.+  -- Both therefore charge no location steps and retire the same vertex.+  handleRemoval <- requireRight "handle removal stats" (removeVertex triangulation (VertexId 4))+  assertEqual+    "a handle-keyed removal locates nothing"+    0+    (statLocationWalkSteps (removalStats handleRemoval))+  locatedRemoval <-+    requireRight "point removal stats" (locateAndRemove triangulation (Point 1.5 1.5))+  pointRemoval <- requireJust "point removal located a vertex" locatedRemoval+  assertEqual+    "a point-keyed removal performs no topological location walk"+    0+    (statLocationWalkSteps (removalStats pointRemoval))+  assertEqual+    "point-keyed and handle-keyed removal publish the same mesh"+    (canonicalEdges (removalTriangulation handleRemoval))+    (canonicalEdges (removalTriangulation pointRemoval))++testConstrainedDelaunay :: IO ()+testConstrainedDelaunay = do+  base <- requirePointBuild "CDT base" [Point 0 0, Point 4 0, Point 4 4, Point 0 4, Point 1 1, Point 3 3, Point 1 3, Point 3 1]+  let cdt0 = fromDelaunay (buildTriangulation base)+      invalidPoint = Point (0 / 0) 0+  case addConstraintEdge cdt0 invalidPoint (Point 4 0) of+    Left (CdtBuildError (InvalidCoordinate Nothing _ CoordinateNaN)) -> pure ()+    outcome -> fail ("invalid first constraint endpoint was admitted: " <> either show (const "success") outcome)+  case addConstraintEdge cdt0 (Point 0 0) invalidPoint of+    Left (CdtBuildError (InvalidCoordinate Nothing _ CoordinateNaN)) -> pure ()+    outcome -> fail ("invalid second constraint endpoint was admitted: " <> either show (const "success") outcome)+  assertEqual+    "invalid endpoint refusal leaves the immutable source unpublished"+    (8, 0)+    (numVertices cdt0, numConstraints cdt0)+  partlyResident <-+    requireRight+      "one resident one new constraint endpoint"+      (addConstraintEdge cdt0 (Point 0 0) (Point 2 2))+  let partlyResidentCdt = constraintRecoveryTriangulation partlyResident+  assertEqual+    "one resident endpoint reserves only the missing site"+    (numVertices cdt0 + 1)+    (numVertices partlyResidentCdt)+  assertCdtValid "one resident one new constraint endpoint" partlyResidentCdt+  diagonalBatch <-+    requireRight+      "constraint recovery"+      (recoverConstraints cdt0 (V.singleton (VertexId 0, VertexId 2)))+  (diagonalPath, diagonalAdded) <-+    requireAcceptedConstraint "constraint recovery" diagonalBatch+  let cdt1 = constraintBatchTriangulation diagonalBatch+  when (V.null diagonalPath) $ fail "constraint recovery returned an empty path"+  assertEqual "constraint count" diagonalAdded (numConstraints cdt1)+  assertCdtValid "constraint recovery" cdt1+  conflictBatch <-+    requireRight+      "atomic conflict"+      (recoverConstraints cdt1 (V.singleton (VertexId 1, VertexId 3)))+  case V.toList (constraintBatchOutcomes conflictBatch) of+    [ConstraintRejected _] -> pure ()+    outcomes ->+      fail+        ( "crossing constraint was not rejected atomically: "+            <> show outcomes+        )+  assertEqual+    "crossing rejection preserves topology"+    cdt1+    (constraintBatchTriangulation conflictBatch)+  let constraintProgram =+        V.fromList+          [ (VertexId 0, VertexId 2)+          , (VertexId 1, VertexId 3)+          , (VertexId 4, VertexId 6)+          ]+  wholeProgram <-+    requireRight+      "whole constraint program"+      (recoverConstraints cdt0 constraintProgram)+  (singletonTriangulation, singletonOutcomes) <-+    requireRight+      "singleton constraint program"+      (V.foldM' replayConstraintRequest (cdt0, []) constraintProgram)+  assertEqual+    "batch outcomes equal singleton descent"+    (V.toList (constraintBatchOutcomes wholeProgram))+    (reverse singletonOutcomes)+  assertEqual+    "batch topology equals singleton descent"+    singletonTriangulation+    (constraintBatchTriangulation wholeProgram)+  assertBatchStats "whole constraint program" wholeProgram+  forM_ [0 .. 7 :: Int] $ \batchIndex -> do+    randomizedBuild <-+      requirePointBuild+        ("random constraint batch " <> show batchIndex)+        (randomPoints (0x6a09_e667_f3bc_c909 + fromIntegral batchIndex) 40)+    let randomizedBase = fromDelaunay (buildTriangulation randomizedBuild)+        mapping = buildInputVertices randomizedBuild+        handles = V.generate (sizeofPrimArray mapping) (VertexId . indexPrimArray mapping)+        requests = V.take 18 (V.zip handles (V.reverse handles))+    randomizedBatch <-+      requireRight+        ("random whole constraint batch " <> show batchIndex)+        (recoverConstraints randomizedBase requests)+    (randomizedSingleton, randomizedOutcomes) <-+      requireRight+        ("random singleton constraint batch " <> show batchIndex)+        (V.foldM' replayConstraintRequest (randomizedBase, []) requests)+    assertEqual+      ("random batch outcomes equal singleton descent " <> show batchIndex)+      (V.toList (constraintBatchOutcomes randomizedBatch))+      (reverse randomizedOutcomes)+    assertEqual+      ("random batch topology equals singleton descent " <> show batchIndex)+      randomizedSingleton+      (constraintBatchTriangulation randomizedBatch)+    assertBatchStats+      ("random constraint batch " <> show batchIndex)+      randomizedBatch+    assertCdtValid+      ("random constraint batch " <> show batchIndex)+      (constraintBatchTriangulation randomizedBatch)+  -- Batch admission returns the first typed obstruction. Callers that need a+  -- complete diagnosis ask the explicit corridor query and alone pay for it.+  diagnosisBatch <-+    requireRight+      "conflict diagnosis"+      (recoverConstraints cdt1 (V.singleton (VertexId 6, VertexId 7)))+  case V.toList (constraintBatchOutcomes diagnosisBatch) of+    [ConstraintRejected blocking] -> do+      let diagnosed =+            fmap+              asUndirected+              (getConflictingEdgesBetweenVertices cdt1 (VertexId 6) (VertexId 7))+      case diagnosed of+        [] -> fail "explicit conflict diagnosis named no edge"+        firstBlocking : _ ->+          assertEqual "batch rejection is the first corridor obstruction" firstBlocking blocking+      assertEqual+        "explicit conflict diagnosis is deduplicated"+        (length diagnosed)+        (length (Set.fromList diagnosed))+      forM_ diagnosed $ \edge ->+        unless (isConstraintEdge cdt1 edge) $+          fail ("explicit conflict diagnosis named a non-constraint edge: " <> show edge)+    outcomes ->+      fail+        ( "a constraint crossing the diagonal was not rejected: "+            <> show outcomes+        )++  split <- requireRight "constraint split" (addConstraintAndSplit id cdt1 (VertexId 1) (VertexId 3))+  let splitCdt = constraintRecoveryTriangulation split+  unless (numVertices splitCdt > numVertices cdt1) $ fail "constraint split did not insert an intersection vertex"+  assertCdtValid "constraint split" splitCdt++  -- The batch splitter must agree with singleton descent, including across a+  -- suspension: every vertical below is constrained only inside the batch+  -- itself, so no census against the base can reserve for its crossings and+  -- the chunk's vertex reservation exhausts mid-batch. The driver publishes,+  -- re-reserves against the published mesh, and resumes; the final mesh must+  -- not know any of that happened.+  let bandColumns = [0 .. 7 :: Int]+      bandVertices =+        V.fromList+          ( Point 0 5+              : Point 90 5+              : concat+                  [ [Point x 10, Point x 0]+                  | column <- bandColumns+                  , let x = 10 * fromIntegral column + 5+                  ]+          )+  bandBuild <-+    requireRight+      "split band base"+      (constrainedDelaunayMaximal unitElementDefaults bandVertices V.empty)+  let bandAcceptedBuild = cdtAcceptedBuild bandBuild+      bandMapping = buildInputVertices bandAcceptedBuild+      bandHandle input = VertexId (indexPrimArray bandMapping input)+      bandBase = buildTriangulation bandAcceptedBuild+      bandRequests =+        V.fromList+          ( (bandHandle 0, bandHandle 1)+              : [ (bandHandle (2 * column + 2), bandHandle (2 * column + 3))+                | column <- bandColumns+                ]+          )+      replaySplit+        :: ConstrainedDelaunayTriangulation (Point)+        -> (VertexId, VertexId)+        -> Either (CdtError) (ConstrainedDelaunayTriangulation (Point))+      replaySplit triangulation request =+        constraintRecoveryTriangulation+          <$> uncurry (addConstraintAndSplit id triangulation) request+  bandBatch <-+    requireRight+      "split batch"+      (addConstraintsAndSplit id bandBase bandRequests)+  bandDescent <-+    requireRight+      "split singleton descent"+      (V.foldM' replaySplit bandBase bandRequests)+  assertEqual+    "split batch topology equals singleton descent"+    bandDescent+    (constraintRecoveryTriangulation bandBatch)+  assertEqual+    "split batch added one vertex per crossing"+    (numVertices bandBase + length bandColumns)+    (numVertices (constraintRecoveryTriangulation bandBatch))+  assertCdtValid "split batch" (constraintRecoveryTriangulation bandBatch)++  -- The same law with the reservation exhausting inside one corridor rather+  -- than between corridors: the closing horizontal crosses two constraints+  -- the census can see and fifteen it cannot, so the corridor suspends with+  -- its cursor mid-walk and the resumed transaction continues from the last+  -- split vertex, not from the corridor's start.+  let laceColumns = [0 .. 16 :: Int]+      laceVertices =+        V.fromList+          ( Point 0 5+              : Point 90 5+              : concat+                  [ [Point x 10, Point x 0]+                  | column <- laceColumns+                  , let x = 5 * fromIntegral column + 5+                  ]+          )+      laceBuiltIn = V.fromList [(2, 3), (34, 35)]+  laceBuild <-+    requireRight+      "split lace base"+      (constrainedDelaunayMaximal unitElementDefaults laceVertices laceBuiltIn)+  let laceAcceptedBuild = cdtAcceptedBuild laceBuild+      laceMapping = buildInputVertices laceAcceptedBuild+      laceHandle input = VertexId (indexPrimArray laceMapping input)+      laceBase = buildTriangulation laceAcceptedBuild+      laceRequests =+        V.fromList+          ( [ (laceHandle (2 * column + 2), laceHandle (2 * column + 3))+            | column <- [1 .. 15]+            ]+              <> [(laceHandle 0, laceHandle 1)]+          )+  laceBatch <-+    requireRight+      "split lace batch"+      (addConstraintsAndSplit id laceBase laceRequests)+  laceDescent <-+    requireRight+      "split lace singleton descent"+      (V.foldM' replaySplit laceBase laceRequests)+  assertEqual+    "split lace batch topology equals singleton descent"+    laceDescent+    (constraintRecoveryTriangulation laceBatch)+  assertEqual+    "split lace batch added one vertex per crossing"+    (numVertices laceBase + length laceColumns)+    (numVertices (constraintRecoveryTriangulation laceBatch))+  assertCdtValid "split lace batch" (constraintRecoveryTriangulation laceBatch)++  let verticesInput :: V.Vector (Point)+      verticesInput = V.fromList [Point 0 0, Point 4 0, Point 4 4, Point 0 4, Point 0 0]+      constraintsInput = V.fromList [(0, 2), (1, 3), (4, 1)]+  bulk <- requireRight "stable CDT bulk load" (constrainedDelaunayMaximal unitElementDefaults verticesInput constraintsInput)+  let bulkAcceptedBuild = cdtAcceptedBuild bulk+      bulkMapping = buildInputVertices bulkAcceptedBuild+  unless (sizeofPrimArray bulkMapping > 4) $ fail "buildInputVertices out of bounds"+  assertEqual "stable duplicate reroute" (VertexId (indexPrimArray bulkMapping 0)) (VertexId (indexPrimArray bulkMapping 4))+  assertEqual "conflict reporting" 1 (V.length (cdtRejectedConstraints bulk))+  assertCdtValid "stable CDT bulk load" (buildTriangulation bulkAcceptedBuild)++testAnnotatedConstrainedUnion :: IO ()+testAnnotatedConstrainedUnion = do+  let leftPoints :: V.Vector (Point)+      leftPoints = V.fromList [Point 0 0, Point 2 0, Point 2 2, Point 0 2]+      rightPoints :: V.Vector (Point)+      rightPoints = V.fromList [Point 2 0, Point 4 0, Point 4 2, Point 2 2]+      thirdPoints :: V.Vector (Point)+      thirdPoints = V.fromList [Point 4 0, Point 6 0, Point 6 2, Point 4 2]+  leftBuild <-+    requireRight "annotated constrained union left" $+      constrainedDelaunay+        unitElementDefaults+        leftPoints+        (V.singleton (0, 2))+  rightBuild <-+    requireRight "annotated constrained union right" $+      constrainedDelaunay+        unitElementDefaults+        rightPoints+        (V.singleton (0, 2))+  thirdBuild <-+    requireRight "annotated constrained union third" $+      constrainedDelaunay+        unitElementDefaults+        thirdPoints+        (V.singleton (0, 2))+  let left =+        mapVertices+          (const (Set.singleton "left"))+          (buildTriangulation leftBuild)+      right =+        mapVertices+          (const (Set.singleton "right"))+          (buildTriangulation rightBuild)+      third =+        mapVertices+          (const (Set.singleton "third"))+          (buildTriangulation thirdBuild)+  joined <-+    requireRight+      "annotated constrained union"+      (unionConstrainedWith Set.union left right)+  let expectedAnnotations =+        Map.fromList+          [ (Point 0 0, Set.singleton "left")+          , (Point 0 2, Set.singleton "left")+          , (Point 2 0, Set.fromList ["left", "right"])+          , (Point 2 2, Set.fromList ["left", "right"])+          , (Point 4 0, Set.singleton "right")+          , (Point 4 2, Set.singleton "right")+          ]+      actualAnnotations =+        Map.fromList+          [ (vertexPoint joined vertex, vertexData joined vertex)+          | vertex <- vertices joined+          ]+      expectedConstraints =+        Set.union+          (Set.fromList (V.toList (constraintSegments left)))+          (Set.fromList (V.toList (constraintSegments right)))+  assertEqual+    "annotated constrained union preserves and combines site payloads"+    expectedAnnotations+    actualAnnotations+  assertEqual+    "annotated constrained union preserves both constraint sections"+    expectedConstraints+    (Set.fromList (V.toList (constraintSegments joined)))+  assertCdtValid "annotated constrained union" joined+  commuted <-+    requireRight+      "annotated constrained union commuted"+      (unionConstrainedWith Set.union right left)+  assertEqual+    "annotated constrained union is commutative under a commutative payload combiner"+    joined+    commuted+  leftAssociated <-+    requireRight+      "annotated constrained union left-associated"+      (unionConstrainedWith Set.union joined third)+  rightPair <-+    requireRight+      "annotated constrained union right pair"+      (unionConstrainedWith Set.union right third)+  rightAssociated <-+    requireRight+      "annotated constrained union right-associated"+      (unionConstrainedWith Set.union left rightPair)+  assertEqual+    "annotated constrained union is associative wherever both descents are admitted"+    leftAssociated+    rightAssociated+  unitJoined <-+    requireRight+      "unit constrained union specialization"+      ( unionConstrained+          (mapVertices (const ()) left)+          (mapVertices (const ()) right)+      )+  assertEqual+    "unit constrained union specializes annotated constrained union"+    unitJoined+    (mapVertices (const ()) joined)++-- | Sequential extension retains the base authority as the transaction root.+-- The semantic result agrees with canonical union on sites and constraint+-- sections, but its receipt proves that only the incoming constraint section+-- was interpreted.+testAsymmetricConstrainedExtension :: IO ()+testAsymmetricConstrainedExtension = do+  let basePoints :: V.Vector (Point)+      basePoints = V.fromList [Point 0 0, Point 2 0, Point 2 2, Point 0 2]+      extensionPoints :: V.Vector (Point)+      extensionPoints = V.fromList [Point 2 0, Point 4 0, Point 4 2, Point 2 2]+  baseBuild <-+    requireRight+      "asymmetric extension base"+      (constrainedDelaunay unitElementDefaults basePoints (V.singleton (0, 2)))+  extensionBuild <-+    requireRight+      "asymmetric extension incoming"+      (constrainedDelaunay unitElementDefaults extensionPoints (V.singleton (0, 2)))+  let base = mapVertices (const (Set.singleton "base")) (buildTriangulation baseBuild)+      extension = mapVertices (const (Set.singleton "extension")) (buildTriangulation extensionBuild)+      expectedAnnotations =+        Map.fromList+          [ (Point 0 0, Set.singleton "base")+          , (Point 0 2, Set.singleton "base")+          , (Point 2 0, Set.fromList ["base", "extension"])+          , (Point 2 2, Set.fromList ["base", "extension"])+          , (Point 4 0, Set.singleton "extension")+          , (Point 4 2, Set.singleton "extension")+          ]+      expectedConstraints =+        Set.union+          (Set.fromList (V.toList (constraintSegments base)))+          (Set.fromList (V.toList (constraintSegments extension)))+      baseAnnotations =+        Map.fromList+          [ (vertexPoint base vertex, vertexData base vertex)+          | vertex <- vertices base+          ]+      extensionAnnotations =+        Map.fromList+          [ (vertexPoint extension vertex, vertexData extension vertex)+          | vertex <- vertices extension+          ]+  baseAnnotationsBefore <- evaluate (force baseAnnotations)+  baseConstraintsBefore <- evaluate (force (constraintSegments base))+  extensionAnnotationsBefore <- evaluate (force extensionAnnotations)+  extensionConstraintsBefore <- evaluate (force (constraintSegments extension))+  extendedResult <-+    requireRight+      "asymmetric constrained extension"+      (extendConstrainedWith Set.union base extension)+  let constraintBatch = constrainedExtensionConstraintBatch extendedResult+      extended = constraintBatchTriangulation constraintBatch+      receipt = constraintBatchStats constraintBatch+      buildReceipt = constrainedExtensionBuildStats extendedResult+      actualAnnotations =+        Map.fromList+          [ (vertexPoint extended vertex, vertexData extended vertex)+          | vertex <- vertices extended+          ]+  assertEqual+    "asymmetric extension preserves base and combines coincident site payloads"+    expectedAnnotations+    actualAnnotations+  assertEqual+    "asymmetric extension preserves resident and incoming constraint sections"+    expectedConstraints+    (Set.fromList (V.toList (constraintSegments extended)))+  assertEqual+    "asymmetric extension does not mutate the frozen base predecessor sites"+    baseAnnotationsBefore+    ( Map.fromList+        [ (vertexPoint base vertex, vertexData base vertex)+        | vertex <- vertices base+        ]+    )+  assertEqual+    "asymmetric extension does not mutate the frozen base predecessor constraints"+    baseConstraintsBefore+    (constraintSegments base)+  assertEqual+    "asymmetric extension does not mutate the frozen incoming predecessor sites"+    extensionAnnotationsBefore+    ( Map.fromList+        [ (vertexPoint extension vertex, vertexData extension vertex)+        | vertex <- vertices extension+        ]+    )+  assertEqual+    "asymmetric extension does not mutate the frozen incoming predecessor constraints"+    extensionConstraintsBefore+    (constraintSegments extension)+  assertEqual+    "asymmetric extension recovers only incoming constraints"+    (V.length (constraintSegments extension))+    (constraintBatchRequests receipt)+  assertEqual+    "asymmetric extension returns one outcome for each incoming constraint"+    (V.length (constraintSegments extension))+    (V.length (constraintBatchOutcomes constraintBatch))+  assertEqual+    "asymmetric extension admits every incoming constraint"+    (V.length (constraintSegments extension))+    (constraintBatchAccepted receipt)+  assertEqual+    "asymmetric extension reports no incoming constraint rejection"+    0+    (constraintBatchRejected receipt)+  assertEqual+    "asymmetric extension charges every incoming site once"+    (V.length extensionPoints)+    (statInputPoints buildReceipt)+  assertEqual+    "asymmetric extension distinguishes occupied incoming sites"+    2+    (statExistingPoints buildReceipt)+  assertEqual+    "asymmetric extension distinguishes newly materialized incoming sites"+    2+    (statUniquePoints buildReceipt)+  assertCdtValid "asymmetric constrained extension" extended++  crossingBuild <-+    requireRight+      "asymmetric extension crossing incoming section"+      (constrainedDelaunay unitElementDefaults basePoints (V.singleton (1, 3)))+  case+      extendConstrainedWith+        Set.union+        base+        (mapVertices (const (Set.singleton "crossing")) (buildTriangulation crossingBuild)) of+    Left (ConstraintUnionConstructionFailed (ConstraintIntersection _)) -> pure ()+    other -> fail ("asymmetric extension did not return the corridor intersection witness: " <> show other)++testLargeAsymmetricConstrainedExtension :: IO ()+testLargeAsymmetricConstrainedExtension = do+  let width = 40 :: Int+      height = 28 :: Int+      basePoints :: V.Vector (Point)+      basePoints =+        V.fromList+          ( [ Point 0 0+            , Point (fromIntegral (width + 1)) 0+            , Point (fromIntegral (width + 1)) (fromIntegral (height + 1))+            , Point 0 (fromIntegral (height + 1))+            ]+              <> [ Point+                     (fromIntegral (column + 1) + fromIntegral ((column * 17 + row * 31) `mod` 13) * 1.0e-3)+                     (fromIntegral (row + 1) + fromIntegral ((column * 23 + row * 19) `mod` 17) * 1.0e-3)+                 | row <- [0 .. height - 1]+                 , column <- [0 .. width - 1]+                 ]+          )+      baseConstraints = V.fromList [(0, 1), (1, 2), (2, 3), (3, 0), (0, 2)]+      extensionPoints :: V.Vector (Point)+      extensionPoints = V.fromList [Point 48 8, Point 53.2 8.4, Point 50.4 15.8]+      extensionConstraints = V.fromList [(0, 1), (1, 2), (2, 0)]+      conflictPoints :: V.Vector (Point)+      conflictPoints = V.fromList [Point 8 22, Point 30 5, Point 26 7]+  baseBuild <-+    requireRight+      "large asymmetric extension base"+      (constrainedDelaunay unitElementDefaults basePoints baseConstraints)+  extensionBuild <-+    requireRight+      "large asymmetric extension incoming"+      (constrainedDelaunay unitElementDefaults extensionPoints extensionConstraints)+  conflictBuild <-+    requireRight+      "large asymmetric extension conflicting incoming"+      (constrainedDelaunay unitElementDefaults conflictPoints (V.singleton (0, 1)))+  let base = mapVertices (const (Set.singleton "base")) (buildTriangulation baseBuild)+      extension = mapVertices (const (Set.singleton "extension")) (buildTriangulation extensionBuild)+      conflicting = mapVertices (const (Set.singleton "conflict")) (buildTriangulation conflictBuild)+      predecessor+        :: Triangulation 'Constrained (Set.Set String) () () ()+        -> ( Triangulation 'Constrained (Set.Set String) () () ()+           , Map.Map VertexId (Point, Set.Set String)+           , Set.Set (CanonicalSegment)+           )+      predecessor triangulation =+        ( triangulation+        , Map.fromList+            [ (vertex, (vertexPoint triangulation vertex, vertexData triangulation vertex))+            | vertex <- vertices triangulation+            ]+        , Set.fromList (V.toList (constraintSegments triangulation))+        )+      assertPredecessor+        :: String+        -> ( Triangulation 'Constrained (Set.Set String) () () ()+           , Map.Map VertexId (Point, Set.Set String)+           , Set.Set (CanonicalSegment)+           )+        -> Triangulation 'Constrained (Set.Set String) () () ()+        -> IO ()+      assertPredecessor label snapshot triangulation =+        assertEqual label snapshot (predecessor triangulation)+  baseBefore <- evaluate (force (predecessor base))+  extensionBefore <- evaluate (force (predecessor extension))+  conflictingBefore <- evaluate (force (predecessor conflicting))+  let (_, baseVertexSnapshotBefore, baseConstraintSnapshotBefore) = baseBefore+      (_, _, extensionConstraintSnapshotBefore) = extensionBefore+  extensionResult <-+    requireRight+      "large asymmetric constrained extension"+      (extendConstrainedWith Set.union base extension)+  let constraintBatch = constrainedExtensionConstraintBatch extensionResult+      extended = constraintBatchTriangulation constraintBatch+      extendedConstraints = Set.fromList (V.toList (constraintSegments extended))+      extendedVertexSnapshot =+        Map.fromList+          [ (vertex, (vertexPoint extended vertex, vertexData extended vertex))+          | vertex <- vertices extended+          ]+  assertEqual+    "large asymmetric extension retains every base vertex handle, coordinate, and payload"+    baseVertexSnapshotBefore+    (Map.restrictKeys extendedVertexSnapshot (Map.keysSet baseVertexSnapshotBefore))+  assertEqual+    "large asymmetric extension retains its complete base constraint source section"+    baseConstraintSnapshotBefore+    (Set.intersection baseConstraintSnapshotBefore extendedConstraints)+  assertEqual+    "large asymmetric extension retains its complete incoming constraint source section"+    extensionConstraintSnapshotBefore+    (Set.intersection extensionConstraintSnapshotBefore extendedConstraints)+  assertEqual+    "large asymmetric extension preserves exactly both source constraint sections"+    (Set.union baseConstraintSnapshotBefore extensionConstraintSnapshotBefore)+    extendedConstraints+  assertEqual+    "large asymmetric extension leaves the frozen base predecessor physically unchanged"+    baseBefore+    (predecessor base)+  assertPredecessor+    "large asymmetric extension leaves the frozen incoming predecessor physically unchanged"+    extensionBefore+    extension+  assertEqual+    "large asymmetric extension charges only the incoming sites"+    (V.length extensionPoints)+    (statInputPoints (constrainedExtensionBuildStats extensionResult))+  assertEqual+    "large asymmetric extension replays only the incoming constraints"+    (V.length extensionConstraints)+    (constraintBatchRequests (constraintBatchStats constraintBatch))+  assertCdtValid "large asymmetric constrained extension" extended+  case extendConstrainedWith Set.union base conflicting of+    Left (ConstraintUnionConstructionFailed (ConstraintIntersection _)) -> pure ()+    outcome ->+      fail+        ( "large asymmetric extension did not refuse the crossing incoming corridor: "+            <> show outcome+        )+  assertEqual+    "large asymmetric extension refusal leaves the frozen base predecessor physically unchanged"+    baseBefore+    (predecessor base)+  assertPredecessor+    "large asymmetric extension refusal leaves the conflicting predecessor physically unchanged"+    conflictingBefore+    conflicting++-- | A separated constrained seam is a restriction-preserving operation, not+-- the canonical site-set union wearing a cheaper costume. Both closed source+-- sections survive face-for-face; only the corridor contributes new faces.+testSeparatedConstrainedSeam :: IO ()+testSeparatedConstrainedSeam = do+  let leftPoints :: V.Vector (Point)+      leftPoints =+        V.fromList+          [ Point (-4) (-1)+          , Point (-2) (-1)+          , Point (-2) 1+          , Point (-4) 1+          ]+      rightPoints :: V.Vector (Point)+      rightPoints =+        V.fromList+          [ Point 2 (-1)+          , Point 4 (-1)+          , Point 4 1+          , Point 2 1+          ]+      closedContour = V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)]+  leftBuild <-+    requireRight+      "separated constrained seam left"+      (constrainedDelaunay unitElementDefaults leftPoints closedContour)+  rightBuild <-+    requireRight+      "separated constrained seam right"+      (constrainedDelaunay unitElementDefaults rightPoints closedContour)+  let left =+        Internal.geometryOnlyPublication+          (buildTriangulation leftBuild)+      right =+        Internal.geometryOnlyPublication+          (buildTriangulation rightBuild)+      leftFaceKeys = Set.fromList (fmap (faceKeyOf left) (innerFaces left))+      rightFaceKeys = Set.fromList (fmap (faceKeyOf right) (innerFaces right))+      expectedConstraints =+        Set.union+          (Set.fromList (V.toList (constraintSegments left)))+          (Set.fromList (V.toList (constraintSegments right)))+  seam <-+    requireRight+      "source-preserving separated constrained seam"+      (joinSeparatedConstrained (\_ _ -> True) defaultRefinementParameters left right)+  let joined = constrainedSeamResultTriangulation seam+      joinedFaceKeys = Set.fromList (fmap (faceKeyOf joined) (innerFaces joined))+      actualAnnotations =+        Map.fromList+          [ (vertexPoint joined vertex, vertexData joined vertex)+          | vertex <- vertices joined+          ]+      expectedAnnotations =+        Map.union+          ( Map.fromList+              [ (vertexPoint left vertex, vertexData left vertex)+              | vertex <- vertices left+              ]+          )+          ( Map.fromList+              [ (vertexPoint right vertex, vertexData right vertex)+              | vertex <- vertices right+              ]+          )+      actualConstraints = Set.fromList (V.toList (constraintSegments joined))+      certifiedPerimeter =+        fmap+          (\segmentValue -> (segmentStart segmentValue, segmentEnd segmentValue))+          (Set.toAscList (Set.difference actualConstraints expectedConstraints))+  assertCdtValid "source-preserving separated constrained seam" joined+  assertEqual+    "separated seam preserves all source annotations"+    expectedAnnotations+    actualAnnotations+  assertEqual+    "separated seam preserves both source constraint sections"+    True+    (expectedConstraints `Set.isSubsetOf` actualConstraints)+  assertEqual+    "separated seam certifies exactly its two synthetic perimeter bridges"+    [ (Point (-2) (-1), Point 2 (-1))+    , (Point (-2) 1, Point 2 1)+    ]+    certifiedPerimeter+  unless (leftFaceKeys `Set.isSubsetOf` joinedFaceKeys) $+    fail "separated seam removed or retriangulated a left source face"+  unless (rightFaceKeys `Set.isSubsetOf` joinedFaceKeys) $+    fail "separated seam removed or retriangulated a right source face"+  assertEqual+    "separated seam records the stable left face witness"+    (numInnerFaces left)+    (constrainedSeamLeftFaceCount seam)+  assertEqual+    "separated seam records the stable left constraint witness"+    (numConstraints left)+    (constrainedSeamLeftConstraintCount seam)+  assertEqual+    "separated seam has one right face witness per source face"+    (numInnerFaces right)+    (V.length (constrainedSeamRightFaceEvidence seam))+  forM_ (V.toList (constrainedSeamRightFaceEvidence seam)) $ \evidence ->+    let sourceFaceKey = faceKeyOf right (constrainedSeamSourceFace evidence)+        targetFaceKey = faceKeyOf joined (constrainedSeamTargetFace evidence)+        evidenceFaceKey =+          [ constrainedSeamFaceFirstPoint evidence+          , constrainedSeamFaceSecondPoint evidence+          , constrainedSeamFaceThirdPoint evidence+          ]+     in do+          assertEqual+            "right face witness names the exact target triangle"+            sourceFaceKey+            targetFaceKey+          assertEqual+            "right face witness carries the exact target triangle"+            targetFaceKey+            evidenceFaceKey+  when (V.null (constrainedSeamJoinFaces seam)) $+    fail "separated seam did not identify any new corridor face"+  assertEqual+    "copied source constraints require no corridor recovery"+    0+    (constraintBatchRequests (constrainedSeamConstraintStats seam))+  let seamPublication = constrainedSeamPublicationStats seam+  assertEqual+    "separated seam does not enumerate resident unboxed base pages"+    0+    (publicationUnboxedBasePageEnumerations seamPublication)+  assertEqual+    "separated seam does not freeze resident unboxed base pages"+    0+    (publicationUnboxedBasePageFreezes seamPublication)+  assertEqual+    "separated seam does not enumerate resident boxed base pages"+    0+    (publicationBoxedBasePageEnumerations seamPublication)+  unless+    ( publicationUnboxedDirtyBasePages seamPublication+        + publicationUnboxedDirtyAppendedPages seamPublication+        > 0+    ) $+    fail "separated seam publication did not record appended unboxed writes"+  unless (constrainedSeamCachedFrontierPointReads seam > 0) $+    fail "separated seam did not record cached frontier point reads"++  let boundedBridgeParameters =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just 6+          , refineMaxEdgeLength = Just 1+          }+  boundedSeam <-+    requireRight+      "edge-bounded separated constrained seam"+      ( joinSeparatedConstrained+          (\_ _ -> True)+          boundedBridgeParameters+          left+          right+      )+  let boundedJoined = constrainedSeamResultTriangulation boundedSeam+      boundedSyntheticSegments =+        Set.difference+          (Set.fromList (V.toList (constraintSegments boundedJoined)))+          expectedConstraints+  assertCdtValid "edge-bounded separated constrained seam" boundedJoined+  assertEqual+    "edge-bounded seam charges its exact bridge Steiner budget"+    6+    (numVertices boundedJoined - numVertices left - numVertices right)+  assertEqual+    "edge-bounded seam publishes both four-edge bridge paths"+    8+    (Set.size boundedSyntheticSegments)+  unless (all ((<= 1) . canonicalSegmentSquaredLength) boundedSyntheticSegments) $+    fail "edge-bounded seam published an oversized synthetic bridge child"+  assertEqual+    "edge-bounded seam cache agrees with its explicit frontier observation"+    (Internal.prepareSeamFrontierIndex boundedJoined)+    (Internal.triSeamFrontier boundedJoined)+  case+      joinSeparatedConstrained+        (\_ _ -> True)+        boundedBridgeParameters{refineMaxAdditionalVertices = Just 5}+        left+        right of+    Left+      ( ConstraintUnionConstructionFailed+          (CdtBuildError (RefinementSeamBridgeBudgetExceeded 6 5))+        ) -> pure ()+    outcome ->+      fail+        ( "edge-bounded seam did not return its exact budget obstruction: "+            <> either show (const "success") outcome+        )++  reversed <- requireRight "reversed source-preserving separated seam" (joinSeparatedConstrained (\_ _ -> True) defaultRefinementParameters right left)+  assertCdtValid "reversed source-preserving separated seam" (constrainedSeamResultTriangulation reversed)++  let localParameters =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just 2+          , refineMaxArea = Just 0.5+          , refineKeepConstraintEdges = True+          }+      allJoinedFaces = Set.fromList (innerFaces joined)+  locallyRefined <-+    requireRight+      "seam refinement preserves cached hull frontier"+      (refineWithinDomain (const ()) localParameters allJoinedFaces joined)+  let refinedJoined = refinedTriangulation (refinementDomainResult locallyRefined)+  unless (refinementComplete (refinementDomainResult locallyRefined)) $+    fail "seam refinement fixture did not drain its local worklist"+  assertEqual+    "local refinement retains the exact cached hull frontier"+    (Internal.triSeamFrontier joined)+    (Internal.triSeamFrontier refinedJoined)++  thirdBuild <-+    requireRight+      "repeated separated constrained seam source"+      (constrainedDelaunay unitElementDefaults (V.fromList+        [ Point 8 (-1)+        , Point 10 (-1)+        , Point 10 1+        , Point 8 1+        ]) closedContour)+  let third =+        Internal.geometryOnlyPublication+          (buildTriangulation thirdBuild)+  repeated <-+    requireRight+      "repeated separated seam after local refinement"+      (joinSeparatedConstrained (\_ _ -> True) defaultRefinementParameters refinedJoined third)+  assertCdtValid+    "repeated separated seam after local refinement"+    (constrainedSeamResultTriangulation repeated)+  case joinSeparatedConstrained (\_ _ -> True) defaultRefinementParameters left left of+    Left ConstraintUnionNotSeparated -> pure ()+    other -> fail ("non-separated constrained seam was not refused: " <> show other)++-- North/south additions use the orientation-preserving Y chart rather than+-- rotating or copying the resident mesh.  The sequence then alternates axes,+-- so a stale one-axis frontier cache cannot accidentally make the third join+-- succeed.+testAxisSeparatedConstrainedSeams :: IO ()+testAxisSeparatedConstrainedSeams = do+  let closedContour :: Int -> V.Vector (Int, Int)+      closedContour pointCount =+        V.fromList+          [ (index, (index + 1) `mod` pointCount)+          | index <- [0 .. pointCount - 1]+          ]+      buildPublished+        :: String+        -> V.Vector Point+        -> IO (Triangulation 'Constrained () () () ())+      buildPublished label points = do+        built <-+          requireRight+            label+            (constrainedDelaunay+               unitElementDefaults+               points+               (closedContour (V.length points)))+        pure (Internal.geometryOnlyPublication (buildTriangulation built))+      centralPoints =+        V.fromList+          [ Point (-1) (-1)+          , Point 1 (-1)+          , Point 1 1+          , Point (-1) 1+          ]+      northPoints =+        V.fromList+          [ Point (-1) 3+          , Point 1 3+          , Point 1 5+          , Point (-1) 5+          ]+      southPoints =+        V.fromList+          [ Point (-1) (-5)+          , Point 1 (-5)+          , Point 1 (-3)+          , Point (-1) (-3)+          ]+      eastPoints =+        V.fromList+          [ Point 3 (-1)+          , Point 5 (-1)+          , Point 5 1+          , Point 3 1+          ]+      overlapPoints =+        V.fromList+          [ Point 0 0+          , Point 2 0+          , Point 2 2+          , Point 0 2+          ]+      irregularNorthPoints =+        V.fromList+          [ Point (-2) 7+          , Point 0 7+          , Point 2 7+          , Point 2.5 9+          , Point 0 11+          , Point (-2.5) 9+          ]+  central <- buildPublished "axis seam central source" centralPoints+  north <- buildPublished "axis seam north source" northPoints+  south <- buildPublished "axis seam south source" southPoints+  east <- buildPublished "axis seam east source" eastPoints+  overlap <- buildPublished "axis seam overlapping source" overlapPoints++  let northParameters =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just 2+          , refineMaxEdgeLength = Just 1+          }+  northJoined <-+    requireRight+      "edge-bounded north source-preserving separated seam"+      (joinSeparatedConstrained (\_ _ -> True) northParameters central north)+  let northTopology = constrainedSeamResultTriangulation northJoined+      northPublication = constrainedSeamPublicationStats northJoined+      northSyntheticSegments =+        Set.difference+          (Set.fromList (V.toList (constraintSegments northTopology)))+          ( Set.union+              (Set.fromList (V.toList (constraintSegments central)))+              (Set.fromList (V.toList (constraintSegments north)))+          )+  assertCdtValid+    "north source-preserving separated seam"+    northTopology+  assertEqual+    "north seam charges two bridge Steiner vertices"+    2+    (numVertices northTopology - numVertices central - numVertices north)+  assertEqual+    "north seam certifies two bounded two-edge bridge paths"+    4+    (Set.size northSyntheticSegments)+  unless (all ((<= 1) . canonicalSegmentSquaredLength) northSyntheticSegments) $+    fail "north seam published an oversized synthetic bridge child"+  assertEqual+    "north seam cache agrees with an explicit frontier observation"+    (Internal.prepareSeamFrontierIndex northTopology)+    (Internal.triSeamFrontier northTopology)+  assertEqual+    "north seam does not enumerate resident unboxed pages"+    0+    (publicationUnboxedBasePageEnumerations northPublication)+  assertEqual+    "north seam does not freeze resident unboxed pages"+    0+    (publicationUnboxedBasePageFreezes northPublication)+  assertEqual+    "north seam does not enumerate resident boxed pages"+    0+    (publicationBoxedBasePageEnumerations northPublication)+  unless+    ( publicationUnboxedDirtyBasePages northPublication+        + publicationUnboxedDirtyAppendedPages northPublication+        > 0+    ) $+    fail "north seam did not record appended unboxed writes"++  reversed <-+    requireRight+      "reversed south/north source-preserving separated seam"+      (joinSeparatedConstrained (\_ _ -> True) defaultRefinementParameters south central)+  assertCdtValid+    "reversed south/north source-preserving separated seam"+    (constrainedSeamResultTriangulation reversed)++  mixed <-+    requireRight+      "mixed-axis east extension after north seam"+      (joinSeparatedConstrained (\_ _ -> True) defaultRefinementParameters+         (constrainedSeamResultTriangulation northJoined)+         east)+  assertCdtValid+    "mixed-axis east extension after north seam"+    (constrainedSeamResultTriangulation mixed)+  assertEqual+    "mixed-axis seam retains prior perimeter and certifies two new bridges"+    ( numConstraints (constrainedSeamResultTriangulation northJoined)+        + numConstraints east+        + 2+    )+    (numConstraints (constrainedSeamResultTriangulation mixed))++  repeated <-+    requireRight+      "repeated mixed-axis south extension"+      (joinSeparatedConstrained (\_ _ -> True) defaultRefinementParameters+         (constrainedSeamResultTriangulation mixed)+         south)+  assertCdtValid+    "repeated mixed-axis south extension"+    (constrainedSeamResultTriangulation repeated)+  assertEqual+    "repeated mixed-axis seam cache agrees with an explicit frontier observation"+    (Internal.prepareSeamFrontierIndex (constrainedSeamResultTriangulation repeated))+    (Internal.triSeamFrontier (constrainedSeamResultTriangulation repeated))++  irregularNorth <-+    buildPublished+      "axis seam irregular north source"+      irregularNorthPoints+  irregularJoined <-+    requireRight+      "irregular collinear north extension"+      (joinSeparatedConstrained (\_ _ -> True) defaultRefinementParameters+         (constrainedSeamResultTriangulation repeated)+         irregularNorth)+  assertCdtValid+    "irregular collinear north extension"+    (constrainedSeamResultTriangulation irregularJoined)+  assertEqual+    "irregular collinear north cache agrees with an explicit frontier observation"+    (Internal.prepareSeamFrontierIndex (constrainedSeamResultTriangulation irregularJoined))+    (Internal.triSeamFrontier (constrainedSeamResultTriangulation irregularJoined))++  case joinSeparatedConstrained (\_ _ -> True) defaultRefinementParameters central overlap of+    Left ConstraintUnionNotSeparated -> pure ()+    outcome ->+      fail+        ( "overlapping sources were not refused by either-axis admission: "+            <> either show (const "success") outcome+        )++-- A separated source frontier may become an interior diagonal when the seam+-- closes. If that diagonal is unconstrained and locally illegal, preserving+-- the source and publishing a Delaunay join are incompatible obligations. The+-- constrained twin is lawful: its contour explicitly authorizes that fixed+-- diagonal to remain.+testSeparatedConstrainedSeamRefusesPinnedFrontierRewrite :: IO ()+testSeparatedConstrainedSeamRefusesPinnedFrontierRewrite = do+  let leftPoints =+        V.fromList+          [ Point (-2) 0+          , Point 0 0+          , Point (-1) 10+          , Point (-3) 5+          ]+      rightPoints =+        V.fromList+          [ Point 1 5+          , Point 2 4+          , Point 3 5+          , Point 2 6+          ]+      closedQuadrilateral = V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)]+      buildSource+        :: String+        -> V.Vector (Int, Int)+        -> V.Vector Point+        -> IO (BuildResult 'Constrained Point () () ())+      buildSource label constraints points =+        requireRight label (constrainedDelaunay unitElementDefaults points constraints)+      publish+        :: BuildResult 'Constrained Point () () ()+        -> Triangulation 'Constrained () () () ()+      publish = Internal.geometryOnlyPublication . buildTriangulation+  unconstrainedLeft <- publish <$> buildSource "incompatible seam left" V.empty leftPoints+  unconstrainedRight <- publish <$> buildSource "incompatible seam right" V.empty rightPoints+  case joinSeparatedConstrained (\_ _ -> True) defaultRefinementParameters unconstrainedLeft unconstrainedRight of+    Left+      ( ConstraintUnionConstructionFailed+          (CdtBuildError (SeamSourceEdgeRequiresFlip _))+        ) -> pure ()+    outcome ->+      fail+        ( "separated seam did not refuse an unconstrained pinned source rewrite: "+            <> either show (const "success") outcome+        )+  selectiveJoin <-+    requireRight+      "selective seam rewrites only unselected exterior faces"+      (joinSeparatedConstrained (\_ _ -> False) defaultRefinementParameters unconstrainedLeft unconstrainedRight)+  let selectivelyJoined = constrainedSeamResultTriangulation selectiveJoin+      sourceFaceKeys =+        Set.union+          (Set.fromList (fmap (faceKeyOf unconstrainedLeft) (innerFaces unconstrainedLeft)))+          (Set.fromList (fmap (faceKeyOf unconstrainedRight) (innerFaces unconstrainedRight)))+      selectiveFaceKeys =+        Set.fromList (fmap (faceKeyOf selectivelyJoined) (innerFaces selectivelyJoined))+  assertCdtValid "selective unconstrained seam" selectivelyJoined+  when (sourceFaceKeys `Set.isSubsetOf` selectiveFaceKeys) $+    fail "selective seam did not rewrite the incompatible exterior source face"+  when (V.null (constrainedSeamJoinFaces selectiveJoin)) $+    fail "selective seam did not publish the exact rewritten J component"+  unless (V.null (constrainedSeamRightFaceEvidence selectiveJoin)) $+    fail "selective seam fabricated transport evidence for unselected incoming faces"+  constrainedLeft <-+    publish+      <$> buildSource+        "compatible constrained seam left"+        closedQuadrilateral+        leftPoints+  constrainedRight <-+    publish+      <$> buildSource+        "compatible constrained seam right"+        closedQuadrilateral+        rightPoints+  let protectedLeftFaces = Set.fromList (boundedRegionFaces constrainedLeft)+      protectedRightFaces = Set.fromList (boundedRegionFaces constrainedRight)+      preserveConstrainedSource side faceHandle =+        case side of+          SeamResident -> Set.member faceHandle protectedLeftFaces+          SeamIncoming -> Set.member faceHandle protectedRightFaces+      protectedFaceKeys =+        Set.union+          (Set.fromList (fmap (faceKeyOf constrainedLeft) (Set.toList protectedLeftFaces)))+          (Set.fromList (fmap (faceKeyOf constrainedRight) (Set.toList protectedRightFaces)))+  constrainedJoin <-+    requireRight+      "compatible selected constrained seam"+      (joinSeparatedConstrained preserveConstrainedSource defaultRefinementParameters constrainedLeft constrainedRight)+  let constrainedJoined = constrainedSeamResultTriangulation constrainedJoin+      joinedFaceKeys =+        Set.fromList (fmap (faceKeyOf constrainedJoined) (innerFaces constrainedJoined))+      evidencedIncomingFaces =+        Set.fromList+          ( fmap+              constrainedSeamSourceFace+              (V.toList (constrainedSeamRightFaceEvidence constrainedJoin))+          )+  assertCdtValid+    "compatible selected constrained seam"+    constrainedJoined+  unless (protectedFaceKeys `Set.isSubsetOf` joinedFaceKeys) $+    fail "selected constrained source face did not survive exactly"+  assertEqual+    "selected seam evidences exactly the protected incoming faces"+    protectedRightFaces+    evidencedIncomingFaces++-- An obtuse unconstrained source has a hull edge inside the opposite vertex's+-- diametral circle.  That edge is queued by the refinement seed even though+-- it is not a source constraint.  The checked local interpreter must refuse+-- the encroachment split at its authoritative resolver, retain the cached+-- frontier, and remain joinable afterwards.+testLocalRefinementRejectsEncroachedHullSplit :: IO ()+testLocalRefinementRejectsEncroachedHullSplit = do+  built <-+    requireRight+      "encroached hull source"+      ( constrainedDelaunay+          unitElementDefaults+          (V.fromList [Point 0 0, Point 2 0, Point 0.1 0.1])+          V.empty+      )+  let source =+        Internal.geometryOnlyPublication+          (buildTriangulation built)+      permitted = Set.fromList (innerFaces source)+      parameters =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just 1+          , refineMaxArea = Just 0.001+          , refineKeepConstraintEdges = True+          }+      hullEdges =+        [ edge+        | edge <- undirectedEdges source+        , let (forward, backward) = directedPair edge+        , incidentFace source forward == outerFace || incidentFace source backward == outerFace+        ]+      encroachedHull edge =+        let (fromVertex, toVertex) = Dcel.undirectedEndpoints source edge+            fromPoint = vertexPoint source fromVertex+            toPoint = vertexPoint source toVertex+            oppositeFaceEdge =+              case directedPair edge of+                (forward, backward)+                  | incidentFace source forward == outerFace -> backward+                  | otherwise -> forward+            oppositePoint =+              let innerFace = incidentFace source oppositeFaceEdge+               in if innerFace == outerFace+                    then Nothing+                    else+                      case Dcel.faceVertices source innerFace of+                        verticesInFace ->+                          case filter (/= fromVertex) (filter (/= toVertex) verticesInFace) of+                            [vertex] -> Just (vertexPoint source vertex)+                            _ -> Nothing+         in maybe False (Admitted.inDiametralCircle fromPoint toPoint) oppositePoint+  unless (any encroachedHull hullEdges) $+    fail "encroached hull fixture did not produce an encroached hull pair"+  refined <-+    requireRight+      "encroached hull local refinement"+      (refineWithinDomain (const ()) parameters permitted source)+  let refinementResult = refinementDomainResult refined+      result = refinedTriangulation refinementResult+  unless (refinementComplete refinementResult) $+    fail "encroached hull local refinement exhausted without a fixpoint"+  assertEqual "encroached hull split count" (numVertices source) (numVertices result)+  assertEqual+    "encroached hull refinement retains cached frontier"+    (Internal.triSeamFrontier source)+    (Internal.triSeamFrontier result)++  secondBuild <-+    requireRight+      "encroached hull join source"+      ( constrainedDelaunay+          unitElementDefaults+          (V.fromList [Point 4 0, Point 6 0, Point 6 1, Point 4 1])+          V.empty+      )+  let second =+        Internal.geometryOnlyPublication+          (buildTriangulation secondBuild)+  joined <-+    requireRight+      "encroached hull repeated join"+      (joinSeparatedConstrained (\_ _ -> True) defaultRefinementParameters result second)+  assertCdtValid+    "encroached hull repeated join"+    (constrainedSeamResultTriangulation joined)++testConstrainedRefinement :: IO ()+testConstrainedRefinement = do+  cdtBuild <- requireRight "bounded domain" $ constrainedDelaunay+    unitElementDefaults+    (V.fromList [Point 0 0, Point 8 0, Point 8 8, Point 0 8, Point 4 2, Point 4 6])+    (V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)])+  let cdt = buildTriangulation cdtBuild+      parameters = defaultRefinementParameters+        { refineMaxAdditionalVertices = Just 80+        , refineMaxArea = Just 3+        , refineMaxRadiusEdgeRatio = Just 1.4+        , refineExcludeOuterFaces = True+        , refineKeepConstraintEdges = False+        }+  refined <- requireRight "constrained refinement" (refine id parameters cdt)+  let result = refinedTriangulation refined+  canonicalResult <- requireRight "canonical constrained refinement" (canonicalize result)+  unless (refinementAddedVertices refined > 0) $ fail "constrained refinement inserted no Steiner points"+  assertCdtValid "constrained refinement" result+  unless (numConstraints result >= numConstraints cdt) $+    fail "constraint splitting lost the constrained boundary"+  assertEqual+    "canonical publication preserves constraint segments"+    (constraintSegments result)+    (constraintSegments canonicalResult)++  -- Refinement maintains the outer-region classification incrementally, from+  -- the touched patch alone. That is a claim about what an insertion cannot+  -- reach, so it is gated against an independent flood over the finished mesh+  -- rather than trusted. The domain here is deliberately narrower than its+  -- convex hull, so the excluded set is non-empty and the two can disagree.+  notchBuild <- requireRight "notched domain" $ constrainedDelaunay+    unitElementDefaults+    (V.fromList [Point 0 0, Point 8 0, Point 8 8, Point 0 8, Point 13 4, Point 4 4])+    (V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)])+  let notch = buildTriangulation notchBuild+      notchMaximumEdgeLength = 6.2+      notchParameters = defaultRefinementParameters+        { refineMaxAdditionalVertices = Just 120+        , refineMaxArea = Just 1.5+        , refineMaxEdgeLength = Just notchMaximumEdgeLength+        , refineExcludeOuterFaces = True+        , refineKeepConstraintEdges = False+        }+  notchRefined <- requireRight "notched refinement" (refine id notchParameters notch)+  let notchResult = refinedTriangulation notchRefined+      maintained = sort (V.toList (refinementExcludedFaces notchRefined))+      independent = sort (outerRegionFaces notchResult)+      excludedEdgeLengthsSquared =+        [ squaredDistanceWide+            (vertexPoint notchResult fromVertex)+            (vertexPoint notchResult toVertex)+        | face <- maintained+        , directed <- faceDirectedEdges notchResult face+        , let (fromVertex, toVertex) =+                undirectedEndpoints notchResult (asUndirected directed)+        ]+  unless (refinementAddedVertices notchRefined > 0) $ fail "notched refinement inserted no Steiner points"+  unless (refinementComplete notchRefined) $ fail "notched maximum-edge refinement did not complete"+  when (null independent) $ fail "notched domain produced no outer region: the gate is vacuous"+  unless+    (any (> notchMaximumEdgeLength * notchMaximumEdgeLength) excludedEdgeLengthsSquared)+    (fail "notched fixture has no excluded maximum-edge violation")+  assertEqual "incremental exclusion agrees with an independent flood" independent maintained+  assertCdtValid "notched refinement" notchResult++  annulusBuild <- requireRight "annular domain" $ constrainedDelaunay+    unitElementDefaults+    ( V.fromList+        [ Point 0 0+        , Point 12 0+        , Point 12 12+        , Point 0 12+        , Point 4 4+        , Point 8 4+        , Point 8 8+        , Point 4 8+        ]+    )+    ( V.fromList+        [ (0, 1)+        , (1, 2)+        , (2, 3)+        , (3, 0)+        , (4, 5)+        , (5, 6)+        , (6, 7)+        , (7, 4)+        ]+    )+  let annulus = buildTriangulation annulusBuild+      annulusParameters :: Int -> Maybe Double -> RefinementParameters+      annulusParameters budget maximumArea =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just budget+          , refineMaxArea = maximumArea+          , refineExcludeOuterFaces = True+          , refineKeepConstraintEdges = False+          }+  annulusUnchanged <-+    requireRight+      "budget-zero annular refinement"+      (refine id (annulusParameters 0 Nothing) annulus)+  let initialAnnulusOutside = sort (outerRegionFaces annulus)+      budgetZeroOutside =+        sort (V.toList (refinementExcludedFaces annulusUnchanged))+  assertEqual "annulus has one two-crossing hole" 2 (length initialAnnulusOutside)+  assertEqual+    "budget-zero refinement uses the authoritative annulus classification"+    initialAnnulusOutside+    budgetZeroOutside++  annulusRefined <-+    requireRight+      "positive-budget annular refinement"+      (refine id (annulusParameters 40 (Just 4)) annulus)+  let refinedAnnulus = refinedTriangulation annulusRefined+      maintainedAnnulus =+        sort (V.toList (refinementExcludedFaces annulusRefined))+      independentAnnulus = sort (outerRegionFaces refinedAnnulus)+  unless (refinementAddedVertices annulusRefined > 0) $+    fail "annular refinement inserted no Steiner points"+  assertEqual+    "incremental annulus exclusion agrees with authoritative barrier depth"+    independentAnnulus+    maintainedAnnulus+  assertCdtValid "annular constrained refinement" refinedAnnulus++  -- A tiny constraint can share a mesh with coordinates of vastly different+  -- magnitude. Encroachment is discovered by a local cavity walk, so there is+  -- no broad phase for the range to overflow; the pin is that the scaled+  -- circumcenter and diametral predicates still produce exactly one vertex.+  wideGridBuild <- requireRight "wide-grid constrained domain" $ constrainedDelaunay+    unitElementDefaults+    ( V.fromList+        [ Point 0 0+        , Point 2.0e-43 0+        , Point 1.0e60 0+        , Point 0 1.0e60+        ] :: V.Vector (Point)+    )+    (V.singleton (0, 1))+  wideGridRefined <-+    requireRight+      "wide-grid constrained refinement"+      ( refine+          id+          defaultRefinementParameters+            { refineMaxAdditionalVertices = Just 1+            , refineMaxArea = Just 1.0e119+            , refineKeepConstraintEdges = False+            }+          (buildTriangulation wideGridBuild)+      )+  assertEqual "wide-grid refinement count" 1 (refinementAddedVertices wideGridRefined)+  assertCdtValid "wide-grid constrained refinement" (refinedTriangulation wideGridRefined)++-- | A local domain is a closed section, not a hopeful initial queue. Its+-- interface is exact, its protected faces survive point-for-point, and the+-- receipt contains no visit to the protected side.+testCheckedLocalRefinement :: IO ()+testCheckedLocalRefinement = do+  built <-+    requireRight+      "checked local refinement source"+      ( constrainedDelaunay+          unitElementDefaults+          ( V.fromList+              [ Point 0 0+              , Point 4.1 0+              , Point 8 0.2+              , Point 0.1 4+              , Point 4 4.2+              , Point 8.1 4+              ]+          )+          (V.singleton (2, 5))+      )+  let source = buildTriangulation built+      permitted =+        Set.fromList+          [ face+          | face <- innerFaces source+          , faceCentroidX source face < 4.05+          ]+      interface =+        Set.fromList+          [ edge+          | edge <- undirectedEdges source+          , let (forward, backward) = directedPair edge+                forwardFace = incidentFace source forward+                backwardFace = incidentFace source backward+          , forwardFace /= outerFace+          , backwardFace /= outerFace+          , Set.member forwardFace permitted /= Set.member backwardFace permitted+          ]+      protected = filter (`Set.notMember` permitted) (innerFaces source)+      protectedSignatures = fmap (\face -> (face, sort (fmap (vertexPoint source) (faceVertices source face)))) protected+      calmParameters =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just 3+          , refineMaxRadiusEdgeRatio = Nothing+          , refineKeepConstraintEdges = True+          }+      crossingParameters = calmParameters{refineMaxArea = Just 1}+  unless (not (Set.null permitted) && not (null protected) && not (Set.null interface)) $+    fail "checked local refinement fixture did not form a nontrivial cover"+  case refineWithinDomain id calmParameters{refineMaxAdditionalVertices = Nothing} permitted source of+    Left RefinementDomainRequiresFiniteVertexBudget -> pure ()+    outcome -> fail ("checked local refinement accepted an unbounded local budget: " <> either show (const "success") outcome)+  refined <-+    requireRight+      "checked local refinement"+      (refineWithinDomain id calmParameters permitted source)+  let localResult = refinementDomainResult refined+      target = refinedTriangulation localResult+      targetProtectedSignatures = fmap (\face -> (face, sort (fmap (vertexPoint target) (faceVertices target face)))) protected+      receipt = refinementDomainReceipt refined+      finalPermitted = Set.fromList (V.toList (refinementFinalPermittedFaces receipt))+      expectedFinalInterfaceIncidence =+        V.fromList+          [ if Set.member sourceForwardFace permitted+              then (edge, sourceBackwardFace, targetForwardFace)+              else (edge, sourceForwardFace, targetBackwardFace)+          | edge <- Set.toAscList interface+          , let (forward, backward) = directedPair edge+                sourceForwardFace = incidentFace source forward+                sourceBackwardFace = incidentFace source backward+                targetForwardFace = incidentFace target forward+                targetBackwardFace = incidentFace target backward+          ]+      actualFinalInterfaceIncidence = refinementFinalInterfaceIncidence receipt+  assertEqual "checked local protected face restriction" protectedSignatures targetProtectedSignatures+  assertEqual+    "checked local final permitted lineage"+    permitted+    finalPermitted+  assertEqual+    "checked local final interface incidence"+    expectedFinalInterfaceIncidence+    actualFinalInterfaceIncidence+  assertEqual+    "checked local final interface edge set"+    interface+    (Set.fromList [edge | (edge, _, _) <- V.toList actualFinalInterfaceIncidence])+  traverse_+    (\(edge, protectedFace, finalPermittedFace) ->+       unless+         ( Set.notMember protectedFace permitted+             && Set.member finalPermittedFace finalPermitted+         )+         ( fail+             ( "checked local final interface incidence misclassified "+                 <> show (edge, protectedFace, finalPermittedFace)+             )+         )+    )+    actualFinalInterfaceIncidence+  assertEqual "checked local protected visit receipt" V.empty (refinementVisitedProtectedFaces receipt)+  assertEqual "checked local boundary crossing receipt" 0 (refinementAttemptedBoundaryCrossings receipt)+  let closureStats = refinementValidationClosureStats receipt+  unless+    ( validationClosureFaces closureStats > 0+        && validationClosureDirectedEdges closureStats > 0+        && validationClosureVertices closureStats > 0+    ) $+    fail "checked local refinement did not record its selected validation closure"+  assertEqual+    "checked local refinement does not enumerate resident unboxed base pages"+    0+    (publicationUnboxedBasePageEnumerations (refinementPublicationStats receipt))+  assertEqual+    "checked local protected constraint restriction"+    (constraintSegments source)+    (constraintSegments target)+  assertValid "checked local refinement" target+  case refineWithinDomain id crossingParameters permitted source of+    Left (RefinementDomainWouldCrossInterface _ _) -> pure ()+    Left obstruction -> fail ("checked local refinement returned the wrong crossing obstruction: " <> show obstruction)+    Right _ -> fail "checked local refinement silently crossed its immutable interface"+  case refineWithinDomain id calmParameters{refinePreserveConvexHull = False} permitted source of+    Left RefinementDomainRequiresConvexHullPreservation -> pure ()+    outcome -> fail ("checked local refinement accepted hull mutation: " <> either show (const "success") outcome)+  case refineWithinDomain id calmParameters{refineKeepConstraintEdges = False} permitted source of+    Left RefinementDomainRequiresConstraintPreservation -> pure ()+    outcome -> fail ("checked local refinement accepted constraint mutation: " <> either show (const "success") outcome)+  case refineWithinDomain id calmParameters{refineExcludeOuterFaces = True} permitted source of+    Left RefinementDomainForbidsOuterFaceExclusion -> pure ()+    outcome -> fail ("checked local refinement accepted outer-face exclusion: " <> either show (const "success") outcome)+  wholeRefined <-+    requireRight+      "checked whole-section refinement"+      ( refineWithinDomain+          id+          crossingParameters+          (Set.fromList (innerFaces source))+          source+      )+  let wholeResult = refinementDomainResult wholeRefined+      wholeReceipt = refinementDomainReceipt wholeRefined+  unless (refinementAddedVertices wholeResult > 0) $+    fail "checked whole-section refinement did not improve its admitted section"+  unless (not (V.null (refinementCreatedFaces wholeReceipt))) $+    fail "checked whole-section refinement omitted semantically rewritten face slots"+  unless+    ( V.any+        (\(FaceId raw) -> toInteger raw < toInteger (numFaces source))+        (refinementCreatedFaces wholeReceipt)+    ) $+    fail "checked whole-section refinement omitted recycled face slots"+  assertEqual+    "checked whole-section final permitted lineage"+    (Set.fromList (innerFaces (refinedTriangulation wholeResult)))+    (Set.fromList (V.toList (refinementFinalPermittedFaces wholeReceipt)))+  assertValid "checked whole-section refinement" (refinedTriangulation wholeResult)+ where+  faceCentroidX+    :: Triangulation mode vertex directed undirected face+    -> FaceId+    -> Double+  faceCentroidX triangulation face =+    case fmap (vertexPoint triangulation) (faceVertices triangulation face) of+      [] -> 0+      points ->+        sum [x | Point x _ <- points] / fromIntegral (length points)++-- | A maximum edge bound is a local geometric law, not a rendering preference:+-- a long, thin face is split along its longest edge even when its area is below+-- the minimum-area short-circuit. A budget-limited pass remains resumable;+-- once the longest edge is frozen at the local interface, a completed pass+-- returns the exact typed quality obstruction instead of crossing it.+testMaximumEdgeLengthQuality :: IO ()+testMaximumEdgeLengthQuality = do+  built <-+    requireRight+      "maximum-edge long-thin source"+      ( constrainedDelaunay+          unitElementDefaults+          ( V.fromList+              [ Point 0 0+              , Point 10 0+              , Point 10 1+              , Point 0 1+              ]+          )+          (V.fromList [(0, 1), (1, 2), (2, 3), (3, 0)])+      )+  let source = buildTriangulation built+      allPermitted = Set.fromList (innerFaces source)+      parameters =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just 1+          , refineMinArea = Just 6+          , refineMaxEdgeLength = Just 10.01+          , refineMaxRadiusEdgeRatio = Nothing+          , refineKeepConstraintEdges = True+          }+  partial <-+    requireRight+      "maximum-edge budget-limited refinement"+      (refineWithinDomain id parameters allPermitted source)+  let partialResult = refinementDomainResult partial+      partialTarget = refinedTriangulation partialResult+      partialReceipt = refinementDomainReceipt partial+      resumedPermitted = Set.fromList (V.toList (refinementFinalPermittedFaces partialReceipt))+  unless (refinementAddedVertices partialResult > 0) $+    fail "maximum-edge refinement did not split the long edge before the area floor"+  when (refinementComplete partialResult) $+    fail "maximum-edge budget-limited refinement reported completion"+  assertValid "maximum-edge budget-limited refinement" partialTarget+  resumed <-+    requireRight+      "maximum-edge resumed refinement"+      ( refineWithinDomain+          id+          parameters{refineMaxAdditionalVertices = Just 8}+          resumedPermitted+          partialTarget+      )+  let resumedResult = refinementDomainResult resumed+      resumedReceipt = refinementDomainReceipt resumed+  unless (refinementComplete resumedResult) $+    fail "maximum-edge resumed refinement did not drain its local worklist"+  assertMaximumEdgeLength+    "maximum-edge resumed refinement"+    10.01+    (refinedTriangulation resumedResult)+    (V.toList (refinementFinalPermittedFaces resumedReceipt))++  case+      refine+        id+        parameters+          { refineMaxAdditionalVertices = Just 8+          , refineMaxEdgeLength = Just 9+          }+        source of+    Left (RefinementOversizedEdge _ edge actual bound)+      | isConstraintEdge source edge && actual > bound -> pure ()+    Left obstruction ->+      fail ("maximum-edge global audit returned the wrong obstruction: " <> show obstruction)+    Right _ -> fail "maximum-edge global refinement accepted an oversized kept constraint"++  case innerFaces source of+    firstFace : _ -> do+      let permitted = Set.singleton firstFace+          interface =+            Set.fromList+              [ edge+              | edge <- undirectedEdges source+              , let (forward, backward) = directedPair edge+                    forwardFace = incidentFace source forward+                    backwardFace = incidentFace source backward+              , forwardFace /= outerFace+              , backwardFace /= outerFace+              , Set.member forwardFace permitted /= Set.member backwardFace permitted+              ]+      let blocked =+            refineWithinDomain+              id+              parameters{refineMaxAdditionalVertices = Just 8}+              permitted+              source+      case blocked of+        Left (RefinementOversizedEdge face edge actual bound)+          | Set.member face permitted+              && Set.member edge interface+              && actual > bound -> pure ()+        Left obstruction ->+          fail ("maximum-edge interface returned the wrong obstruction: " <> show obstruction)+        Right _ -> fail "maximum-edge interface was silently crossed or accepted"+    [] -> fail "maximum-edge source has no inner face"++-- | A circumcenter can be inside the admitted face while its legalization+-- cavity also meets the immutable interface. That is a true crossing demand,+-- not the boundary-limited locator read discharged by the local interpreter.+testLocalRefinementRejectsTrueInterfaceCrossing :: IO ()+testLocalRefinementRejectsTrueInterfaceCrossing = do+  built <-+    requireRight+      "deterministic true interface crossing source"+      ( constrainedDelaunay+          unitElementDefaults+          ( V.fromList+              [ Point 0 0+              , Point 2 0+              , Point 1 (sqrt 3)+              , Point (-1) (sqrt 3)+              ]+          )+          V.empty+      )+  let source = buildTriangulation built+      equilateralFacePoints = sort [Point 0 0, Point 2 0, Point 1 (sqrt 3)]+      permittedFace =+        List.find+          ( \face ->+              sort (fmap (vertexPoint source) (faceVertices source face))+                == equilateralFacePoints+          )+          (innerFaces source)+  assertEqual "deterministic crossing source has two inner faces" 2 (numInnerFaces source)+  case permittedFace of+    Nothing -> fail "deterministic crossing source omitted its equilateral face"+    Just face -> do+      let permitted = Set.singleton face+          interface =+            Set.fromList+              [ edge+              | edge <- undirectedEdges source+              , let (forward, backward) = directedPair edge+                    forwardFace = incidentFace source forward+                    backwardFace = incidentFace source backward+              , forwardFace /= outerFace+              , backwardFace /= outerFace+              , Set.member forwardFace permitted /= Set.member backwardFace permitted+              ]+          parameters =+            defaultRefinementParameters+              { refineMaxAdditionalVertices = Just 1+              , refineMaxArea = Just 0.5+              , refineMaxRadiusEdgeRatio = Nothing+              , refineKeepConstraintEdges = True+              }+      assertEqual+        "deterministic crossing source has one interface edge"+        1+        (Set.size interface)+      case refineWithinDomain id parameters permitted source of+        Left (RefinementDomainWouldCrossInterface _ _) -> pure ()+        Left obstruction ->+          fail+            ( "deterministic true interface crossing returned the wrong obstruction: "+                <> show obstruction+            )+        Right _ ->+          fail "deterministic true interface crossing was silently accepted"++testRepeatedBoundaryAdjacentRefinement :: IO ()+testRepeatedBoundaryAdjacentRefinement = do+  built <-+    requireRight+      "repeated boundary-adjacent constrained source"+      ( constrainedDelaunay+          unitElementDefaults+          ( V.fromList+              [ Point 0 0+              , Point 4 0+              , Point 8 0+              , Point 12 0+              , Point 0 4+              , Point 4 4+              , Point 8 4+              , Point 12 4+              ]+          )+          (V.singleton (2, 6))+      )+  let source = buildTriangulation built+      sourcePermitted = leftSection source+      fullParameters =+        defaultRefinementParameters+          { refineMaxAdditionalVertices = Just 20+          , refineMaxArea = Just 1+          , refineMaxRadiusEdgeRatio = Nothing+          , refineKeepConstraintEdges = True+          }+  fullRefinement <-+    requireRight+      "full boundary-adjacent refinement"+      (refineWithinDomain id fullParameters sourcePermitted source)+  let fullResult = refinementDomainResult fullRefinement+      fullTarget = refinedTriangulation fullResult+      fullReceipt = refinementDomainReceipt fullRefinement+  unless (refinementAddedVertices fullResult > 0) $+    fail "full boundary-adjacent refinement did not refine its admitted section"+  unless (refinementInterfaceBoundaryReads fullReceipt > 0) $+    fail "boundary-adjacent refinement did not report its immutable interface read"+  assertEqual+    "boundary-adjacent crossing attempts"+    0+    (refinementAttemptedBoundaryCrossings fullReceipt)+  assertEqual+    "full boundary-adjacent constraint restriction"+    (constraintSegments source)+    (constraintSegments fullTarget)+  assertEqual+    "completed boundary-adjacent refinement is idempotent"+    True+    (refinementComplete fullResult)++  let progressParameters = fullParameters{refineMaxAdditionalVertices = Just 1}+  progressFirstRefinement <-+    requireRight+      "first bounded boundary-adjacent refinement"+      (refineWithinDomain id progressParameters sourcePermitted source)+  let progressFirstResult = refinementDomainResult progressFirstRefinement+      progressFirstTarget = refinedTriangulation progressFirstResult+      progressFirstReceipt = refinementDomainReceipt progressFirstRefinement+      progressPermitted =+        Set.fromList (V.toList (refinementFinalPermittedFaces progressFirstReceipt))+  unless (refinementAddedVertices progressFirstResult > 0) $+    fail "first bounded boundary-adjacent refinement did not refine its admitted section"+  when (refinementComplete progressFirstResult) $+    fail "first bounded boundary-adjacent refinement unexpectedly reached a fixpoint"+  progressSecondRefinement <-+    requireRight+      "repeated boundary-adjacent refinement"+      ( refineWithinDomain+          id+          progressParameters+          progressPermitted+          progressFirstTarget+      )+  let progressSecondResult = refinementDomainResult progressSecondRefinement+      progressSecondTarget = refinedTriangulation progressSecondResult+      progressSecondReceipt = refinementDomainReceipt progressSecondRefinement+  unless (refinementAddedVertices progressSecondResult > 0) $+    fail "repeated boundary-adjacent refinement did not retain its dynamic join-face support"+  assertEqual+    "repeated boundary-adjacent protected visits"+    V.empty+    (refinementVisitedProtectedFaces progressSecondReceipt)+  assertEqual+    "repeated boundary-adjacent constraint restriction"+    (constraintSegments progressFirstTarget)+    (constraintSegments progressSecondTarget)+  assertValid "repeated boundary-adjacent refinement" progressSecondTarget+ where+  leftSection+    :: Triangulation mode vertex directed undirected face+    -> Set.Set FaceId+  leftSection triangulation =+    Set.fromList+      [ face+      | face <- innerFaces triangulation+      , faceCentroidX triangulation face < 8+      ]+  faceCentroidX+    :: Triangulation mode vertex directed undirected face+    -> FaceId+    -> Double+  faceCentroidX triangulation face =+    case fmap (vertexPoint triangulation) (faceVertices triangulation face) of+      [] -> 0+      points ->+        sum [x | Point x _ <- points] / fromIntegral (length points)++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)+  assertEqual+    "component loop provenance mismatch is typed before DCEL lookup"+    (Left (BoundaryComponentFaceOutOfRange (FaceId 2) 2))+    (componentBoundaryLoops triangle squareComponent)+  squareBoundary <- requireRight "uniform square boundary" (componentBoundary square squareComponent)+  squareLoops <-+    requireRight+      "uniform square oriented boundary loops"+      (componentBoundaryLoops square squareComponent)+  repeatedSquareBoundary <-+    requireRight "repeated uniform square boundary" (componentBoundary square squareComponent)+  assertEqual "boundary extraction is deterministic" squareBoundary repeatedSquareBoundary+  assertEqual+    "ordinary oriented loops agree with strict boundary"+    (regionBoundaryOuterLoop squareBoundary :| regionBoundaryHoleLoops squareBoundary)+    squareLoops+  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))+  assertEqual+    "resident boundary retains every hull edge endpoint"+    (Set.fromList [Point 0 0, Point 1 0, Point 2 0, Point 2 2, Point 0 2])+    (residentLoopPointSet collinearHull (regionBoundaryOuterLoop collinearBoundary))+  assertEqual+    "resident boundary follows exact DCEL edges"+    True+    (residentBoundaryIsEdgeCycle 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)+  pinchedLoops <-+    requireRight+      "pinched oriented boundary loops"+      (componentBoundaryLoops pinched pinchedComponent)+  let pinchedLoopList = toList pinchedLoops+  assertEqual "pinched simple loop count" 2 (length pinchedLoopList)+  assertEqual+    "pinched simple loop vertex counts"+    [4, 6]+    (sort (fmap (length . boundaryLoopVertices) pinchedLoopList))+  assertEqual+    "pinched loop orientations"+    [BoundaryCounterClockwise, BoundaryClockwise]+    (sort (fmap boundaryLoopOrientation pinchedLoopList))+  traverse_+    (\loop -> do+       let loopVertexIds = toList (boundaryLoopVertices loop)+       assertEqual+         "pinched loop has no repeated vertex"+         (length loopVertexIds)+         (Set.size (Set.fromList loopVertexIds))+       assertLoopWinding+         "pinched loop winding agrees with orientation"+         (case boundaryLoopOrientation loop of+            BoundaryCounterClockwise -> GT+            BoundaryClockwise -> LT)+         pinched+         loop)+    pinchedLoopList+  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++residentLoopPointSet+  :: Triangulation mode vertex directed undirected face+  -> BoundaryLoop+  -> Set.Set Point+residentLoopPointSet triangulation =+  Set.fromList+    . fmap (vertexPoint triangulation)+    . toList+    . boundaryLoopResidentVertices++residentBoundaryIsEdgeCycle+  :: Triangulation mode vertex directed undirected face+  -> BoundaryLoop+  -> Bool+residentBoundaryIsEdgeCycle triangulation loop =+  let first :| remaining = boundaryLoopResidentVertices loop+      adjacentPairs = zip (first : remaining) (remaining <> [first])+   in all+        (\(fromVertex, toVertex) ->+           any+             ((== toVertex) . destination triangulation)+             (vertexOutgoingEdges triangulation fromVertex))+        adjacentPairs++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 orientation")+    BoundaryCounterClockwise+    (boundaryLoopOrientation (regionBoundaryOuterLoop boundary))+  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 orientation")+         BoundaryClockwise+         (boundaryLoopOrientation hole)+       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]+  forwardStart <- requireQueryPoint "forward traversal start" (Point (-4) 0)+  forwardEnd <- requireQueryPoint "forward traversal end" (Point 4 0)+  let triangulation = buildTriangulation built+      forward = lineIntersections triangulation forwardStart forwardEnd+      backward = lineIntersections triangulation forwardEnd forwardStart+  when (null forward) $ fail "ordered line traversal crossed nothing"+  assertEqual+    "reversing the segment reverses crossing order and orientation"+    (map reverseTraversalEvent forward)+    (reverse backward)+  interiorEnd <- requireQueryPoint "outside traversal interior end" (Point 0.25 0.5)+  let outsideToInterior = lineIntersections triangulation forwardStart interiorEnd+      interiorToOutside = lineIntersections triangulation interiorEnd forwardStart+  when (null outsideToInterior) $ fail "outside-to-interior traversal crossed nothing"+  assertEqual+    "endpoint-directed outside traversal preserves order and orientation"+    (map reverseTraversalEvent outsideToInterior)+    (reverse interiorToOutside)+  missFrom <- requireQueryPoint "outside traversal miss from" (Point (-4) 4)+  missTo <- requireQueryPoint "outside traversal miss to" (Point 4 4)+  assertEqual+    "outside segment missing the hull reports no intersections"+    []+    (lineIntersections triangulation missFrom missTo)+  circleEdges <- Set.fromList <$> requireRight "circle edge query" (edgesInCircle triangulation (Point 0 0) 4)+  let bruteCircle = Set.fromList+        [ edge+        | edge <- undirectedEdges triangulation+        , let (a, b) = undirectedEndpoints triangulation edge+        , segmentDistanceSquared (vertexPoint triangulation a) (vertexPoint triangulation b) (Point 0 0) <= 4+        ]+  assertEqual "circle edge flood" bruteCircle circleEdges+  assertEqual+    "negative circle metric refusal"+    (Left (InvalidCircleRadius (NegativeRadiusSquared (-1))))+    (circleMetric (Point 0 0 :: Point) (-1))+  assertEqual+    "negative circle edge-query refusal"+    (Left (InvalidCircleRadius (NegativeRadiusSquared (-1))))+    (edgesInCircle triangulation (Point 0 0) (-1))+  assertEqual+    "negative circle vertex-query refusal"+    (Left (InvalidCircleRadius (NegativeRadiusSquared (-1))))+    (verticesInCircle triangulation (Point 0 0) (-1))+  assertEqual+    "NaN circle metric refusal"+    (Left (InvalidCircleRadius (NonFiniteRadiusSquared ValueNaN)))+    (circleMetric (Point 0 0 :: Point) (0 / 0))+  assertEqual+    "NaN circle center-x refusal"+    (Left (InvalidCircleCenter (InvalidPointX CoordinateNaN)))+    (circleMetric (Point (0 / 0) 0 :: Point) 1)+  assertEqual+    "positive-infinite circle center-y refusal"+    (Left (InvalidCircleCenter (InvalidPointY CoordinateInfinite)))+    (edgesInCircle triangulation (Point 0 (1 / 0)) 1)+  assertEqual+    "negative-infinite circle center-x refusal"+    (Left (InvalidCircleCenter (InvalidPointX CoordinateInfinite)))+    (verticesInCircle triangulation (Point ((-1) / 0) 0) 1)+  assertEqual+    "infinite circle edge-query refusal"+    (Left (InvalidCircleRadius (NonFiniteRadiusSquared ValuePositiveInfinity)))+    (edgesInCircle triangulation (Point 0 0) (1 / 0))+  assertEqual+    "negative-infinite circle vertex-query refusal"+    (Left (InvalidCircleRadius (NonFiniteRadiusSquared ValueNegativeInfinity)))+    (verticesInCircle triangulation (Point 0 0) ((-1) / 0))+  rectangleVertices <-+    Set.fromList+      <$> requireRight+        "rectangle query"+        (verticesInRectangle triangulation (Point (-1.1) (-2.1)) (Point 1.1 2.1))+  let bruteVertices = Set.fromList+        [ vertex+        | vertex <- vertices triangulation+        , let Point x y = vertexPoint triangulation vertex+        , x >= (-1.1), x <= 1.1, y >= (-2.1), y <= 2.1+        ]+  assertEqual "rectangle vertex flood" bruteVertices rectangleVertices++testRandomizedConstruction :: IO ()+testRandomizedConstruction = do+  forM_ [0 .. 31] $ \index -> do+    let points = randomPoints (0x9e37_79b9 + fromIntegral index) (40 + index * 7)+    built <- requirePointBuild ("random build " <> show index) points+    let triangulation = buildTriangulation built+    assertValid ("random build " <> show index) triangulation+    assertEqual "random input mapping" (length points) (sizeofPrimArray (buildInputVertices built))++testErrors :: IO ()+testErrors = do+  assertEqual+    "NaN query x refusal"+    (Left (InvalidPointX CoordinateNaN))+    (mkQueryPoint (Point (0 / 0) 0))+  assertEqual+    "infinite query y refusal"+    (Left (InvalidPointY CoordinateInfinite))+    (mkQueryPoint (Point 0 (1 / 0)))+  assertEqual+    "negative-infinite query x refusal"+    (Left (InvalidPointX CoordinateInfinite))+    (mkQueryPoint (Point ((-1) / 0) 0))+  case delaunay unitElementDefaults (V.singleton (Point (0 / 0) 0 :: Point)) of+    Left (InvalidCoordinate (Just 0) _ CoordinateNaN) -> pure ()+    Left other -> fail ("NaN insertion result: " <> show other)+    Right built ->+      fail+        ( "NaN insertion result: built a triangulation of "+            <> show (numVertices (buildTriangulation built))+            <> " vertices"+        )+  expectBuildFailure+    "NaN minimum angle"+    (RefinementMinimumAngleNotFinite ValueNaN)+    (withMinimumAngle (0 / 0 :: Double) defaultRefinementParameters)+  expectBuildFailure+    "infinite minimum angle"+    (RefinementMinimumAngleNotFinite ValuePositiveInfinity)+    (withMinimumAngle (1 / 0 :: Double) defaultRefinementParameters)+  expectBuildFailure+    "out-of-range minimum angle"+    (RefinementMinimumAngleOutOfRange 61)+    (withMinimumAngle (61 :: Double) defaultRefinementParameters)+  expectBuildFailure+    "minimum angle whose derived ratio overflows"+    (RefinementMinimumAngleDerivedRatioNotFinite ValuePositiveInfinity)+    (withMinimumAngle (encodeFloat 1 (-1074) :: Double) defaultRefinementParameters)+  square <- requirePointBuild "area validation square" [Point 0 0, Point 1 0, Point 1 1, Point 0 1]+  let refineWith parameters =+        refine id parameters (buildTriangulation square)+      refineWithArea area =+        refineWith defaultRefinementParameters{refineMaxArea = Just area}+  expectBuildFailure+    "negative refinement vertex budget"+    (RefinementMaximumAdditionalVerticesNegative (-1))+    (refineWith defaultRefinementParameters{refineMaxAdditionalVertices = Just (-1)})+  expectBuildFailure+    "infinite minimum area"+    (RefinementMinimumAreaNotFinite ValuePositiveInfinity)+    (refineWith defaultRefinementParameters{refineMinArea = Just (1 / 0)})+  expectBuildFailure+    "negative minimum area"+    (RefinementMinimumAreaNegative (-1))+    (refineWith defaultRefinementParameters{refineMinArea = Just (-1)})+  expectBuildFailure+    "NaN maximum area"+    (RefinementMaximumAreaNotFinite ValueNaN)+    (refineWithArea (0 / 0))+  expectBuildFailure+    "infinite maximum area"+    (RefinementMaximumAreaNotFinite ValuePositiveInfinity)+    (refineWithArea (1 / 0))+  expectBuildFailure+    "zero maximum area"+    (RefinementMaximumAreaNotPositive 0)+    (refineWithArea 0)+  expectBuildFailure+    "negative maximum area"+    (RefinementMaximumAreaNotPositive (-1))+    (refineWithArea (-1))+  expectBuildFailure+    "infinite maximum radius/edge ratio"+    (RefinementMaximumRadiusEdgeRatioNotFinite ValuePositiveInfinity)+    (refineWith defaultRefinementParameters{refineMaxRadiusEdgeRatio = Just (1 / 0)})+  expectBuildFailure+    "non-positive maximum radius/edge ratio"+    (RefinementMaximumRadiusEdgeRatioNotPositive 0)+    (refineWith defaultRefinementParameters{refineMaxRadiusEdgeRatio = Just 0})+  expectBuildFailure+    "infinite maximum edge length"+    (RefinementMaximumEdgeLengthNotFinite ValuePositiveInfinity)+    (refineWith defaultRefinementParameters{refineMaxEdgeLength = Just (1 / 0)})+  expectBuildFailure+    "non-positive maximum edge length"+    (RefinementMaximumEdgeLengthNotPositive 0)+    (refineWith defaultRefinementParameters{refineMaxEdgeLength = Just 0})+  expectBuildFailure+    "minimum area above maximum area"+    (RefinementMinimumAreaExceedsMaximum 2 1)+    ( refineWith+        defaultRefinementParameters+          { refineMinArea = Just 2+          , refineMaxArea = Just 1+          }+    )+  case refineWithArea 0.25 of+    Right _ -> pure ()+    Left failure -> fail ("positive maximum area rejected: " <> show failure)++expectBuildFailure :: String -> BuildError -> Either BuildError value -> IO ()+expectBuildFailure label expected outcome =+  case outcome of+    Left actual -> assertEqual label expected actual+    Right _ -> fail (label <> ": expected " <> show expected <> ", got success")+++canonicalEdges+  :: Triangulation mode vertex directed undirected face+  -> Set.Set (Point, Point)+canonicalEdges triangulation =+  Set.fromList+    [ ordered (vertexPoint triangulation (origin triangulation edge)) (vertexPoint triangulation (destination triangulation edge))+    | undirected <- undirectedEdges triangulation+    , let edge = normalizedDirected undirected+    ]+ where+  ordered :: Ord value => value -> value -> (value, value)+  ordered left right = if left <= right then (left, right) else (right, left)++requireJust :: String -> Maybe value -> IO value+requireJust _ (Just value) = pure value+requireJust label Nothing = fail (label <> ": expected Just")++requireAcceptedConstraint+  :: String+  -> ConstraintBatchResult vertex directed undirected face+  -> IO (V.Vector DirectedEdgeId, Int)+requireAcceptedConstraint label batch =+  case V.toList (constraintBatchOutcomes batch) of+    [ConstraintAccepted path added] -> pure (path, added)+    outcomes ->+      fail+        ( label+            <> ": expected one accepted constraint, got "+            <> show outcomes+        )++assertBatchStats+  :: String+  -> ConstraintBatchResult vertex directed undirected face+  -> IO ()+assertBatchStats label batch = do+  let stats = constraintBatchStats batch+      (accepted, rejected) =+        V.foldl'+          (\(!acceptedCount, !rejectedCount) outcome ->+            case outcome of+              ConstraintAccepted _ _ -> (acceptedCount + 1, rejectedCount)+              ConstraintRejected _ -> (acceptedCount, rejectedCount + 1)+          )+          (0, 0)+          (constraintBatchOutcomes batch)+  assertEqual+    (label <> " request count")+    (V.length (constraintBatchOutcomes batch))+    (constraintBatchRequests stats)+  assertEqual+    (label <> " accepted count")+    accepted+    (constraintBatchAccepted stats)+  assertEqual+    (label <> " rejected count")+    rejected+    (constraintBatchRejected stats)++replayConstraintRequest+  :: (ConstrainedDelaunayTriangulation (Point), [ConstraintOutcome])+  -> (VertexId, VertexId)+  -> Either+      (CdtError)+      (ConstrainedDelaunayTriangulation (Point), [ConstraintOutcome])+replayConstraintRequest (current, outcomes) request = do+  singleton <- recoverConstraints current (V.singleton request)+  case V.toList (constraintBatchOutcomes singleton) of+    [outcome] ->+      Right+        ( constraintBatchTriangulation singleton+        , outcome : outcomes+        )+    cardinality ->+      Left+        ( ConstraintBatchCardinalityMismatch+            1+            (length cardinality)+        )++requirePointBuild :: String -> [Point] -> IO (BuildResult 'Unconstrained (Point) () () ())+requirePointBuild label points = requireRight label (delaunay unitElementDefaults (V.fromList points))++assertCdtValid :: String -> Triangulation 'Constrained vertex () () () -> IO ()+assertCdtValid label triangulation =+  case validateTriangulation triangulation of+    [] -> pure ()+    violations -> fail (label <> " CDT violations: " <> show violations)++assertMaximumEdgeLength+  :: String+  -> Double+  -> Triangulation mode vertex directed undirected face+  -> [FaceId]+  -> IO ()+assertMaximumEdgeLength label maximumLength triangulation faces =+  unless (null violations) $+    fail (label <> " oversized edges: " <> show (take 1 violations))+ where+  !maximumSquaredLength = maximumLength * maximumLength+  violations =+    [ (face, edge, squaredLength)+    | face <- faces+    , directed <- faceDirectedEdges triangulation face+    , let edge = asUndirected directed+          (fromVertex, toVertex) = undirectedEndpoints triangulation edge+          squaredLength =+            squaredDistanceWide+              (vertexPoint triangulation fromVertex)+              (vertexPoint triangulation toVertex)+    , squaredLength > maximumSquaredLength+    ]++canonicalSegmentSquaredLength :: CanonicalSegment -> Double+canonicalSegmentSquaredLength segmentValue =+  squaredDistanceWide+    (segmentStart segmentValue)+    (segmentEnd segmentValue)++assertNear :: String -> Double -> Double -> Double -> IO ()+assertNear label tolerance expected actual =+  unless (abs (expected - actual) <= tolerance * max 1 (max (abs expected) (abs actual))) $+    fail (label <> ": expected " <> show expected <> ", got " <> show actual)++gridPoints :: Int -> Int -> [Point]+gridPoints width height =+  [ Point (fromIntegral x + jitter x y) (fromIntegral y + jitter y x)+  | y <- [0 .. height - 1]+  , x <- [0 .. width - 1]+  ]+ where+  jitter :: Int -> Int -> Double+  jitter a b = fromIntegral ((a * 17 + b * 31) `mod` 11) * 1.0e-5++randomPoints :: Word64 -> Int -> [Point]+randomPoints seed count = take count (go seed Set.empty)+ where+  go :: Word64 -> Set.Set (Point) -> [Point]+  go state seen =+    let state1 = lcg state+        state2 = lcg state1+        x = unit state1 * 2 - 1+        y = unit state2 * 2 - 1+        point = Point x y+     in if Set.member point seen+          then go state2 seen+          else point : go state2 (Set.insert point seen)++  unit :: Word64 -> Double+  unit value = fromIntegral (value `mod` 9_007_199_254_740_881) / 9_007_199_254_740_881++  lcg :: Word64 -> Word64+  lcg value = value * 6_364_136_223_846_793_005 + 1_442_695_040_888_963_407
+ test/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/parallel/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.ParallelSpec as ParallelSpec++main :: IO ()+main = ParallelSpec.tests
+ test/parallel/Moonlight/Triangulation/ParallelSpec.hs view
@@ -0,0 +1,72 @@+-- | The one module in the package that spawns threads. Its whole contract is+-- that scheduling is invisible: the same tournament, the same value, at every+-- worker count. That is what is asserted here, because a concurrent join whose+-- result depended on the worker count would be wrong in a way no amount of+-- validity checking on a single run could see.+module Moonlight.Triangulation.ParallelSpec+  ( tests+  ) where++import qualified Data.List.NonEmpty as NE+import Moonlight.Triangulation (unions)+import Moonlight.Triangulation.AlgebraFixtures (Mesh, assertMesh, operands)+import Moonlight.Triangulation.Parallel (unionsConcurrently)+import Support (requireRight)++tests :: IO ()+tests = do+  testConcurrentJoinAgreesWithSequential+  testConcurrentJoinIsWorkerCountInvariant+  putStrLn "parallel: ok"++-- Counts on both sides of the operand count, so the tournament is starved at+-- one end and saturated at the other, and 1 exercises the sequential-collapse+-- branch that a purely concurrent test would never reach.+workerCounts :: [Int]+workerCounts = [1, 2, 3, 5, 16]++concurrentJoin :: Int -> NE.NonEmpty Mesh -> IO Mesh+concurrentJoin workers shards = do+  outcome <- unionsConcurrently workers shards+  requireRight ("concurrent unions at " <> show workers <> " workers") outcome++-- The sequential tournament is the oracle. It is a different interpreter over+-- the same plan, not a second copy of this one, so agreement is evidence.+testConcurrentJoinAgreesWithSequential :: IO ()+testConcurrentJoinAgreesWithSequential = do+  shards <- fmap (map snd) operands+  nonEmptyShards <- case NE.nonEmpty shards of+    Nothing -> fail "concurrent join agreement: no operands"+    Just present -> pure present+  sequential <- requireRight "sequential unions" (unions shards)+  mapM_+    ( \workers -> do+        concurrent <- concurrentJoin workers nonEmptyShards+        assertMesh+          ("concurrent tournament at " <> show workers <> " workers")+          sequential+          concurrent+    )+    workerCounts++-- Stated separately from agreement: even if both interpreters were wrong in+-- the same way, a result that moved with the worker count would still be a+-- defect, and this is the assertion that would catch it.+testConcurrentJoinIsWorkerCountInvariant :: IO ()+testConcurrentJoinIsWorkerCountInvariant = do+  shards <- fmap (map snd) operands+  nonEmptyShards <- case NE.nonEmpty shards of+    Nothing -> fail "worker-count invariance: no operands"+    Just present -> pure present+  results <- traverse (`concurrentJoin` nonEmptyShards) workerCounts+  case results of+    [] -> fail "worker-count invariance: no worker counts"+    (reference : rest) ->+      mapM_+        ( \(workers, result) ->+            assertMesh+              ("worker count " <> show workers <> " agrees with the first")+              reference+              result+        )+        (zip (drop 1 workerCounts) rest)
+ test/persistence-rose/Main.hs view
@@ -0,0 +1,196 @@+module Main (main) where++import Data.ByteString qualified as ByteString+import Data.List (isInfixOf, isPrefixOf, isSuffixOf)+import Data.Word (Word8)+import Moonlight.Triangulation.Exhibit.PersistenceRose+  ( AlphaEclipseReceipt (..),+    AlphaEclipseScene,+    PersistenceRoseAnimationReceipt (..),+    PersistenceRoseReceipt (..),+    PersistenceRoseScene,+    alphaEclipseReceipt,+    buildAlphaEclipseScene,+    buildPersistenceRoseScene,+    persistenceRoseFrameSpecs,+    persistenceRoseReceipt,+    renderPersistenceRoseFrame,+    renderPersistenceRosePoster,+    renderAlphaEclipse,+    stampPersistenceRoseGif,+    verifyPersistenceRoseGif,+  )+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit+  ( Assertion,+    assertBool,+    assertFailure,+    testCase,+    (@?=),+  )++main :: IO ()+main = defaultMain persistenceRoseTests++persistenceRoseTests :: TestTree+persistenceRoseTests =+  testGroup+    "persistence rose"+    [ testCase "scene builds from canonical owners" testSceneBuilds,+      testCase "hero holes agree with persistent beta one" testHeroAgreement,+      testCase "Sibson field has no fallback" testSibsonField,+      testCase "poster is deterministic SVG" testPosterDeterminism,+      testCase "frame sweep closes exactly" testFrameSweepClosure,+      testCase "alpha eclipse is the exact resident square interval" testAlphaEclipseSemantics,+      testCase "alpha eclipse is deterministic SVG" testAlphaEclipseDeterminism,+      testCase "GIF provenance binds the canonical frame section" testGifProvenance+    ]++withScene :: (PersistenceRoseScene -> Assertion) -> Assertion+withScene = withResult buildPersistenceRoseScene++withAlphaEclipse :: (AlphaEclipseScene -> Assertion) -> Assertion+withAlphaEclipse = withResult buildAlphaEclipseScene++withResult :: Show failure => Either failure value -> (value -> Assertion) -> Assertion+withResult result assertion = either (assertFailure . show) assertion result++testSceneBuilds :: Assertion+testSceneBuilds =+  withScene $ \scene -> do+    let receipt = persistenceRoseReceipt scene+    assertBool "the deterministic cover should contain at least one hundred sites" (roseSiteCount receipt >= 100)+    assertBool "Delaunay edges should be nontrivial" (roseEdgeCount receipt > roseSiteCount receipt)+    assertBool "bounded faces should be nontrivial" (roseFaceCount receipt > 0)+    assertBool "the alpha filtration should have many exact critical births" (roseCriticalBirthCount receipt > 20)+    assertBool "the exact barcode should contain finite H1 intervals" (roseFinitePersistentHoleCount receipt > 0)+    assertBool "the Voronoi dual should contain finite segments" (roseVoronoiSegmentCount receipt > 0)+    assertBool "the exact overlay and Minkowski mask should remain nonempty" (roseMaskComponentCount receipt > 0)++testHeroAgreement :: Assertion+testHeroAgreement =+  withScene $ \scene -> do+    let receipt = persistenceRoseReceipt scene+    assertBool "the hero state should display at least seven independent holes" (roseHeroBettiOne receipt >= 7)+    roseHeroGeometricHoleCount receipt @?= roseHeroBettiOne receipt++testSibsonField :: Assertion+testSibsonField =+  withScene $ \scene -> do+    let receipt = persistenceRoseReceipt scene+    assertBool "the field should contain a dense interior sample" (roseNaturalNeighborSampleCount receipt > 300)+    roseNaturalNeighborFallbackCount receipt @?= 0++testPosterDeterminism :: Assertion+testPosterDeterminism =+  withScene $ \scene -> do+    let firstPoster = renderPersistenceRosePoster scene+        secondPoster = renderPersistenceRosePoster scene+    firstPoster @?= secondPoster+    assertBool "poster should be an SVG document" ("<svg" `isPrefixOf` firstPoster && "</svg>\n" `isSuffixOf` firstPoster)+    assertBool+      "poster should explain beta one semantically"+      ("7 independent one-dimensional holes" `isInfixOf` firstPoster)+    assertBool+      "poster should identify the scale-local topology"+      ("TOPOLOGICAL HOLES AT THIS SCALE" `isInfixOf` firstPoster)+    assertBool+      "poster should omit the old alpha subtitle"+      (not ("EXACT ALPHA / PERSISTENT H1" `isInfixOf` firstPoster))+    assertBool+      "poster should omit the capability footer"+      (not ("VORONOI DUAL · SIBSON FIELD · EXACT OVERLAY" `isInfixOf` firstPoster))+    assertBool+      "poster should omit the receipt footer"+      (not ("glued bounded complement components at the hero state" `isInfixOf` firstPoster))++testFrameSweepClosure :: Assertion+testFrameSweepClosure =+  withScene $ \scene ->+    case persistenceRoseFrameSpecs 49 of+      Left frameError -> assertFailure (show frameError)+      Right frames ->+        case endpoints frames of+          Nothing -> assertFailure "a valid frame count produced no frames"+          Just (firstFrame, finalFrame) -> do+            let firstSvg = renderPersistenceRoseFrame scene firstFrame+            firstSvg @?= renderPersistenceRoseFrame scene finalFrame+            assertBool+              "animation should omit the old descent subtitle"+              (not ("ALPHA DESCENT / GLUING" `isInfixOf` firstSvg))++testAlphaEclipseSemantics :: Assertion+testAlphaEclipseSemantics =+  withAlphaEclipse $ \scene -> do+    let receipt = alphaEclipseReceipt scene+    eclipseSiteCount receipt @?= 4+    eclipseEdgeCount receipt @?= 5+    eclipseFaceCount receipt @?= 2+    (eclipseHoleBirthNumerator receipt, eclipseHoleBirthDenominator receipt) @?= (1, 1)+    (eclipseHoleDeathNumerator receipt, eclipseHoleDeathDenominator receipt) @?= (2, 1)+    (eclipseBettiBeforeBirth receipt, eclipseBettiAtBirth receipt, eclipseBettiAtDeath receipt)+      @?= (0, 1, 0)++testAlphaEclipseDeterminism :: Assertion+testAlphaEclipseDeterminism =+  withAlphaEclipse $ \scene -> do+    let firstSvg = renderAlphaEclipse scene+        secondSvg = renderAlphaEclipse scene+    firstSvg @?= secondSvg+    assertBool "eclipse should be an SVG document" ("<svg" `isPrefixOf` firstSvg && "</svg>\n" `isSuffixOf` firstSvg)+    assertBool "eclipse should name the exact finite interval" ("birth α² = 1" `isInfixOf` firstSvg && "death α² = 2" `isInfixOf` firstSvg)+    assertBool "eclipse should identify one fixed resident DCEL" ("ONE FIXED DELAUNAY DCEL" `isInfixOf` firstSvg)++testGifProvenance :: Assertion+testGifProvenance =+  withScene $ \scene ->+    case stampPersistenceRoseGif scene syntheticCanonicalGif of+      Left gifError -> assertFailure (show gifError)+      Right (stampedReceipt, stamped) -> do+        roseAnimationFrameCount stampedReceipt @?= 65+        case stampPersistenceRoseGif scene stamped of+          Left gifError -> assertFailure (show gifError)+          Right (restampedReceipt, restamped) -> do+            restampedReceipt @?= stampedReceipt+            restamped @?= stamped+        case verifyPersistenceRoseGif scene stamped of+          Left gifError -> assertFailure (show gifError)+          Right receipt -> do+            roseAnimationFrameCount receipt @?= 65+            roseAnimationFramesPerSecond receipt @?= 8+            (roseAnimationWidth receipt, roseAnimationHeight receipt) @?= (960, 540)++syntheticCanonicalGif :: ByteString.ByteString+syntheticCanonicalGif =+  ByteString.pack+    ( [ 0x47, 0x49, 0x46, 0x38, 0x39, 0x61,+        0xc0, 0x03,+        0x1c, 0x02,+        0x00, 0x00, 0x00+      ]+        <> concatMap syntheticGifFrame [0 .. 64]+        <> [0x3b]+    )++syntheticGifFrame :: Int -> [Word8]+syntheticGifFrame frameIndex =+  [ 0x21, 0xf9, 0x04, 0x00,+    if even frameIndex then 0x0d else 0x0c,+    0x00, 0x00, 0x00,+    0x2c,+    0x00, 0x00,+    0x00, 0x00,+    0x01, 0x00,+    0x01, 0x00,+    0x00,+    0x02,+    0x02, 0x44, 0x01,+    0x00+  ]++endpoints :: [value] -> Maybe (value, value)+endpoints values =+  case values of+    [] -> Nothing+    firstValue : remainingValues ->+      Just (firstValue, foldl' (\_ nextValue -> nextValue) firstValue remainingValues)
+ test/public-components/Main.hs view
@@ -0,0 +1,131 @@+module Main (main) where++import Data.Bifunctor (first)+import qualified Data.Vector as Vector+import Moonlight.Triangulation.BulkLoad (delaunayGeometry)+import Moonlight.Triangulation.Dcel (numVertices)+import Moonlight.Triangulation.FloodFillIterator+  ( RectangleMetricError+  , verticesInRectangle+  )+import Moonlight.Triangulation.Handles.Iterators.DynamicIterators+  ( vertexHandles+  )+import Moonlight.Triangulation.Handles.Scoped+  ( scopedVertexPoint+  , scopedVertices+  , withScopedTriangulation+  )+import Moonlight.Triangulation.PointLocation (locatePoint)+import Moonlight.Triangulation.Session+  ( insertVertexAtNearVertex+  , removeAt+  , withSession+  )+import Moonlight.Triangulation.Types+  ( BuildError+  , InsertionDisposition (Inserted)+  , Location (OnVertex)+  , Point (..)+  , PointValidationError+  )+import Moonlight.Triangulation.Math (mkQueryPoint, orient2d)+import Moonlight.Triangulation.Validation (validateTriangulation)+import System.Exit (die)++data PublicComponentFailure+  = PublicBuildFailure !BuildError+  | PublicQueryFailure !PointValidationError+  | PublicRectangleFailure !RectangleMetricError+  | PublicSeedVertexMissing+  deriving stock (Show)++data PublicComponentSummary = PublicComponentSummary+  { residentVertices :: !Int+  , owningVertexHandles :: !Int+  , scopedVertexPoints :: !Int+  , rectangleVertices :: !Int+  , locatedResidentVertex :: !Bool+  , admittedPredicateCorrect :: !Bool+  , sessionInsertedVertex :: !Bool+  , sessionRemovedVertex :: !Bool+  , finalMeshValid :: !Bool+  }+  deriving stock (Eq, Show)++main :: IO ()+main =+  either+    (die . ("public component workflow refused: " <>) . show)+    assertExpected+    publicComponentWorkflow++publicComponentWorkflow :: Either PublicComponentFailure PublicComponentSummary+publicComponentWorkflow = do+  square <-+    first PublicBuildFailure+      ( delaunayGeometry+          ( Vector.fromList+              [ Point (-1) (-1)+              , Point 1 (-1)+              , Point 1 1+              , Point (-1) 1+              ]+          )+      )+  query <- first PublicQueryFailure (mkQueryPoint (Point (-1) (-1)))+  seed <- case locatePoint square query of+    OnVertex vertex -> Right vertex+    _ -> Left PublicSeedVertexMissing+  ((disposition, removed), restored, _) <-+    first PublicBuildFailure+      ( withSession square 1 $ do+          (_, inserted) <- insertVertexAtNearVertex seed (Point 0 0) ()+          removal <- removeAt (Point 0 0)+          pure (inserted, removal)+      )+  queryRight <- first PublicQueryFailure (mkQueryPoint (Point 1 (-1)))+  queryTop <- first PublicQueryFailure (mkQueryPoint (Point (-1) 1))+  inside <-+    first PublicRectangleFailure+      (verticesInRectangle restored (Point (-2) (-2)) (Point 2 2))+  pure+    PublicComponentSummary+      { residentVertices = numVertices restored+      , owningVertexHandles = length (vertexHandles restored)+      , scopedVertexPoints =+          withScopedTriangulation restored $ \scoped ->+            length (fmap (scopedVertexPoint scoped) (scopedVertices scoped))+      , rectangleVertices = length inside+      , locatedResidentVertex = case locatePoint restored query of+          OnVertex _ -> True+          _ -> False+      , admittedPredicateCorrect = orient2d query queryRight queryTop == GT+      , sessionInsertedVertex = disposition == Inserted+      , sessionRemovedVertex = maybe False (const True) removed+      , finalMeshValid = null (validateTriangulation restored)+      }++assertExpected :: PublicComponentSummary -> IO ()+assertExpected actual+  | actual == expected = putStrLn "public components: ok"+  | otherwise =+      die+        ( "public component summary mismatch; expected "+            <> show expected+            <> ", got "+            <> show actual+        )+ where+  expected =+    PublicComponentSummary+      { residentVertices = 4+      , owningVertexHandles = 4+      , scopedVertexPoints = 4+      , rectangleVertices = 4+      , locatedResidentVertex = True+      , admittedPredicateCorrect = True+      , sessionInsertedVertex = True+      , sessionRemovedVertex = True+      , finalMeshValid = True+      }
+ test/serialization/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified Moonlight.Triangulation.SerializationSpec as SerializationSpec++main :: IO ()+main = SerializationSpec.tests
+ test/serialization/Moonlight/Triangulation/SerializationSpec.hs view
@@ -0,0 +1,305 @@+{-# 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 (unless)+import Data.Binary (Binary)+import Data.Binary.Put (putWord16be, putWord32be, putWord64be, putWord8, runPut)+import qualified Data.ByteString.Lazy as BL+import Data.Foldable (traverse_)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Vector as V+import Data.Word (Word16, Word64)+import GHC.Generics (Generic)+import Moonlight.Triangulation+import Moonlight.Triangulation.Internal.HandleDefs (DirectedEdgeId (..), FaceId (..))+import Moonlight.Triangulation.Serialization+import Moonlight.Triangulation.Types (KnownConstraintMode)+import Support (assertEqual, assertValid, requireRight)++tests :: IO ()+tests = do+  testRoundTrip+  testDegenerateCardinalityRoundTrips+  testConstrainedRoundTrip+  testIndependentPayloadGeometryRoundTrip+  testPointPayloadRoundTrip+  testCanonicalizesSerializedSignedZero+  testRejectsHostileStructuralPrefixes+  testRejectsOutOfRangeOuterFaceReference+  testRejectsCorruption+  putStrLn "all serialization tests passed"++data SerialVertex = SerialVertex+  { serialPosition :: !(Point)+  , serialLabel :: !Int+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData, Binary)++instance HasPosition SerialVertex where+  position = serialPosition++type SerialTriangulation = Triangulation 'Unconstrained SerialVertex Int Bool String++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)+      payloads =+        V.fromList+          [ SerialVertex (Point 0 0) 10+          , SerialVertex (Point 2 0) 20+          , SerialVertex (Point 0 2) 30+          , SerialVertex (Point 0.5 0.5) 40+          ]+  buildTriangulation <$> requireRight "serialization source" (delaunay defaults payloads)++testRoundTrip :: IO ()+testRoundTrip = do+  original <- source+  let bytes = encodeTriangulation original+  unless (BL.length bytes > 0) $ fail "serialization produced an empty payload"+  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.+testIndependentPayloadGeometryRoundTrip :: IO ()+testIndependentPayloadGeometryRoundTrip = do+  geometry <- source+  vertex <- case vertices geometry of+    (first : _) -> pure first+    [] -> fail "independent payload fixture has no vertices"+  let independentPayload = SerialVertex (Point 91 73) 1010+      original = setVertexData geometry vertex independentPayload+      positionless = mapVertices serialLabel original+  assertEqual "independent payload leaves geometry fixed"+    (vertexPoint geometry vertex) (vertexPoint original vertex)+  assertEqual "independent payload position is stored"+    (Point 91 73) (serialPosition (vertexData original vertex))+  assertSerializationRoundTrip "independent payload serialization" original+  assertSerializationRoundTrip "positionless payload serialization" positionless++testPointPayloadRoundTrip :: IO ()+testPointPayloadRoundTrip = do+  let points = V.fromList [Point 0 0, Point 2 0, Point 0 2, Point 0.5 0.5] :: V.Vector (Point)+  built <- requireRight "point payload source" (delaunay unitElementDefaults points)+  let geometry = buildTriangulation built+  vertex <- case vertices geometry of+    (first : _) -> pure first+    [] -> fail "point payload fixture has no vertices"+  let original = setVertexData geometry vertex (Point 13 17)+  assertEqual "point payload leaves geometry fixed"+    (vertexPoint geometry vertex) (vertexPoint original vertex)+  assertEqual "point payload is stored"+    (Point 13 17) (vertexData original vertex)+  assertSerializationRoundTrip "point payload serialization" original++-- The wire format admits every binary64 bit pattern, but resident point identity+-- admits only canonical zero. Mutate the first singleton coordinate to negative+-- zero and require decode to restore the canonical representation.+testCanonicalizesSerializedSignedZero :: IO ()+testCanonicalizesSerializedSignedZero = do+  original <- requireRight "signed-zero source" (delaunayGeometry (V.singleton (Point 0 0)))+  let bytes = encodeTriangulation original+      structuralPrefixSize = 8 + 2 + 1 + 1 + 4 * 8+      signedZeroBytes =+        BL.concat+          [ BL.take structuralPrefixSize bytes+          , BL.singleton 0x80+          , BL.drop (structuralPrefixSize + 1) bytes+          ]+  decoded <-+    requireRight+      "signed-zero decode"+      ( decodeTriangulation testDecodingBudget trustedBinaryPayloadDecoders signedZeroBytes+          :: Either SerializationError (Triangulation 'Unconstrained () () () ())+      )+  vertex <- case vertices decoded of+    [onlyVertex] -> pure onlyVertex+    unexpected -> fail ("signed-zero fixture produced " <> show (length unexpected) <> " vertices")+  assertEqual "signed-zero coordinate canonicalization" (Point 0 0) (vertexPoint decoded vertex)+  assertEqual "signed-zero canonical re-encoding" bytes (encodeTriangulation decoded)++assertSerializationRoundTrip+  :: ( KnownConstraintMode mode+     , Binary vertex+     , Binary directed+     , Binary undirected+     , Binary face+     , Eq vertex+     , Eq directed+     , Eq undirected+     , Eq face+     , Show vertex+     , Show directed+     , Show undirected+     , Show face+     )+  => String+  -> Triangulation mode vertex directed undirected face+  -> IO ()+assertSerializationRoundTrip label original = do+  decoded <-+    requireRight+      (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)+    ]++-- Range validation must obstruct before relational validation dereferences the+-- hostile handle. Fully comparing the error forces its complete violation+-- inventory and therefore pins the absence of a lazy unsafe-index crash.+testRejectsOutOfRangeOuterFaceReference :: IO ()+testRejectsOutOfRangeOuterFaceReference =+  assertDecodeFailure+    "out-of-range outer-face reference"+    testDecodingBudget+    (structuralPrefix 6 0 0 1 0 <> runPut (putWord32be 0 >> putWord8 0))+    ( DecodedInvariantViolations+        (FaceAdjacentOutOfRange (FaceId 0) (DirectedEdgeId 0) 0 :| [])+    )++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+-- the stream carries payload values, and a byte flipped inside an element+-- payload names a different but entirely legal value — the guarantee there is+-- not refusal but soundness: a decoder that rebuilds its indexes rather than+-- trusting them may never surface a triangulation that violates its invariants,+-- whatever it is fed.+testRejectsCorruption :: IO ()+testRejectsCorruption = do+  original <- source+  let bytes = encodeTriangulation original+      size = BL.length bytes+      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 ()+      rejects label candidate =+        case decode candidate of+          Left _ -> pure ()+          Right _ -> fail ("decoder accepted " <> label)+  assertEqual+    "typed trailing-byte refusal"+    (Left (TrailingBytes 1))+    (decode (bytes <> BL.singleton 0))+  case decode (BL.cons 0 (BL.drop 1 bytes)) of+    Left (InvalidFormatMagic _) -> pure ()+    other -> fail ("magic corruption produced " <> show other)+  rejects "an empty payload" BL.empty+  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
@@ -0,0 +1,73 @@+-- | 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+  ( ExactLoop+  , ExactPoint+  , Point+  , PolygonComponent+  , QueryPoint+  , Triangulation+  , exactLoop+  , exactPoint+  , mkQueryPoint+  , polygonComponent+  , validateTriangulation+  )++requireRight :: Show error => String -> Either error value -> IO value+requireRight label value = case value of+  Left failure -> fail (label <> ": " <> show failure)+  Right result -> pure result++requireQueryPoint :: String -> Point -> IO QueryPoint+requireQueryPoint label = requireRight label . mkQueryPoint++assertEqual :: (Eq value, Show value) => String -> value -> value -> IO ()+assertEqual label expected actual =+  unless (expected == actual) $+    fail (label <> ": expected " <> show expected <> ", got " <> show actual)++assertValid :: String -> Triangulation mode vertex directed undirected face -> IO ()+assertValid label triangulation =+  case validateTriangulation triangulation of+    [] -> pure ()+    violations -> fail (label <> " invariant violations: " <> show violations)++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` [])
+ test/zigzag/Main.hs view
@@ -0,0 +1,232 @@+module Main (main) where++import Data.Bifunctor (first)+import Data.Foldable (traverse_)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty+import Data.Set qualified as Set+import Data.Vector qualified as Vector+import Moonlight.Homology.Chain (HomologicalDegree (..))+import Moonlight.Triangulation.Example.ActivationZigzag+  ( squareLoopAcrossDepths+  )+import Moonlight.Triangulation.Types+  ( Point (..)+  , RadiusSquared+  , mkRadiusSquared+  )+import Moonlight.Triangulation.Zigzag+  ( ActivationComplex+  , ActivationInterval+  , ActivationPoint (..)+  , ActivationSlice (..)+  , ActivationStage (..)+  , ActivationZigzagError (..)+  , ZigzagInterval (..)+  , activationAlphaPersistence+  , activationAlphaZigzag+  , activationComplexCells+  , activationZigzagComplexes+  , activationZigzagCorrespondences+  , activationZigzagIntervals+  , activationZigzagStages+  , adjacentCommonCells+  , adjacentUnionComplex+  )+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit+  ( Assertion+  , assertFailure+  , testCase+  , (@?=)+  )++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+  testGroup+    "activation alpha zigzag"+    [ testCase "tracks a loop born and filled across depth" loopAcrossDepths+    , testCase "compiled documentation example returns the same loop" compiledExample+    , testCase "accepts genuinely non-nested adjacent complexes" nonNestedCorrespondence+    , testCase "is invariant under point input permutation" permutationInvariant+    , testCase "retains exact common and union cell witnesses" correspondenceCells+    , testCase "rejects duplicate depth keys" rejectDuplicateDepths+    , testCase "rejects duplicate labels within a depth" rejectDuplicateLabels+    , testCase "rejects distinct labels collapsed onto one coordinate" rejectCoordinateCollapse+    ]++loopAcrossDepths :: Assertion+loopAcrossDepths = do+  slices <- squareSlices squarePoints+  intervals <- requireRight "square loop barcode" (activationAlphaPersistence slices)+  degreeOneIntervals intervals+    @?= [ ZigzagInterval+            { zigzagIntervalDegree = HomologicalDegree 1+            , zigzagIntervalFirst = AdjacentDepthUnion 0 1+            , zigzagIntervalLast = ObservedDepth 1+            , zigzagIntervalMultiplicity = 1+            }+        ]++compiledExample :: Assertion+compiledExample = do+  intervals <- requireRight "compiled activation example" squareLoopAcrossDepths+  fmap zigzagIntervalMultiplicity intervals @?= [1]++nonNestedCorrespondence :: Assertion+nonNestedCorrespondence = do+  threshold <- requireRadius 10+  let slices :: NonEmpty (ActivationSlice Int String)+      slices =+        ActivationSlice+          0+          threshold+          ( Vector.fromList+              [ ActivationPoint "a" (Point 0 0)+              , ActivationPoint "b" (Point 2 0)+              , ActivationPoint "c" (Point 0 2)+              ]+          )+          :| [ ActivationSlice+                 1+                 threshold+                 ( Vector.fromList+                     [ ActivationPoint "b" (Point 2 0)+                     , ActivationPoint "c" (Point 0 2)+                     , ActivationPoint "d" (Point 2 2)+                     ]+                 )+             ]+  zigzag <-+    requireRight+      "non-nested triangle zigzag"+      (activationAlphaZigzag slices)+  intervals <- requireRight "non-nested triangle barcode" (activationZigzagIntervals zigzag)+  filter ((== HomologicalDegree 0) . zigzagIntervalDegree) intervals+    @?= [ZigzagInterval (HomologicalDegree 0) (ObservedDepth 0) (ObservedDepth 1) 1]++permutationInvariant :: Assertion+permutationInvariant = do+  forwardSlices <- squareSlices squarePoints+  reverseSlices <- squareSlices (Vector.reverse squarePoints)+  forwardIntervals <- requireRight "forward square barcode" (activationAlphaPersistence forwardSlices)+  reverseIntervals <- requireRight "reversed square barcode" (activationAlphaPersistence reverseSlices)+  reverseIntervals @?= forwardIntervals++correspondenceCells :: Assertion+correspondenceCells = do+  slices <- squareSlices squarePoints+  zigzag <- requireRight "square correspondence" (activationAlphaZigzag slices)+  activationZigzagStages zigzag+    @?= Vector.fromList+      [ ObservedDepth 0+      , AdjacentDepthUnion 0 1+      , ObservedDepth 1+      , AdjacentDepthUnion 1 2+      , ObservedDepth 2+      ]+  let complexes = NonEmpty.toList (activationZigzagComplexes zigzag)+      witnesses = Vector.toList (activationZigzagCorrespondences zigzag)+  length witnesses @?= 2+  traverse_+    ( \(leftComplex, rightComplex, witness) -> do+        adjacentCommonCells witness+          @?= Set.intersection+            (activationComplexCells leftComplex)+            (activationComplexCells rightComplex)+        activationComplexCells (adjacentUnionComplex witness)+          @?= Set.union+            (activationComplexCells leftComplex)+            (activationComplexCells rightComplex)+    )+    (adjacentTriples complexes witnesses)++rejectDuplicateDepths :: Assertion+rejectDuplicateDepths = do+  threshold <- requireRadius 0+  let slices :: NonEmpty (ActivationSlice Int String)+      slices =+        ActivationSlice 4 threshold (Vector.singleton (ActivationPoint "a" (Point 0 0)))+          :| [ActivationSlice 4 threshold (Vector.singleton (ActivationPoint "a" (Point 1 0)))]+  activationAlphaPersistence slices @?= Left (ActivationDuplicateDepth 4)++rejectDuplicateLabels :: Assertion+rejectDuplicateLabels = do+  threshold <- requireRadius 0+  let result :: Either (ActivationZigzagError Int String) [ActivationInterval Int]+      result =+        activationAlphaPersistence+          ( ActivationSlice+              7+              threshold+              ( Vector.fromList+                  [ ActivationPoint "same" (Point 0 0)+                  , ActivationPoint "same" (Point 1 0)+                  ]+              )+              :| []+          )+  result @?= Left (ActivationDuplicateLabel 7 "same")++rejectCoordinateCollapse :: Assertion+rejectCoordinateCollapse = do+  threshold <- requireRadius 0+  let result :: Either (ActivationZigzagError Int String) [ActivationInterval Int]+      result =+        activationAlphaPersistence+          ( ActivationSlice+              9+              threshold+              ( Vector.fromList+                  [ ActivationPoint "first" (Point 0 0)+                  , ActivationPoint "second" (Point 0 0)+                  ]+              )+              :| []+          )+  result @?= Left (ActivationCoordinateCollapse 9 2 1)++degreeOneIntervals :: [ActivationInterval depth] -> [ActivationInterval depth]+degreeOneIntervals =+  filter ((== HomologicalDegree 1) . zigzagIntervalDegree)++squareSlices ::+  Vector.Vector (ActivationPoint String) ->+  IO (NonEmpty (ActivationSlice Int String))+squareSlices points = do+  let depths :: NonEmpty Int+      depths = 0 :| [1, 2]+  thresholds <- traverse (requireRadius . fromIntegral) depths+  pure+    ( NonEmpty.zipWith+        (\depthValue threshold -> ActivationSlice depthValue threshold points)+        depths+        thresholds+    )++squarePoints :: Vector.Vector (ActivationPoint String)+squarePoints =+  Vector.fromList+    [ ActivationPoint "south-west" (Point (-1) (-1))+    , ActivationPoint "south-east" (Point 1 (-1))+    , ActivationPoint "north-east" (Point 1 1)+    , ActivationPoint "north-west" (Point (-1) 1)+    ]++adjacentTriples ::+  [ActivationComplex depth label] ->+  [witness] ->+  [(ActivationComplex depth label, ActivationComplex depth label, witness)]+adjacentTriples complexes witnesses =+  zipWith3 (,,) complexes (drop 1 complexes) witnesses++requireRadius :: Double -> IO RadiusSquared+requireRadius value =+  requireRight "radius squared" (first show (mkRadiusSquared value))++requireRight :: Show failure => String -> Either failure value -> IO value+requireRight context =+  either (assertFailure . ((context <> ": ") <>) . show) pure
+ weeder.toml view
@@ -0,0 +1,60 @@+roots = [+  '^Main\.main$',+  '^Paths_.*'+]++# Every exposed non-Internal module is public API and therefore a root. The+# exposed Internal modules exist only to connect the package's sublibrary tower;+# their unreachable declarations remain subject to the gate.+root-modules = [+  '^Moonlight\.Hex\.Coordinate$',+  '^Moonlight\.Hex\.Element$',+  '^Moonlight\.Hex\.Region$',+  '^Moonlight\.Hex\.Planar$',+  '^Moonlight\.Hex\.Serialization$',+  '^Moonlight\.Hex\.CellComplex$',+  '^Moonlight\.Triangulation\.Scalar$',+  '^Moonlight\.Triangulation\.LineSideInfo$',+  '^Moonlight\.Triangulation\.Types$',+  '^Moonlight\.Triangulation\.Math$',+  '^Moonlight\.Triangulation\.Exact$',+  '^Moonlight\.Triangulation\.CellSet$',+  '^Moonlight\.Triangulation\.CellComplex$',+  '^Moonlight\.Triangulation\.Zigzag$',+  '^Moonlight\.Triangulation\.Region$',+  '^Moonlight\.Triangulation\.Valuation$',+  '^Moonlight\.Triangulation\.Interop$',+  '^Moonlight\.Triangulation\.Dcel$',+  '^Moonlight\.Triangulation\.Payload$',+  '^Moonlight\.Triangulation\.JoinSemilattice$',+  '^Moonlight\.Triangulation\.Handles\.HandleDefs$',+  '^Moonlight\.Triangulation\.Handles\.Dynamic$',+  '^Moonlight\.Triangulation\.Handles\.Iterators\.CircularIterator$',+  '^Moonlight\.Triangulation\.Handles\.Iterators\.DynamicIterators$',+  '^Moonlight\.Triangulation\.Handles\.Iterators\.FixedIterators$',+  '^Moonlight\.Triangulation\.Handles\.Iterators\.HullIterator$',+  '^Moonlight\.Triangulation\.PointLocation$',+  '^Moonlight\.Triangulation\.Validation$',+  '^Moonlight\.Triangulation\.FloodFillIterator$',+  '^Moonlight\.Triangulation\.IntersectionIterator$',+  '^Moonlight\.Triangulation\.BulkLoad$',+  '^Moonlight\.Triangulation\.Removal$',+  '^Moonlight\.Triangulation\.Session$',+  '^Moonlight\.Triangulation\.Cdt$',+  '^Moonlight\.Triangulation\.Minkowski$',+  '^Moonlight\.Triangulation\.Overlay$',+  '^Moonlight\.Triangulation\.Refinement$',+  '^Moonlight\.Triangulation\.SetAlgebra$',+  '^Moonlight\.Triangulation\.Parallel$',+  '^Moonlight\.Triangulation\.Serialization$',+  '^Moonlight\.Triangulation\.Voronoi$',+  '^Moonlight\.Triangulation\.Voronoi\.Handles$',+  '^Moonlight\.Triangulation\.Interpolation$',+  '^Moonlight\.Triangulation\.HintGenerator$',+  '^Moonlight\.Triangulation\.Foreign\.Exports$',+  '^Moonlight\.Triangulation$'+]++root-instances = []+type-class-roots = true+unused-types = true