moonlight-triangulation 1.4.0.3 → 1.4.0.4

raw patch · 44 files changed

+8872/−2766 lines, 44 filesdep ~basedep ~containersdep ~deepseqPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, containers, deepseq, moonlight-triangulation

API changes (from Hackage documentation)

Files

• CHANGELOG.md +61/−0
• README.md +37/−8
• bench/layer/Main.hs +8/−0
• bench/layer/Moonlight/Triangulation/LayerBench.hs +244/−0
• bench/power/Main.hs +9/−0
• bench/power/Moonlight/Triangulation/PowerBench.hs +289/−0
• docs/README.md +1/−0
• moonlight-triangulation.cabal +115/−11
• src-build/Moonlight/Triangulation/Internal/Join.hs +7/−20
• src-build/Moonlight/Triangulation/Internal/Join/Plan.hs +8/−29
• src-core/Moonlight/Triangulation/Internal/ExactRational.hs +23/−0
• src-dcel/Moonlight/Triangulation/Dcel.hs +10/−5
• src-dcel/Moonlight/Triangulation/Exact.hs +985/−1
• src-dcel/Moonlight/Triangulation/Handles/HandleDefs.hs +4/−5
• src-dcel/Moonlight/Triangulation/Handles/Scoped.hs +276/−0
• src-dcel/Moonlight/Triangulation/Internal/BoundaryCycle.hs +48/−0
• src-dcel/Moonlight/Triangulation/Internal/Tournament.hs +45/−0
• src-dcel/Moonlight/Triangulation/Region.hs +9/−6
• src-dcel/Moonlight/Triangulation/Valuation.hs +14/−1
• src-overlay/Moonlight/Triangulation/Embedding.hs +546/−0
• src-overlay/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs +812/−0
• src-overlay/Moonlight/Triangulation/Internal/Overlay/Resident.hs +923/−0
• src-overlay/Moonlight/Triangulation/Internal/Overlay/Types.hs +274/−0
• src-parallel/Moonlight/Triangulation/Parallel.hs +3/−2
• src-public/Moonlight/Triangulation.hs +182/−5
• src-public/Moonlight/Triangulation/Internal/Minkowski/Convex.hs +64/−86
• src-public/Moonlight/Triangulation/Internal/Minkowski/Types.hs +4/−4
• src-public/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs +0/−811
• src-public/Moonlight/Triangulation/Internal/Overlay/Embedding.hs +0/−539
• src-public/Moonlight/Triangulation/Internal/Overlay/Resident.hs +0/−923
• src-public/Moonlight/Triangulation/Internal/Overlay/Types.hs +0/−274
• src-public/Moonlight/Triangulation/Internal/RegularTriangulation.hs +1111/−0
• src-public/Moonlight/Triangulation/Minkowski.hs +10/−13
• src-public/Moonlight/Triangulation/Overlay.hs +189/−18
• src-public/Moonlight/Triangulation/PowerDiagram.hs +955/−0
• test/algebra/Main.hs +0/−2
• test/algebra/Moonlight/Triangulation/ExactClipRetentionSpec.hs +536/−0
• test/algebra/Moonlight/Triangulation/LayerOperationsSpec.hs +275/−0
• test/algebra/Moonlight/Triangulation/MinkowskiSpec.hs +25/−0
• test/algebra/Moonlight/Triangulation/PowerDiagramSpec.hs +734/−0
• test/coherence/Main.hs +4/−1
• test/exact-planar/Main.hs +15/−0
• test/native/Moonlight/Triangulation/ExactEmbeddingSpec.hs +7/−2
• test/public-components/Main.hs +10/−0

@@ -10,6 +10,67 @@ The serialization format carries its own version tag, independent of the package version; any change to it is recorded here explicitly. +## 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

@@ -12,7 +12,7 @@  Delaunay triangulation, constrained Delaunay (CDT), exact rational planar regions and labelled overlay, intrinsic valuations, polygonal Minkowski-morphology, the Voronoi dual, natural-neighbour interpolation, Ruppert+morphology, exact regular/power geometry, the Voronoi dual, natural-neighbour interpolation, Ruppert refinement, walk point location, convex hull, exact Shewchuk predicates, and versioned binary serialization. @@ -32,6 +32,7 @@ | `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` |@@ -49,12 +50,19 @@ | `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` |+| `boundedPowerDiagram` | Labelled weighted sites need exact cells inside one finite convex domain | `ConvexPolygon`, nonempty `PowerSite` family | Total labelled dispositions plus rational-width receipt / `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` | | `fromExactCellSet` | Exact cells need a generic complex view | `ExactCellSet` | `DCELComplex` |@@ -64,6 +72,23 @@ [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) +## 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 label's visibility disposition and publishes regular faces plus weighted+dual segments, rays, full lines, or collapsed degenerate edges.+`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.++`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.+ ## Foreign bindings  The C ABI and its Python, TypeScript, and Rust consumers are documented in the@@ -130,6 +155,11 @@   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,@@ -140,8 +170,8 @@  ```cabal build-depends:-  moonlight-triangulation:dcel >= 1.4.1 && < 1.5,-  moonlight-triangulation:build >= 1.4.1 && < 1.5+  moonlight-triangulation:dcel >= 1.4 && < 1.5,+  moonlight-triangulation:build >= 1.4 && < 1.5 ```  ## Architecture@@ -154,15 +184,14 @@ ## Consumer libraries  The Cabal manifest owns component visibility and dependencies; this is its-consumer-facing projection. The default library reexports the complete safe-geometry surface. Use a public sublibrary directly when its smaller dependency-cone matters; the trusted implementation units remain private.+consumer-facing projection. Use a public sublibrary directly when its smaller+dependency cone matters; trusted implementation units remain private.  | Dependency | Imports | Purpose | | --- | --- | --- |-| `moonlight-triangulation` | `Moonlight.Triangulation` and every safe `dcel`, `build`, and `dual` module | Broad construction, observation, set algebra, CDT, refinement, alpha, Voronoi, interpolation, and exact planar surface. |+| `moonlight-triangulation` | `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-triangulation:core` | `.Scalar`, `.LineSideInfo` | Low-level exact scalars and paged storage primitives. |-| `moonlight-triangulation:dcel` | `.Types`, `.Dcel`, `.Handles.*`, `.PointLocation`, `.FloodFillIterator`, `.IntersectionIterator`, `.Alpha`, `.Exact`, `.Region`, `.Valuation` | Immutable mesh vocabulary, observations, typed spatial queries, exact geometry, and owning handles; no construction kernel. |+| `moonlight-triangulation: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-triangulation:build` | `.BulkLoad`, `.Session`, `.Removal`, `.Cdt`, `.Refinement`, `.SetAlgebra` | Construction and persistent editing over the DCEL; no dual, serialization, concurrency, or Homology dependency. | | `moonlight-triangulation:dual` | `.Voronoi`, `.Voronoi.Handles`, `.Interpolation` | Voronoi observations and natural-neighbour interpolation. | | `moonlight-triangulation:parallel` | `.Parallel` | Bounded concurrent union; adds `async`. |

@@ -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

@@ -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

@@ -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

@@ -0,0 +1,289 @@+-- | 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 BenchSupport (randomPoints, requireRight)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Data.Foldable (traverse_)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import GHC.Conc.Sync (getAllocationCounter, setAllocationCounter)+import Moonlight.Triangulation+  ( BoundedPowerDiagram+  , ConvexPolygon+  , Point (Point)+  , PowerDiagramError+  , PowerDiagramReceipt+  , PowerSite+  , RegularTriangulation+  , RegularTriangulationReceipt+  , boundedPowerDiagram+  , 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+  , powerWeight+  , regularTriangulation+  )+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))+  }++type PowerResult =+  Either (PowerDiagramError Int) (BoundedPowerDiagram Int, PowerDiagramReceipt)++type DiagramResult =+  Either (PowerDiagramError Int) (BoundedPowerDiagram Int)++type RegularResult =+  Either+    (PowerDiagramError Int)+    (RegularTriangulation Int, RegularTriangulationReceipt)++siteCounts :: [Int]+siteCounts = [16, 64, 128, 169, 256, 512]++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 ->+      pure+        PowerBenchCase+          { powerBenchLabel = familyLabel family <> "/n=" <> show siteCount+          , powerBenchDomain = domain+          , powerBenchSites = nonEmptySites+          }++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)+  ]++construct :: PowerBenchCase -> PowerResult+construct benchmarkCase =+  boundedPowerDiagram+    (powerBenchDomain benchmarkCase)+    (powerBenchSites benchmarkCase)++constructDiagramOnly :: PowerBenchCase -> DiagramResult+constructDiagramOnly = fmap fst . construct++constructRegularTopology :: PowerBenchCase -> RegularResult+constructRegularTopology = regularTriangulation . powerBenchSites++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)

@@ -8,6 +8,7 @@ | 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) | | 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) |

@@ -1,6 +1,6 @@ cabal-version:       3.4 name:                moonlight-triangulation-version:             1.4.0.3+version:             1.4.0.4 synopsis:            Delaunay meshes and exact planar-region algebra. description:         Delaunay and constrained Delaunay triangulation as a lawful                      finite-set algebra, together with exact rational planar@@ -106,7 +106,7 @@ source-repository this   type:     git   location: https://github.com/PaleRoses/moonlight.git-  tag:      moonlight-triangulation-1.4.0.3+  tag:      moonlight-triangulation-1.4.0.4   subdir:   moonlight-triangulation  flag warnings-as-errors@@ -185,6 +185,7 @@     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@@ -207,6 +208,7 @@     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@@ -251,6 +253,7 @@     , 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@@ -410,6 +413,27 @@     , moonlight-triangulation: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-triangulation:core+    , moonlight-triangulation:dcel-internal+    , moonlight-triangulation:build-internal+ library   import: shared-properties   hs-source-dirs:@@ -419,12 +443,10 @@     Moonlight.Triangulation.HintGenerator     Moonlight.Triangulation.Minkowski     Moonlight.Triangulation.Overlay-    Moonlight.Triangulation.Internal.Overlay.Arrangement-    Moonlight.Triangulation.Internal.Overlay.Embedding-    Moonlight.Triangulation.Internal.Overlay.Resident-  -- The default library is the broad safe surface. These are the exact modules-  -- compiled by the focused components, not facade copies; consumers that want-  -- a smaller dependency cone can name :dcel, :build, or :dual directly.+    Moonlight.Triangulation.PowerDiagram+  -- 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@@ -440,6 +462,7 @@     , 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@@ -456,10 +479,11 @@     , 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.Overlay.Types+    Moonlight.Triangulation.Internal.RegularTriangulation   build-depends:     base >= 4.19 && < 5     , containers >= 0.8 && < 0.9@@ -469,6 +493,7 @@     , moonlight-triangulation:dcel-internal     , moonlight-triangulation:build-internal     , moonlight-triangulation:dual+    , moonlight-triangulation:overlay-internal   ghc-options: -fexpose-all-unfoldings  library ffi@@ -567,6 +592,7 @@     , moonlight-triangulation:dcel-internal     , moonlight-triangulation:build-internal     , moonlight-triangulation:dual+    , moonlight-triangulation:overlay-internal  common triangulation-serialization-test-slice   other-modules: Moonlight.Triangulation.SerializationSpec@@ -609,6 +635,28 @@     moonlight-triangulation:core     , moonlight-triangulation: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-triangulation:core+    , moonlight-triangulation:dcel-internal++common triangulation-power-diagram-law-slice+  other-modules: Moonlight.Triangulation.PowerDiagramSpec+  build-depends:+    containers >= 0.8 && < 0.9+    , moonlight-triangulation:core+    , moonlight-triangulation:dcel-internal++common triangulation-layer-operations-law-slice+  other-modules: Moonlight.Triangulation.LayerOperationsSpec+  build-depends:+    containers >= 0.8 && < 0.9+    , moonlight-triangulation:core+    , moonlight-triangulation: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.@@ -659,6 +707,25 @@     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.@@ -743,7 +810,6 @@     triangulation-algebra-law-slice,     triangulation-region-algebra-law-slice,     triangulation-valuation-law-slice,-    triangulation-minkowski-law-slice,     triangulation-algebra-schedule-slice   type: exitcode-stdio-1.0   main-is: Main.hs@@ -775,7 +841,7 @@     , moonlight-triangulation:ffi  -- This component owns only cross-slice compile coherence.  Behavioral ownership--- remains in the four focused suites.  The shared test-properties stanza keeps+-- 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@@ -789,6 +855,9 @@     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@@ -1069,6 +1138,41 @@     , moonlight-triangulation:cell-complex     , moonlight-triangulation: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:+    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:

@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -7,19 +6,15 @@ module Moonlight.Triangulation.Internal.Join   ( joinNormalForm   , joinBalanced-  , executeTournamentPlan-  , TournamentPlan (..)-  , planTournament   ) 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 (..)-  , TournamentPlan (..)   , planPair-  , planTournament   ) import Moonlight.Triangulation.Internal.Join.Seam (executeSeam) import Moonlight.Triangulation.Internal.Join.SiteSet@@ -35,6 +30,10 @@   ( insertAdmittedVertexAtCombining   , withLocalSession   )+import Moonlight.Triangulation.Internal.Tournament+  ( interpretTournament+  , planTournament+  ) import Moonlight.Triangulation.Types  -- | A Delaunay representative of the union of two site sets.@@ -85,7 +84,7 @@       (siteSetSize sites)       ( traverse_           (\(point, annotation) ->-             () <$ insertAdmittedVertexAtCombining joinAnnotations point annotation+             void (insertAdmittedVertexAtCombining joinAnnotations point annotation)           )           (siteSetAssocs sites)       )@@ -112,19 +111,7 @@   -> Either BuildError (Triangulation 'Unconstrained annotation () () ()) joinBalanced [] = Right (empty unitElementDefaults) joinBalanced (first : rest) =-  executeTournamentPlan (planTournament (first :| rest))+  interpretTournament joinNormalForm (planTournament (first :| rest)) {-# SPECIALIZE joinBalanced   :: [Triangulation 'Unconstrained () () () ()]   -> Either BuildError (Triangulation 'Unconstrained () () () ()) #-}--executeTournamentPlan-  :: JoinSemilattice annotation-  => TournamentPlan (Triangulation 'Unconstrained annotation () () ())-  -> Either BuildError (Triangulation 'Unconstrained annotation () () ())-executeTournamentPlan tournament =-  case tournament of-    TournamentLeaf mesh -> Right mesh-    TournamentNode left right -> do-      leftMesh <- executeTournamentPlan left-      rightMesh <- executeTournamentPlan right-      joinNormalForm leftMesh rightMesh

@@ -8,12 +8,10 @@ module Moonlight.Triangulation.Internal.Join.Plan   ( PairPlan (..)   , planPair-  , TournamentPlan (..)-  , planTournament   ) where -import Data.List.NonEmpty (NonEmpty (..)) import Moonlight.Triangulation.Dcel (numVertices)+import Moonlight.Triangulation.Internal.BulkLoad (empty) import Moonlight.Triangulation.Internal.Join.Seam (SeamPlan, planSeam) import Moonlight.Triangulation.Internal.Join.SiteSet   ( SiteSet@@ -26,6 +24,7 @@ import Moonlight.Triangulation.Internal.Types   ( ConstraintMode (Unconstrained)   , SiteRelation (..)+  , unitElementDefaults   )  data PairPlan annotation@@ -45,6 +44,12 @@   -> 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@@ -73,29 +78,3 @@ insertionIsCheaper :: Int -> Int -> Bool insertionIsCheaper addition base = addition <= 64 || addition <= base `quot` 8 {-# INLINE insertionIsCheaper #-}---- | A deterministic dependency graph. Leaves retain meshes as values; no site--- flattening occurs, so singleton and repeated-value shortcut semantics remain--- those of the binary operation. Duplicate operands need no planning pass:--- every adjacent pair reaches the binary operation, whose structural-equality--- shortcut already returns the operand verbatim, so a dedup here would buy a--- quadratic scan of whole meshes to skip work the executor skips anyway.-data TournamentPlan mesh-  = TournamentLeaf !mesh-  | TournamentNode !(TournamentPlan mesh) !(TournamentPlan mesh)--planTournament :: NonEmpty mesh -> TournamentPlan mesh-planTournament = buildBalanced . fmap TournamentLeaf- where-  buildBalanced :: NonEmpty (TournamentPlan value) -> TournamentPlan value-  buildBalanced (single :| []) = single-  buildBalanced plans = buildBalanced (pairRound plans)--  pairRound :: NonEmpty (TournamentPlan value) -> NonEmpty (TournamentPlan value)-  pairRound (left :| right : rest) =-    TournamentNode left right :| pairTail rest-  pairRound (single :| []) = single :| []--  pairTail :: [TournamentPlan value] -> [TournamentPlan value]-  pairTail (left : right : rest) = TournamentNode left right : pairTail rest-  pairTail rest = rest

@@ -15,6 +15,8 @@   , exactRationalFromDyadicRatio   , exactRationalNumerator   , exactRationalDenominator+  , exactRationalBitWidth+  , exactRationalDenominatorBitWidth   , exactRationalIsZero   , exactDivide   , exactSignum@@ -122,6 +124,27 @@ 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

@@ -1,8 +1,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} --- | Constant-time observations and persistent payload updates over the--- immutable DCEL.+-- | 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@@ -370,8 +372,9 @@   -> [DirectedEdgeId] circularWalk triangulation start advance =   build-    ( \link stop ->-        let go !remaining !current !visited+    ( \(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)@@ -380,7 +383,8 @@ {-# INLINE circularWalk #-}  circularFold-  :: Triangulation mode vertex directed undirected face -> DirectedEdgeId+  :: forall mode vertex directed undirected face a.+     Triangulation mode vertex directed undirected face -> DirectedEdgeId   -> (DirectedEdgeId -> DirectedEdgeId)   -> (a -> DirectedEdgeId -> a)   -> a@@ -388,6 +392,7 @@ 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

@@ -8,12 +8,35 @@   , 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@@ -32,14 +55,31 @@   ) 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   )@@ -61,17 +101,151 @@   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@@ -96,6 +270,795 @@ 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@@ -244,7 +1207,7 @@ compareExactVectorAngle left right =   case compare (vectorHalf left) (vectorHalf right) of     EQ ->-      case exactSignum (exactCross left right) of+      case exactCrossSign left right of         GT -> LT         LT -> GT         EQ -> EQ@@ -255,6 +1218,27 @@     | 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) =

@@ -1,8 +1,7 @@--- | Opaque resident identifiers and lawful orientation operations.------ Identifiers can only be obtained from a triangulation. Their numeric--- projections support serialization and diagnostics without allowing a caller--- to manufacture a handle that belongs to no mesh.+-- | 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

@@ -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)

@@ -11,6 +11,8 @@   , cyclePairs   , cyclePairsNonEmpty   , cyclicTriples+  , firstNonCounterClockwiseTurn+  , admitsSimpleCycleEdgeRelation   ) where  import Data.List (tails)@@ -21,6 +23,9 @@ 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@@ -253,3 +258,46 @@             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 #-}

@@ -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

@@ -46,7 +46,8 @@   , exactSegmentEndpoints   ) import Moonlight.Triangulation.Internal.BoundaryCycle-  ( cyclePairs+  ( admitsSimpleCycleEdgeRelation+  , cyclePairs   , rotateCycleLeast   , simplifyBoundaryCycle   )@@ -238,7 +239,13 @@     [ (leftIndex, rightIndex, relation)     | ((ExactSweepSegmentId leftIndex, ExactSweepSegmentId rightIndex), relation) <-         Map.toAscList (exactSegmentRelationMap plan)-    , not (adjacentSegment segmentCount leftIndex rightIndex && relation == SegmentsShareEndpoint)+    , not+        ( admitsSimpleCycleEdgeRelation+            segmentCount+            leftIndex+            rightIndex+            relation+        )     ] of     (leftIndex, rightIndex, relation) : _ ->       Left (RegionLoopSelfRelation leftIndex rightIndex relation)@@ -256,10 +263,6 @@          first (const (RegionLoopDegenerate (NonEmpty.toList points)))            (exactSegment from to))       (cyclePairs points)--adjacentSegment :: Int -> Int -> Int -> Bool-adjacentSegment count left right =-  right == left + 1 || (left == 0 && right == count - 1)  loopWinding :: ExactLoop -> Ordering loopWinding (ExactLoop points) =

@@ -11,6 +11,7 @@   , eulerCharacteristicValue   , ExactArea   , exactAreaValue+  , polygonComponentArea   , ExactLengthTerm   , lengthCoefficient   , squaredLength@@ -118,9 +119,21 @@   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 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 ExactLengthTerm = ExactLengthTerm   { lengthCoefficient :: !ExactRational   , squaredLength :: !ExactRational@@ -195,7 +208,7 @@   componentBoundaries <- traverse componentBoundaryData components   let boundaryCover =         overlappingPredecessors componentBoundaryBounds componentBoundaries-      hasPotentialBoundaryContacts = any (not . null . snd) boundaryCover+      hasPotentialBoundaryContacts = not (all (null . snd) boundaryCover)   euler <- regionEuler boundaryCover   boundaryAtoms <-     normalizedRegionBoundaryAtoms

@@ -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.Math as Math+  ( 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 Math.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+    ( Math.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

@@ -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)

@@ -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))

@@ -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)

@@ -13,11 +13,12 @@ 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 (..)-  , joinNormalForm   , planTournament   )-import Moonlight.Triangulation.Internal.Representation (Triangulation) import Moonlight.Triangulation.Internal.Types (BuildError, ConstraintMode (Unconstrained)) import Moonlight.Triangulation.JoinSemilattice (JoinSemilattice) 

@@ -32,10 +32,10 @@   , JoinSemilattice (..)   , Coordinate2 (..)   , mapCoordinate2-    -- | An identifier is admitted by the triangulation that issued it. The-    -- observations below index without a second bounds check, so the-    -- constructors are withheld and the projections are not: an identifier-    -- can be read, compared and carried, and can only be obtained from a mesh.+    -- | 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@@ -51,6 +51,42 @@   , 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@@ -381,6 +417,10 @@   , exactCross   , compareExactVectorAngle   , translateExactPoint+  , ExactRay+  , exactRay+  , exactRayOrigin+  , exactRayDirection   , ExactSegment   , ExactGeometryError (..)   , exactSegment@@ -432,7 +472,11 @@   , OverlayError (..)   , OverlaySelectionKind (..)   , OverlaySelectionError (..)+  , CoverGap+  , coverGapRegion+  , LayerCoverageError (..)   , overlayLayers+  , overlayAll   , overlayEmbeddedTriangulation   , overlayReceipt   , overlayCells@@ -440,6 +484,9 @@   , overlayArrangementEdges   , overlayPlanarLayer   , overlaySelectedRegion+  , overlayMass+  , overlayConfusion+  , layerCovers   , overlayClosedUnion   , overlayClosedIntersection   , overlayRegularizedDifference@@ -447,6 +494,7 @@   , eulerCharacteristicValue   , ExactArea   , exactAreaValue+  , polygonComponentArea   , ExactLengthTerm   , lengthCoefficient   , squaredLength@@ -475,12 +523,52 @@   , MinkowskiError (..)   , MinkowskiReceipt (..)   , convexMinkowskiSum+  , reflectConvexPolygon   , minkowskiSum   , erodeBy   , openWith   , closeWith   , polygonOffset   , polygonInset+  , PowerWeight+  , PowerWeightError (..)+  , powerWeight+  , powerWeightExact+  , PowerSite+  , powerSite+  , powerSiteLabel+  , powerSitePosition+  , powerSiteWeight+  , PowerCellDisposition (..)+  , RegularSiteDisposition (..)+  , RegularFace+  , regularFaceLabels+  , regularFaceDualPoint+  , PowerDualEdge (..)+  , RegularEdge+  , regularEdgeLabels+  , regularEdgeDual+  , RegularTriangulation+  , regularTriangulation+  , regularSiteDisposition+  , regularFaces+  , regularEdges+  , regularNeighbours+  , RegularTriangulationReceipt (..)+  , BoundedPowerDiagram+  , boundedPowerDiagram+  , powerCellDisposition+  , powerCellDispositions+  , powerDiagramPlanarLayer+  , PowerDiagramError (..)+  , RegularTopologyError (..)+  , PowerDiagramReceipt (..)+  , powerDiagramInputSites+  , powerDiagramPeakIntermediateBitGrowth+  , powerDiagramFinalCoordinateBitGrowth+  , AffineForm (..)+  , UpperEnvelopeError (..)+  , upperEnvelope      -- * Discharge — the invariants the constructors guarantee, checkable on a     -- value built by any route; every violation is a value carrying its witness@@ -616,6 +704,7 @@   ( ExactGeometryError (..)   , ExactIntersectionError (..)   , ExactPoint+  , ExactRay   , ExactSegment   , ExactVector (..)   , SegmentRelation (..)@@ -632,6 +721,9 @@   , exactPointFromPoint   , exactPointFromQueryPoint   , exactPointToEmbeddingCandidate+  , exactRay+  , exactRayDirection+  , exactRayOrigin   , exactSegment   , exactSegmentEndpoints   , exactSegmentRelation@@ -671,6 +763,41 @@   ( 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@@ -834,6 +961,7 @@   , StructuringElement   , closeWith   , convexMinkowskiSum+  , reflectConvexPolygon   , convexPolygon   , convexPolygonPoints   , erodeBy@@ -860,11 +988,16 @@   , triangleArea   ) import Moonlight.Triangulation.Overlay-  ( OverlayError (..)+  ( CoverGap+  , LayerCoverageError (..)+  , OverlayError (..)   , OverlayReceipt (..)   , OverlayResult   , OverlaySelectionError (..)   , OverlaySelectionKind (..)+  , coverGapRegion+  , layerCovers+  , overlayAll   , overlayArrangementEdges   , overlayArrangementVertices   , overlayCells@@ -872,11 +1005,54 @@   , overlayClosedUnion   , overlayEmbeddedTriangulation   , overlayLayers+  , overlayMass+  , overlayConfusion   , overlayPlanarLayer   , overlayReceipt   , overlayRegularizedDifference   , overlaySelectedRegion   )+import Moonlight.Triangulation.PowerDiagram+  ( AffineForm (..)+  , BoundedPowerDiagram+  , PowerDualEdge (..)+  , PowerCellDisposition (..)+  , PowerDiagramError (..)+  , PowerDiagramReceipt (..)+  , PowerSite+  , PowerWeight+  , PowerWeightError (..)+  , RegularEdge+  , RegularFace+  , RegularSiteDisposition (..)+  , RegularTriangulation+  , RegularTriangulationReceipt (..)+  , RegularTopologyError (..)+  , UpperEnvelopeError (..)+  , boundedPowerDiagram+  , powerCellDisposition+  , powerCellDispositions+  , powerDiagramPlanarLayer+  , powerDiagramInputSites+  , powerDiagramPeakIntermediateBitGrowth+  , powerDiagramFinalCoordinateBitGrowth+  , powerSite+  , powerSiteLabel+  , powerSitePosition+  , powerSiteWeight+  , powerWeight+  , powerWeightExact+  , regularEdgeDual+  , regularEdgeLabels+  , regularEdges+  , regularFaceDualPoint+  , regularFaceLabels+  , regularFaces+  , regularNeighbours+  , regularSiteDisposition+  , regularTriangulation+  , upperEnvelope+  ) import Moonlight.Triangulation.Payload   ( PayloadTraversal   , directedPayloads@@ -974,6 +1150,7 @@   , cellValuations   , eulerCharacteristicValue   , exactAreaValue+  , polygonComponentArea   , exactLengthBounds   , exactLengthExpression   , exactLengthTerms

@@ -3,7 +3,9 @@ module Moonlight.Triangulation.Internal.Minkowski.Convex   ( convexPolygon   , convexPolygonPoints+  , convexPolygonComponent   , convexPolygonRegion+  , convexPolygonFromRetained   , admittedConvexLoop   , structuringElement   , structuringElementPolygon@@ -17,29 +19,34 @@   , subtractExactPoints   ) where -import Control.Monad (foldM) 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-  ( ExactPoint+  ( ExactClipDisposition (..)+  , ExactClipReceipt+  , ExactClosedHalfPlane+  , ExactPoint+  , ExactRetainedPolygon   , ExactVector (..)   , addExactVectors+  , exactClipRetainedPolygon+  , exactClosedHalfPlaneFromDirectedEdge   , compareExactVectorAngle   , exactVectorFromPoints-  , exactSegment-  , exactSupportingLineIntersection   , exactOrient2d   , exactPoint   , exactPointCoordinates+  , exactRetainedPolygon+  , exactRetainedPolygonPoints   , translateExactPoint   ) import Moonlight.Triangulation.Internal.BoundaryCycle   ( cyclePairs   , cyclePairsNonEmpty-  , cyclicTriples+  , firstNonCounterClockwiseTurn   , rotateCycleLeast   , rotateCycleLeastBy   )@@ -70,31 +77,33 @@ convexPolygon submitted = do   loop <- first MinkowskiInvalidConvexLoop (exactLoop submitted)   let points = exactLoopPoints loop-  case-    [ (index, turn)-    | (index, (previous, current, next)) <--        zip [0 :: Int ..] (cyclicTriples (NonEmpty.toList points))-    , let turn = exactOrient2d previous current next-    , turn /= GT-    ] of-    (index, turn) : _ -> Left (MinkowskiNonConvexTurn index turn)-    [] -> Right (ConvexPolygon loop)+  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 (ConvexPolygon loop) =-  PlanarRegion [PolygonComponent loop []]+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-  | all ((== GT) . orderedTurn) (cyclicTriples (NonEmpty.toList (exactLoopPoints loop))) =-      Just (ConvexPolygon loop)-  | otherwise = Nothing- where-  orderedTurn (previous, current, next) =-    exactOrient2d previous current next+admittedConvexLoop loop =+  case firstNonCounterClockwiseTurn exactOrient2d (exactLoopPoints loop) of+    Nothing -> Just (ConvexPolygon loop)+    Just _ -> Nothing  structuringElement   :: ConvexPolygon@@ -131,7 +140,7 @@       directionList = NonEmpty.toList directions       scanned = scanl translateExactPoint start directionList       resultPoints = start :| take (length directionList - 1) (drop 1 scanned)-   in ConvexPolygon (ExactLoop (rotateCycleLeast resultPoints))+   in admittedConvexPolygon resultPoints  convexHullPolygon   :: NonEmpty ExactPoint@@ -140,16 +149,13 @@   let points = NonEmpty.toList submitted    in case convexHullPoints points of     Nothing -> Left (MinkowskiConvexHullDegenerate points)-    Just hullPoints -> Right (ConvexPolygon (ExactLoop (rotateCycleLeast hullPoints)))+    Just hullPoints -> Right (admittedConvexPolygon hullPoints)  reflectConvexPolygon :: ConvexPolygon -> ConvexPolygon-reflectConvexPolygon polygon =-  ConvexPolygon-    ( ExactLoop-        ( rotateCycleLeast-            (NonEmpty.reverse (fmap negateExactPoint (convexPolygonPoints polygon)))-        )-    )+reflectConvexPolygon =+  admittedConvexPolygon+    . fmap negateExactPoint+    . convexPolygonPoints  convexPolygonCentroid   :: ConvexPolygon@@ -169,27 +175,35 @@   pure (exactPoint x y)  -- | Erode one convex polygon by another through the strongest translated--- support half-plane for each source edge. Sutherland--Hodgman descent keeps--- the construction exact; a lower-dimensional residual is represented by the--- empty polygonal region at this two-dimensional publication boundary.+-- 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)+  -> Either MinkowskiError (Maybe ConvexPolygon, ExactClipReceipt) erodeConvexBy source kernel = do   let sourcePoints = convexPolygonPoints source       kernelPoints = convexPolygonPoints kernel       firstKernel = NonEmpty.head kernelPoints       initial =-        map+        fmap           (`subtractExactPoints` firstKernel)-          (NonEmpty.toList sourcePoints)-      halfPlanes =-        [ strongestHalfPlane kernelPoints from to-        | (from, to) <- cyclePairs sourcePoints-        ]-  clipped <- foldM clipPolygon initial halfPlanes-  pure (ConvexPolygon . ExactLoop . rotateCycleLeast <$> convexHullPoints clipped)+          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@@ -247,7 +261,7 @@   :: NonEmpty ExactPoint   -> ExactPoint   -> ExactPoint-  -> (ExactPoint, ExactPoint)+  -> Either MinkowskiError ExactClosedHalfPlane strongestHalfPlane kernelPoints from to =   let direction = exactVectorFromPoints from to       supportPoint =@@ -261,50 +275,17 @@                    else selected)               initial               remaining-   in ( subtractExactPoints from supportPoint-      , subtractExactPoints to supportPoint-      )+   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 -clipPolygon-  :: [ExactPoint]-  -> (ExactPoint, ExactPoint)-  -> Either MinkowskiError [ExactPoint]-clipPolygon [] _ = Right []-clipPolygon polygon halfPlane =-  concat <$> traverse (clipEdge halfPlane) (cyclePairsList polygon)--clipEdge-  :: (ExactPoint, ExactPoint)-  -> (ExactPoint, ExactPoint)-  -> Either MinkowskiError [ExactPoint]-clipEdge (boundaryFrom, boundaryTo) (from, to) =-  case (inside from, inside to) of-    (True, True) -> Right [to]-    (True, False) -> (: []) <$> supportingLineIntersection from to boundaryFrom boundaryTo-    (False, True) -> do-      crossing <- supportingLineIntersection from to boundaryFrom boundaryTo-      pure [crossing, to]-    (False, False) -> Right []- where-  inside point = exactOrient2d boundaryFrom boundaryTo point /= LT--supportingLineIntersection-  :: ExactPoint-  -> ExactPoint-  -> ExactPoint-  -> ExactPoint-  -> Either MinkowskiError ExactPoint-supportingLineIntersection lineFrom lineTo boundaryFrom boundaryTo = do-  clippedSegment <- first MinkowskiInvalidSegment (exactSegment lineFrom lineTo)-  boundarySegment <- first MinkowskiInvalidSegment (exactSegment boundaryFrom boundaryTo)-  first MinkowskiLineIntersection-    (exactSupportingLineIntersection clippedSegment boundarySegment)- addExactPoints :: ExactPoint -> ExactPoint -> ExactPoint addExactPoints left right =   let (leftX, leftY) = exactPointCoordinates left@@ -321,6 +302,3 @@ negateExactPoint point =   let (x, y) = exactPointCoordinates point    in exactPoint (negate x) (negate y)--cyclePairsList :: [value] -> [(value, value)]-cyclePairsList = maybe [] cyclePairs . NonEmpty.nonEmpty

@@ -14,8 +14,8 @@ import Control.DeepSeq (NFData) import GHC.Generics (Generic) import Moonlight.Triangulation.Exact-  ( ExactGeometryError-  , ExactIntersectionError+  ( ExactClipError+  , ExactHalfPlaneError   , ExactPoint   ) import Moonlight.Triangulation.Internal.HandleDefs (FaceId)@@ -50,11 +50,11 @@  data MinkowskiError   = MinkowskiInvalidConvexLoop !RegionValidationError-  | MinkowskiInvalidSegment !ExactGeometryError+  | MinkowskiInvalidHalfPlane !ExactHalfPlaneError+  | MinkowskiClipFailed !ExactClipError   | MinkowskiNonConvexTurn !Int !Ordering   | MinkowskiOriginOutside !RegionPointLocation   | MinkowskiExactArithmetic !ExactArithmeticError-  | MinkowskiLineIntersection !ExactIntersectionError   | MinkowskiOverlayFailed !(OverlayError Bool Bool)   | MinkowskiPublicationFailed !RegionPublicationError   | MinkowskiOverlayCellWitness !OverlayCellWitness

@@ -1,811 +0,0 @@-{-# 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.Internal.Overlay.Embedding-  ( DraftId (..)-  , DraftIncidence (..)-  , DraftNeighborhood (..)-  , DraftReference (..)-  , DraftVertexId-  , ExactArrangementDraft (..)-  , LocalEmbeddingCertificate (..)-  , 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)

@@ -1,539 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}---- | Bounded certification of local binary64 embedding obligations for a--- declared exact arrangement draft.-module Moonlight.Triangulation.Internal.Overlay.Embedding-  ( DraftId (..)-  , DraftVertexId-  , DraftSegmentId-  , DraftSourceId-  , DraftIncidence (..)-  , DraftNeighborhood (..)-  , ExactArrangementDraft (..)-  , DraftReference (..)-  , OverlayEmbeddingObstruction (..)-  , EmbeddingObligation (..)-  , EmbeddingResidual-  , residualUndischargedObligations-  , milestoneOneResidual-  , LocalEmbeddingCertificate (..)-  , certifyLocalEmbedding-  ) where--import Control.DeepSeq (NFData)-import Data.List (sort, tails)-import 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)-import Moonlight.Triangulation.Internal.ExactRational (ExactRational)-import qualified Moonlight.Triangulation.Math as Math-  ( 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 : remainingIds) <- tails (sort vertexIds)-  , rightId <- remainingIds-  ]- where-  verticesByRoundedPoint =-    Map.fromListWith (<>)-      [ (projectedRoundedPoint projectedVertex, [vertexId])-      | (vertexId, projectedVertex) <- Map.toAscList projectedVertices-      ]--splitOrderObstructions-  :: DraftSourceId-  -> [ResolvedMembership]-  -> [OverlayEmbeddingObstruction]-splitOrderObstructions sourceId memberships =-  case memberships of-    firstMembership : secondMembership : remainingMemberships ->-      let finalMembership =-            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 Math.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-    ( Math.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