diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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`. | diff --git a/bench/layer/Main.hs b/bench/layer/Main.hs new file mode 100644 --- /dev/null +++ b/bench/layer/Main.hs @@ -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 diff --git a/bench/layer/Moonlight/Triangulation/LayerBench.hs b/bench/layer/Moonlight/Triangulation/LayerBench.hs new file mode 100644 --- /dev/null +++ b/bench/layer/Moonlight/Triangulation/LayerBench.hs @@ -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 diff --git a/bench/power/Main.hs b/bench/power/Main.hs new file mode 100644 --- /dev/null +++ b/bench/power/Main.hs @@ -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 diff --git a/bench/power/Moonlight/Triangulation/PowerBench.hs b/bench/power/Moonlight/Triangulation/PowerBench.hs new file mode 100644 --- /dev/null +++ b/bench/power/Moonlight/Triangulation/PowerBench.hs @@ -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) diff --git a/docs/README.md b/docs/README.md --- a/docs/README.md +++ b/docs/README.md @@ -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) | diff --git a/moonlight-triangulation.cabal b/moonlight-triangulation.cabal --- a/moonlight-triangulation.cabal +++ b/moonlight-triangulation.cabal @@ -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: diff --git a/src-build/Moonlight/Triangulation/Internal/Join.hs b/src-build/Moonlight/Triangulation/Internal/Join.hs --- a/src-build/Moonlight/Triangulation/Internal/Join.hs +++ b/src-build/Moonlight/Triangulation/Internal/Join.hs @@ -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 diff --git a/src-build/Moonlight/Triangulation/Internal/Join/Plan.hs b/src-build/Moonlight/Triangulation/Internal/Join/Plan.hs --- a/src-build/Moonlight/Triangulation/Internal/Join/Plan.hs +++ b/src-build/Moonlight/Triangulation/Internal/Join/Plan.hs @@ -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 diff --git a/src-core/Moonlight/Triangulation/Internal/ExactRational.hs b/src-core/Moonlight/Triangulation/Internal/ExactRational.hs --- a/src-core/Moonlight/Triangulation/Internal/ExactRational.hs +++ b/src-core/Moonlight/Triangulation/Internal/ExactRational.hs @@ -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 diff --git a/src-dcel/Moonlight/Triangulation/Dcel.hs b/src-dcel/Moonlight/Triangulation/Dcel.hs --- a/src-dcel/Moonlight/Triangulation/Dcel.hs +++ b/src-dcel/Moonlight/Triangulation/Dcel.hs @@ -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 diff --git a/src-dcel/Moonlight/Triangulation/Exact.hs b/src-dcel/Moonlight/Triangulation/Exact.hs --- a/src-dcel/Moonlight/Triangulation/Exact.hs +++ b/src-dcel/Moonlight/Triangulation/Exact.hs @@ -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) = diff --git a/src-dcel/Moonlight/Triangulation/Handles/HandleDefs.hs b/src-dcel/Moonlight/Triangulation/Handles/HandleDefs.hs --- a/src-dcel/Moonlight/Triangulation/Handles/HandleDefs.hs +++ b/src-dcel/Moonlight/Triangulation/Handles/HandleDefs.hs @@ -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 diff --git a/src-dcel/Moonlight/Triangulation/Handles/Scoped.hs b/src-dcel/Moonlight/Triangulation/Handles/Scoped.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Handles/Scoped.hs @@ -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) diff --git a/src-dcel/Moonlight/Triangulation/Internal/BoundaryCycle.hs b/src-dcel/Moonlight/Triangulation/Internal/BoundaryCycle.hs --- a/src-dcel/Moonlight/Triangulation/Internal/BoundaryCycle.hs +++ b/src-dcel/Moonlight/Triangulation/Internal/BoundaryCycle.hs @@ -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 #-} diff --git a/src-dcel/Moonlight/Triangulation/Internal/Tournament.hs b/src-dcel/Moonlight/Triangulation/Internal/Tournament.hs new file mode 100644 --- /dev/null +++ b/src-dcel/Moonlight/Triangulation/Internal/Tournament.hs @@ -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 diff --git a/src-dcel/Moonlight/Triangulation/Region.hs b/src-dcel/Moonlight/Triangulation/Region.hs --- a/src-dcel/Moonlight/Triangulation/Region.hs +++ b/src-dcel/Moonlight/Triangulation/Region.hs @@ -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) = diff --git a/src-dcel/Moonlight/Triangulation/Valuation.hs b/src-dcel/Moonlight/Triangulation/Valuation.hs --- a/src-dcel/Moonlight/Triangulation/Valuation.hs +++ b/src-dcel/Moonlight/Triangulation/Valuation.hs @@ -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 diff --git a/src-overlay/Moonlight/Triangulation/Embedding.hs b/src-overlay/Moonlight/Triangulation/Embedding.hs new file mode 100644 --- /dev/null +++ b/src-overlay/Moonlight/Triangulation/Embedding.hs @@ -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 diff --git a/src-overlay/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs b/src-overlay/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs new file mode 100644 --- /dev/null +++ b/src-overlay/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs @@ -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) diff --git a/src-overlay/Moonlight/Triangulation/Internal/Overlay/Resident.hs b/src-overlay/Moonlight/Triangulation/Internal/Overlay/Resident.hs new file mode 100644 --- /dev/null +++ b/src-overlay/Moonlight/Triangulation/Internal/Overlay/Resident.hs @@ -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)) diff --git a/src-overlay/Moonlight/Triangulation/Internal/Overlay/Types.hs b/src-overlay/Moonlight/Triangulation/Internal/Overlay/Types.hs new file mode 100644 --- /dev/null +++ b/src-overlay/Moonlight/Triangulation/Internal/Overlay/Types.hs @@ -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) diff --git a/src-parallel/Moonlight/Triangulation/Parallel.hs b/src-parallel/Moonlight/Triangulation/Parallel.hs --- a/src-parallel/Moonlight/Triangulation/Parallel.hs +++ b/src-parallel/Moonlight/Triangulation/Parallel.hs @@ -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) diff --git a/src-public/Moonlight/Triangulation.hs b/src-public/Moonlight/Triangulation.hs --- a/src-public/Moonlight/Triangulation.hs +++ b/src-public/Moonlight/Triangulation.hs @@ -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 diff --git a/src-public/Moonlight/Triangulation/Internal/Minkowski/Convex.hs b/src-public/Moonlight/Triangulation/Internal/Minkowski/Convex.hs --- a/src-public/Moonlight/Triangulation/Internal/Minkowski/Convex.hs +++ b/src-public/Moonlight/Triangulation/Internal/Minkowski/Convex.hs @@ -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 diff --git a/src-public/Moonlight/Triangulation/Internal/Minkowski/Types.hs b/src-public/Moonlight/Triangulation/Internal/Minkowski/Types.hs --- a/src-public/Moonlight/Triangulation/Internal/Minkowski/Types.hs +++ b/src-public/Moonlight/Triangulation/Internal/Minkowski/Types.hs @@ -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 diff --git a/src-public/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs b/src-public/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs deleted file mode 100644 --- a/src-public/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs +++ /dev/null @@ -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) diff --git a/src-public/Moonlight/Triangulation/Internal/Overlay/Embedding.hs b/src-public/Moonlight/Triangulation/Internal/Overlay/Embedding.hs deleted file mode 100644 --- a/src-public/Moonlight/Triangulation/Internal/Overlay/Embedding.hs +++ /dev/null @@ -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 diff --git a/src-public/Moonlight/Triangulation/Internal/Overlay/Resident.hs b/src-public/Moonlight/Triangulation/Internal/Overlay/Resident.hs deleted file mode 100644 --- a/src-public/Moonlight/Triangulation/Internal/Overlay/Resident.hs +++ /dev/null @@ -1,923 +0,0 @@ -{-# 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)) diff --git a/src-public/Moonlight/Triangulation/Internal/Overlay/Types.hs b/src-public/Moonlight/Triangulation/Internal/Overlay/Types.hs deleted file mode 100644 --- a/src-public/Moonlight/Triangulation/Internal/Overlay/Types.hs +++ /dev/null @@ -1,274 +0,0 @@ -{-# 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.Internal.Overlay.Embedding (OverlayEmbeddingObstruction) -import Moonlight.Triangulation.Internal.Region.Types - ( ExactLoop - , PolygonComponent - , RegionPublicationError - ) -import Moonlight.Triangulation.Internal.Representation (Triangulation) -import Moonlight.Triangulation.Internal.Types - ( ConstraintMode (Constrained) - ) - --- | Which cycle inside a polygon component supplied a source reference. -data BoundaryLoopRef - = BoundaryOuterLoop - | BoundaryHoleLoop !Int - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - -data OverlayOperand - = LeftOverlayOperand - | RightOverlayOperand - --- | 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) diff --git a/src-public/Moonlight/Triangulation/Internal/RegularTriangulation.hs b/src-public/Moonlight/Triangulation/Internal/RegularTriangulation.hs new file mode 100644 --- /dev/null +++ b/src-public/Moonlight/Triangulation/Internal/RegularTriangulation.hs @@ -0,0 +1,1111 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Exact upper-hull descent for affine generators. The public power owner +-- supplies admitted, distinct slopes; this module returns only topology and +-- exact dual geometry. +module Moonlight.Triangulation.Internal.RegularTriangulation + ( ExactPowerGenerator (..) + , DistinctSlopeGenerators (..) + , RegularGeneratorDisposition (..) + , GeneratorRegularFace (..) + , GeneratorDualGeometry (..) + , GeneratorRegularEdge (..) + , GeneratorRegularTopology (..) + , GeneratorRegularReceipt (..) + , RegularTopologyError (..) + , regularGeneratorTopology + , exactGeneratorAxis + ) where + +import Control.DeepSeq (NFData) +import Data.Bifunctor (first) +import qualified Data.Foldable as Foldable +import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Generics (Generic) +import Moonlight.Triangulation.Exact + ( ExactAffineLine + , ExactGeometryError + , ExactHalfPlaneError + , ExactIntersectionError + , ExactPoint + , ExactRay + , ExactSegment + , ExactVector (..) + , exactAffineLine + , exactAffineLineCoefficients + , exactAffineLineIntersection + , exactPoint + , exactPointCoordinates + , exactRay + , exactSegment + ) +import Moonlight.Triangulation.Internal.ExactRational + ( ExactRational ) +import Moonlight.Triangulation.Internal.BoundaryCycle + ( consecutivePairs ) +import Moonlight.Triangulation.Internal.Minkowski.Convex + ( convexHullPolygon ) +import Moonlight.Triangulation.Minkowski + ( MinkowskiError + , convexPolygonPoints + ) + +-- | Exact affine score @constant + xCoefficient*x + yCoefficient*y@. +data ExactPowerGenerator label = ExactPowerGenerator + { exactPowerGeneratorLabel :: !label + , exactPowerGeneratorXCoefficient :: !ExactRational + , exactPowerGeneratorYCoefficient :: !ExactRational + , exactPowerGeneratorConstant :: !ExactRational + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Package-internal witness that coincident affine slopes were resolved once. +newtype DistinctSlopeGenerators label = + DistinctSlopeGenerators (NonEmpty (ExactPowerGenerator label)) + +data RegularGeneratorDisposition + = RegularGeneratorVisible + | RegularGeneratorLowerDimensional + | RegularGeneratorHidden + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +data GeneratorRegularFace label = GeneratorRegularFace + { generatorRegularFaceFirst :: !label + , generatorRegularFaceSecond :: !label + , generatorRegularFaceThird :: !label + , generatorRegularFaceDualPoint :: !ExactPoint + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +data GeneratorDualGeometry + = GeneratorDualSegment !ExactSegment + | GeneratorDualRay !ExactRay + | GeneratorDualLine !ExactAffineLine + | GeneratorDualCollapsed !ExactPoint + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +data GeneratorRegularEdge label = GeneratorRegularEdge + { generatorRegularEdgeFirst :: !(ExactPowerGenerator label) + , generatorRegularEdgeSecond :: !(ExactPowerGenerator label) + , generatorRegularEdgeDual :: !GeneratorDualGeometry + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +data GeneratorRegularTopology label = GeneratorRegularTopology + { generatorRegularDispositions :: !(NonEmpty (ExactPowerGenerator label, RegularGeneratorDisposition)) + , generatorRegularFaces :: ![GeneratorRegularFace label] + , generatorRegularEdges :: ![GeneratorRegularEdge label] + , generatorRegularReceipt :: !GeneratorRegularReceipt + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +data GeneratorRegularReceipt = GeneratorRegularReceipt + { generatorRegularInputSites :: !Int + , generatorRegularVisibleSites :: !Int + , generatorRegularLowerDimensionalSites :: !Int + , generatorRegularHiddenSites :: !Int + , generatorRegularFaceCount :: !Int + , generatorRegularEdgeCount :: !Int + , generatorRegularPeakHullFaces :: !Int + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +data RegularTopologyError label + = RegularTopologySlopeHullInvalid !MinkowskiError + | RegularTopologySlopeVertexMissing !ExactPoint + | RegularTopologyAxisInvalid !label !label !ExactHalfPlaneError + | RegularTopologyDualVertexInvalid !label !label !label !ExactIntersectionError + | RegularTopologyDualSegmentInvalid !label !label !ExactGeometryError + | RegularTopologyDualRayInvalid !label !label !ExactGeometryError + | RegularTopologyFlatBoundary !label !label !label + | RegularTopologyNonManifoldEdge !label !label !Int + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | Construct exact regular topology from distinct affine slopes. Full-rank +-- input uses one conflict graph; collinear slopes use the one-dimensional +-- upper chain; coplanar lifted input reuses the exact planar hull owner. +regularGeneratorTopology + :: Ord label + => DistinctSlopeGenerators label + -> Either (RegularTopologyError label) (GeneratorRegularTopology label) +regularGeneratorTopology (DistinctSlopeGenerators generators) = + let points = admittedLiftedPoints generators + in case points of + singleton :| [] -> + pure (topologyFromParts points (Set.singleton singleton) Set.empty [] [] 0) + firstPoint :| secondPoint : remaining -> + case List.find (not . slopeCollinear firstPoint secondPoint) remaining of + Nothing -> collinearSlopeTopology points firstPoint secondPoint + Just thirdPoint -> + case List.find (not . liftedCoplanar firstPoint secondPoint thirdPoint) remaining of + Nothing -> coplanarLiftedTopology points + Just fourthPoint -> fullRankTopology points firstPoint secondPoint thirdPoint fourthPoint + +-- | The equality line of two distinct-slope affine generators. +exactGeneratorAxis + :: ExactPowerGenerator label + -> ExactPowerGenerator label + -> Either ExactHalfPlaneError ExactAffineLine +exactGeneratorAxis firstGenerator secondGenerator = + exactAffineLine + ( exactPowerGeneratorXCoefficient firstGenerator + - exactPowerGeneratorXCoefficient secondGenerator + ) + ( exactPowerGeneratorYCoefficient firstGenerator + - exactPowerGeneratorYCoefficient secondGenerator + ) + ( exactPowerGeneratorConstant firstGenerator + - exactPowerGeneratorConstant secondGenerator + ) + +data LiftedPoint label = LiftedPoint + { liftedPointId :: !Int + , liftedPointGenerator :: !(ExactPowerGenerator label) + } + +instance Eq (LiftedPoint label) where + left == right = liftedPointId left == liftedPointId right + +instance Ord (LiftedPoint label) where + compare left right = compare (liftedPointId left) (liftedPointId right) + +admittedLiftedPoints + :: Ord label + => NonEmpty (ExactPowerGenerator label) + -> NonEmpty (LiftedPoint label) +admittedLiftedPoints generators = + let ordered = NonEmpty.sortWith exactPowerGeneratorLabel generators + in NonEmpty.zipWith + (\identifier generator -> LiftedPoint identifier generator) + (0 :| [1 ..]) + ordered + +liftedCoordinates + :: LiftedPoint label + -> (ExactRational, ExactRational, ExactRational) +liftedCoordinates point = + let generator = liftedPointGenerator point + in ( exactPowerGeneratorXCoefficient generator + , exactPowerGeneratorYCoefficient generator + , exactPowerGeneratorConstant generator + ) + +slopePoint :: LiftedPoint label -> ExactPoint +slopePoint point = + let (coordinateX, coordinateY, _) = liftedCoordinates point + in exactPoint coordinateX coordinateY + +slopeCollinear + :: LiftedPoint label + -> LiftedPoint label + -> LiftedPoint label + -> Bool +slopeCollinear firstPoint secondPoint thirdPoint = + slopeOrientation firstPoint secondPoint thirdPoint == 0 + +slopeOrientation + :: LiftedPoint label + -> LiftedPoint label + -> LiftedPoint label + -> ExactRational +slopeOrientation firstPoint secondPoint thirdPoint = + let (firstX, firstY, _) = liftedCoordinates firstPoint + (secondX, secondY, _) = liftedCoordinates secondPoint + (thirdX, thirdY, _) = liftedCoordinates thirdPoint + in (secondX - firstX) * (thirdY - firstY) + - (secondY - firstY) * (thirdX - firstX) + +liftedCoplanar + :: LiftedPoint label + -> LiftedPoint label + -> LiftedPoint label + -> LiftedPoint label + -> Bool +liftedCoplanar firstPoint secondPoint thirdPoint fourthPoint = + liftedVolume firstPoint secondPoint thirdPoint fourthPoint == 0 + +liftedVolume + :: LiftedPoint label + -> LiftedPoint label + -> LiftedPoint label + -> LiftedPoint label + -> ExactRational +liftedVolume firstPoint secondPoint thirdPoint fourthPoint = + let (firstX, firstY, firstZ) = liftedCoordinates firstPoint + (secondX, secondY, secondZ) = liftedCoordinates secondPoint + (thirdX, thirdY, thirdZ) = liftedCoordinates thirdPoint + (fourthX, fourthY, fourthZ) = liftedCoordinates fourthPoint + secondX' = secondX - firstX + secondY' = secondY - firstY + secondZ' = secondZ - firstZ + thirdX' = thirdX - firstX + thirdY' = thirdY - firstY + thirdZ' = thirdZ - firstZ + fourthX' = fourthX - firstX + fourthY' = fourthY - firstY + fourthZ' = fourthZ - firstZ + in secondX' * (thirdY' * fourthZ' - thirdZ' * fourthY') + - secondY' * (thirdX' * fourthZ' - thirdZ' * fourthX') + + secondZ' * (thirdX' * fourthY' - thirdY' * fourthX') + +data HullFace label = HullFace + { hullFaceId :: !Int + , hullFaceFirst :: !(LiftedPoint label) + , hullFaceSecond :: !(LiftedPoint label) + , hullFaceThird :: !(LiftedPoint label) + , hullFaceOutside :: !(Set (LiftedPoint label)) + , hullFaceCoplanar :: !(Set (LiftedPoint label)) + } + +type HullEdge = (Int, Int) + +data HullState label = HullState + { hullFaces :: !(IntMap.IntMap (HullFace label)) + , hullEdgeFaces :: !(Map HullEdge IntSet.IntSet) + , hullConflictFaces :: !IntSet.IntSet + , hullNextFaceId :: !Int + , hullPeakFaceCount :: !Int + } + +fullRankTopology + :: NonEmpty (LiftedPoint label) + -> LiftedPoint label + -> LiftedPoint label + -> LiftedPoint label + -> LiftedPoint label + -> Either (RegularTopologyError label) (GeneratorRegularTopology label) +fullRankTopology points firstPoint secondPoint thirdPoint fourthPoint = do + let interior = liftedInteriorSum firstPoint secondPoint thirdPoint fourthPoint + simplex = Set.fromList [firstPoint, secondPoint, thirdPoint, fourthPoint] + initialFaces = + zipWith + (orientedHullFace interior) + [0 ..] + [ (firstPoint, secondPoint, thirdPoint) + , (firstPoint, fourthPoint, secondPoint) + , (firstPoint, thirdPoint, fourthPoint) + , (secondPoint, fourthPoint, thirdPoint) + ] + initialState = + List.foldl' + insertHullFace + (HullState IntMap.empty Map.empty IntSet.empty 4 4) + initialFaces + seededState = + Foldable.foldl' + (flip assignPointToHull) + initialState + (filter (`Set.notMember` simplex) (NonEmpty.toList points)) + finalState = descendHull interior seededState + upperFaces = filter ((> 0) . hullFaceNormalZ) (IntMap.elems (hullFaces finalState)) + (canonicalFaces, visible, lowerDimensional) <- canonicalUpperFaces upperFaces + (faces, edges) <- topologyFromHullFaces canonicalFaces + pure + ( topologyFromParts + points + visible + lowerDimensional + faces + edges + (hullPeakFaceCount finalState) + ) + +liftedInteriorSum + :: LiftedPoint label + -> LiftedPoint label + -> LiftedPoint label + -> LiftedPoint label + -> (ExactRational, ExactRational, ExactRational) +liftedInteriorSum firstPoint secondPoint thirdPoint fourthPoint = + let (firstX, firstY, firstZ) = liftedCoordinates firstPoint + (secondX, secondY, secondZ) = liftedCoordinates secondPoint + (thirdX, thirdY, thirdZ) = liftedCoordinates thirdPoint + (fourthX, fourthY, fourthZ) = liftedCoordinates fourthPoint + in ( firstX + secondX + thirdX + fourthX + , firstY + secondY + thirdY + fourthY + , firstZ + secondZ + thirdZ + fourthZ + ) + +orientedHullFace + :: (ExactRational, ExactRational, ExactRational) + -> Int + -> (LiftedPoint label, LiftedPoint label, LiftedPoint label) + -> HullFace label +orientedHullFace interior identifier (firstPoint, secondPoint, thirdPoint) = + let provisional = HullFace identifier firstPoint secondPoint thirdPoint Set.empty Set.empty + in if hullFaceVolumeAtInterior interior provisional < 0 + then provisional + else HullFace identifier firstPoint thirdPoint secondPoint Set.empty Set.empty + +hullFaceVolumeAtInterior + :: (ExactRational, ExactRational, ExactRational) + -> HullFace label + -> ExactRational +hullFaceVolumeAtInterior (sumX, sumY, sumZ) face = + let (firstX, firstY, firstZ) = liftedCoordinates (hullFaceFirst face) + (secondX, secondY, secondZ) = liftedCoordinates (hullFaceSecond face) + (thirdX, thirdY, thirdZ) = liftedCoordinates (hullFaceThird face) + secondX' = secondX - firstX + secondY' = secondY - firstY + secondZ' = secondZ - firstZ + thirdX' = thirdX - firstX + thirdY' = thirdY - firstY + thirdZ' = thirdZ - firstZ + interiorX' = sumX - 4 * firstX + interiorY' = sumY - 4 * firstY + interiorZ' = sumZ - 4 * firstZ + in secondX' * (thirdY' * interiorZ' - thirdZ' * interiorY') + - secondY' * (thirdX' * interiorZ' - thirdZ' * interiorX') + + secondZ' * (thirdX' * interiorY' - thirdY' * interiorX') + +liftedVolumeAtFace :: HullFace label -> LiftedPoint label -> ExactRational +liftedVolumeAtFace face = + liftedVolume + (hullFaceFirst face) + (hullFaceSecond face) + (hullFaceThird face) + +hullFaceNormalZ :: HullFace label -> ExactRational +hullFaceNormalZ face = + slopeOrientation + (hullFaceFirst face) + (hullFaceSecond face) + (hullFaceThird face) + +hullFacePoints :: HullFace label -> [LiftedPoint label] +hullFacePoints face = + [hullFaceFirst face, hullFaceSecond face, hullFaceThird face] + +hullFaceDirectedEdges + :: HullFace label + -> [(LiftedPoint label, LiftedPoint label)] +hullFaceDirectedEdges face = + [ (hullFaceFirst face, hullFaceSecond face) + , (hullFaceSecond face, hullFaceThird face) + , (hullFaceThird face, hullFaceFirst face) + ] + +hullEdgeKey :: LiftedPoint label -> LiftedPoint label -> HullEdge +hullEdgeKey firstPoint secondPoint = + let firstId = liftedPointId firstPoint + secondId = liftedPointId secondPoint + in if firstId <= secondId then (firstId, secondId) else (secondId, firstId) + +insertHullFace :: HullState label -> HullFace label -> HullState label +insertHullFace state face = + state + { hullFaces = IntMap.insert (hullFaceId face) face (hullFaces state) + , hullEdgeFaces = + List.foldl' + (\incidence (fromPoint, toPoint) -> + Map.insertWith + IntSet.union + (hullEdgeKey fromPoint toPoint) + (IntSet.singleton (hullFaceId face)) + incidence) + (hullEdgeFaces state) + (hullFaceDirectedEdges face) + , hullPeakFaceCount = max (hullPeakFaceCount state) (IntMap.size (hullFaces state) + 1) + } + +assignPointToHull :: LiftedPoint label -> HullState label -> HullState label +assignPointToHull point state = + attachSelectedPoint point state + (selectHullFace point (IntMap.elems (hullFaces state))) + +data HullFaceSelection label + = HullFaceInterior + | HullFaceCoplanar !(HullFace label) + | HullFaceVisible !(HullFace label) !ExactRational + +selectHullFace + :: LiftedPoint label + -> [HullFace label] + -> HullFaceSelection label +selectHullFace point = List.foldl' choose HullFaceInterior + where + choose selected face = + let volume = liftedVolumeAtFace face point + in case compare volume 0 of + LT -> selected + EQ -> + case selected of + HullFaceInterior -> HullFaceCoplanar face + _ -> selected + GT -> + case selected of + HullFaceVisible current currentVolume + | volume < currentVolume + || (volume == currentVolume && hullFaceId current < hullFaceId face) -> + selected + _ -> HullFaceVisible face volume + +attachSelectedPoint + :: LiftedPoint label + -> HullState label + -> HullFaceSelection label + -> HullState label +attachSelectedPoint point state selection = + case selection of + HullFaceInterior -> state + HullFaceCoplanar face -> + state + { hullFaces = + IntMap.adjust + (\selected -> selected{hullFaceCoplanar = Set.insert point (hullFaceCoplanar selected)}) + (hullFaceId face) + (hullFaces state) + } + HullFaceVisible face _ -> + state + { hullFaces = + IntMap.adjust + (\selected -> selected{hullFaceOutside = Set.insert point (hullFaceOutside selected)}) + (hullFaceId face) + (hullFaces state) + , hullConflictFaces = IntSet.insert (hullFaceId face) (hullConflictFaces state) + } + +descendHull + :: (ExactRational, ExactRational, ExactRational) + -> HullState label + -> HullState label +descendHull interior state = + case nextHullExpansion state of + Nothing -> state + Just (seedFace, apex) -> + let visible = visibleHullPatch state apex (IntSet.singleton (hullFaceId seedFace)) [hullFaceId seedFace] + visibleFaces = + mapMaybe (`IntMap.lookup` hullFaces state) (IntSet.toAscList visible) + horizon = hullHorizon state visible visibleFaces + candidates = + Set.difference + ( Set.delete apex + ( Set.unions + [ Set.unions + [ hullFaceOutside face + , hullFaceCoplanar face + , Set.fromList (hullFacePoints face) + ] + | face <- visibleFaces + ] + ) + ) + ( Set.fromList + [ point + | (firstPoint, secondPoint) <- Map.elems horizon + , point <- [firstPoint, secondPoint] + ] + ) + withoutVisible = removeHullFaces visibleFaces state + (withHorizon, newFaceIds) = + Map.foldl' + (insertHorizonFace interior apex) + (withoutVisible, []) + horizon + redistributed = + Foldable.foldl' + (assignPointToFaces newFaceIds) + withHorizon + candidates + in descendHull interior redistributed + +nextHullExpansion + :: HullState label + -> Maybe (HullFace label, LiftedPoint label) +nextHullExpansion state = do + identifier <- IntSet.lookupMin (hullConflictFaces state) + face <- IntMap.lookup identifier (hullFaces state) + apex <- farthestOutsidePoint face + pure (face, apex) + +farthestOutsidePoint :: HullFace label -> Maybe (LiftedPoint label) +farthestOutsidePoint face = + case Set.minView (hullFaceOutside face) of + Nothing -> Nothing + Just (initial, remaining) -> + Just + ( fst + ( Foldable.foldl' + (\(selected, selectedVolume) candidate -> + let candidateVolume = liftedVolumeAtFace face candidate + in if candidateVolume > selectedVolume + then (candidate, candidateVolume) + else (selected, selectedVolume)) + (initial, liftedVolumeAtFace face initial) + remaining + ) + ) + +visibleHullPatch + :: HullState label + -> LiftedPoint label + -> IntSet.IntSet + -> [Int] + -> IntSet.IntSet +visibleHullPatch _ _ visited [] = visited +visibleHullPatch state apex visited (identifier : remaining) = + case IntMap.lookup identifier (hullFaces state) of + Nothing -> visibleHullPatch state apex visited remaining + Just face -> + let neighbours = + IntSet.unions + [ Map.findWithDefault IntSet.empty (hullEdgeKey fromPoint toPoint) (hullEdgeFaces state) + | (fromPoint, toPoint) <- hullFaceDirectedEdges face + ] + newlyVisible = + IntSet.filter + (\candidateId -> + IntSet.notMember candidateId visited + && maybe + False + ((> 0) . (`liftedVolumeAtFace` apex)) + (IntMap.lookup candidateId (hullFaces state))) + neighbours + in visibleHullPatch + state + apex + (IntSet.union visited newlyVisible) + (IntSet.toList newlyVisible <> remaining) + +hullHorizon + :: HullState label + -> IntSet.IntSet + -> [HullFace label] + -> Map HullEdge (LiftedPoint label, LiftedPoint label) +hullHorizon state visible visibleFaces = + Map.fromList + [ (hullEdgeKey fromPoint toPoint, (fromPoint, toPoint)) + | face <- visibleFaces + , (fromPoint, toPoint) <- hullFaceDirectedEdges face + , not + ( IntSet.null + ( IntSet.difference + (Map.findWithDefault IntSet.empty (hullEdgeKey fromPoint toPoint) (hullEdgeFaces state)) + visible + ) + ) + ] + +removeHullFaces :: [HullFace label] -> HullState label -> HullState label +removeHullFaces removed state = List.foldl' removeHullFace state removed + +removeHullFace :: HullState label -> HullFace label -> HullState label +removeHullFace state face = + state + { hullFaces = IntMap.delete identifier (hullFaces state) + , hullEdgeFaces = + List.foldl' + (removeHullFaceFromEdge identifier) + (hullEdgeFaces state) + (hullFaceDirectedEdges face) + , hullConflictFaces = IntSet.delete identifier (hullConflictFaces state) + } + where + identifier = hullFaceId face + +removeHullFaceFromEdge + :: Int + -> Map HullEdge IntSet.IntSet + -> (LiftedPoint label, LiftedPoint label) + -> Map HullEdge IntSet.IntSet +removeHullFaceFromEdge identifier incidence (fromPoint, toPoint) = + Map.update + (\incident -> + let retained = IntSet.delete identifier incident + in if IntSet.null retained then Nothing else Just retained) + (hullEdgeKey fromPoint toPoint) + incidence + +insertHorizonFace + :: (ExactRational, ExactRational, ExactRational) + -> LiftedPoint label + -> (HullState label, [Int]) + -> (LiftedPoint label, LiftedPoint label) + -> (HullState label, [Int]) +insertHorizonFace interior apex (state, identifiers) (firstPoint, secondPoint) = + let identifier = hullNextFaceId state + face = orientedHullFace interior identifier (firstPoint, secondPoint, apex) + nextState = + (insertHullFace state face) + { hullNextFaceId = identifier + 1 } + in (nextState, identifier : identifiers) + +assignPointToFaces + :: [Int] + -> HullState label + -> LiftedPoint label + -> HullState label +assignPointToFaces identifiers state point = + attachSelectedPoint point state + (selectHullFace point (mapMaybe (`IntMap.lookup` hullFaces state) identifiers)) + +-- | Glue the triangular implementation facets on each exact supporting plane, +-- then recover only that plane's extreme slope vertices. This removes +-- simplex/horizon diagonals from the visibility decision while retaining a +-- deterministic triangulation for incidence and collapsed duals. +canonicalUpperFaces + :: [HullFace label] + -> Either + (RegularTopologyError label) + ( [(HullFace label, ExactPoint)] + , Set (LiftedPoint label) + , Set (LiftedPoint label) + ) +canonicalUpperFaces faces = do + associations <- traverse upperFaceAssociation faces + sections <- + traverse canonicalUpperFaceGroup + ( Map.elems + ( List.foldl' + (\groups (planeKey, dualFace) -> + Map.insertWith (<>) planeKey (dualFace :| []) groups) + Map.empty + associations + ) + ) + let (sectionFaces, visible, lowerDimensional) = mconcat sections + canonicalFaces = + zipWith + (\identifier (face, dualPoint) -> + (face{hullFaceId = identifier}, dualPoint)) + [0 ..] + sectionFaces + pure (canonicalFaces, visible, lowerDimensional) + +canonicalUpperFaceGroup + :: NonEmpty (HullFace label, ExactPoint) + -> Either + (RegularTopologyError label) + ( [(HullFace label, ExactPoint)] + , Set (LiftedPoint label) + , Set (LiftedPoint label) + ) +canonicalUpperFaceGroup ((face, dualPoint) :| []) + | Set.null (hullFaceCoplanar face) = + Right ([(face, dualPoint)], Set.fromList (hullFacePoints face), Set.empty) +canonicalUpperFaceGroup ((firstFace, dualPoint) :| remainingDualFaces) = do + let groupFaces = firstFace : fmap fst remainingDualFaces + groupPoints = + Set.unions + [ Set.union + (Set.fromList (hullFacePoints face)) + (hullFaceCoplanar face) + | face <- groupFaces + ] + initialPoint = hullFaceFirst firstFace + points = initialPoint :| Set.toAscList (Set.delete initialPoint groupPoints) + pointsBySlope = + Map.fromList [(slopePoint point, point) | point <- NonEmpty.toList points] + hull <- + first RegularTopologySlopeHullInvalid + (convexHullPolygon (fmap slopePoint points)) + visiblePoints <- + traverse + (\point -> + maybe + (Left (RegularTopologySlopeVertexMissing point)) + Right + (Map.lookup point pointsBySlope)) + (NonEmpty.toList (convexPolygonPoints hull)) + let visible = Set.fromList visiblePoints + pure + ( fmap (\fanFace -> (fanFace, dualPoint)) (coplanarFanFaces visiblePoints) + , visible + , Set.difference groupPoints visible + ) + +hullFacePlaneKey + :: HullFace label + -> ExactPoint + -> (ExactRational, ExactRational, ExactRational) +hullFacePlaneKey face dualPoint = + let (dualX, dualY) = exactPointCoordinates dualPoint + generator = liftedPointGenerator (hullFaceFirst face) + support = + exactPowerGeneratorXCoefficient generator * dualX + + exactPowerGeneratorYCoefficient generator * dualY + + exactPowerGeneratorConstant generator + in (dualX, dualY, support) + +upperFaceAssociation + :: HullFace label + -> Either + (RegularTopologyError label) + ( (ExactRational, ExactRational, ExactRational) + , (HullFace label, ExactPoint) + ) +upperFaceAssociation face = do + (_, dualPoint) <- hullFaceDual face + pure (hullFacePlaneKey face dualPoint, (face, dualPoint)) + +coplanarLiftedTopology + :: NonEmpty (LiftedPoint label) + -> Either (RegularTopologyError label) (GeneratorRegularTopology label) +coplanarLiftedTopology points = do + hull <- + first RegularTopologySlopeHullInvalid + (convexHullPolygon (fmap slopePoint points)) + let pointsBySlope = Map.fromList [(slopePoint point, point) | point <- NonEmpty.toList points] + hullPoints <- + traverse + (\point -> maybe (Left (RegularTopologySlopeVertexMissing point)) Right (Map.lookup point pointsBySlope)) + (NonEmpty.toList (convexPolygonPoints hull)) + let visible = Set.fromList hullPoints + lowerDimensional = Set.difference (Set.fromList (NonEmpty.toList points)) visible + hullFaces' = coplanarFanFaces hullPoints + dualFaces <- coplanarFanDualFaces hullFaces' + (faces, edges) <- topologyFromHullFaces dualFaces + pure + ( topologyFromParts + points + visible + lowerDimensional + faces + edges + (length hullFaces') + ) + +coplanarFanDualFaces + :: [HullFace label] + -> Either + (RegularTopologyError label) + [(HullFace label, ExactPoint)] +coplanarFanDualFaces [] = Right [] +coplanarFanDualFaces faces@(firstFace : _) = do + (_, dualPoint) <- hullFaceDual firstFace + pure (fmap (\face -> (face, dualPoint)) faces) + +coplanarFanFaces :: [LiftedPoint label] -> [HullFace label] +coplanarFanFaces (firstPoint : secondPoint : thirdPoint : remaining) = + zipWith + (\identifier (leftPoint, rightPoint) -> + HullFace identifier firstPoint leftPoint rightPoint Set.empty Set.empty) + [0 ..] + (consecutivePairs (secondPoint : thirdPoint : remaining)) +coplanarFanFaces _ = [] + +collinearSlopeTopology + :: NonEmpty (LiftedPoint label) + -> LiftedPoint label + -> LiftedPoint label + -> Either (RegularTopologyError label) (GeneratorRegularTopology label) +collinearSlopeTopology points firstPoint secondPoint = do + let direction = slopeDifference firstPoint secondPoint + ordered = List.sortOn (slopeParameter direction) (NonEmpty.toList points) + visibleList = upperSlopeChain direction ordered + visible = Set.fromList visibleList + lowerDimensional = + Set.difference + (upperChainPointSet direction visibleList ordered) + visible + edges <- traverse fullLineEdge (consecutivePairs visibleList) + pure (topologyFromParts points visible lowerDimensional [] edges 0) + +slopeDifference + :: LiftedPoint label + -> LiftedPoint label + -> (ExactRational, ExactRational) +slopeDifference firstPoint secondPoint = + let (firstX, firstY, _) = liftedCoordinates firstPoint + (secondX, secondY, _) = liftedCoordinates secondPoint + in (secondX - firstX, secondY - firstY) + +slopeParameter + :: (ExactRational, ExactRational) + -> LiftedPoint label + -> ExactRational +slopeParameter (directionX, directionY) point = + let (coordinateX, coordinateY, _) = liftedCoordinates point + in directionX * coordinateX + directionY * coordinateY + +upperSlopeChain + :: (ExactRational, ExactRational) + -> [LiftedPoint label] + -> [LiftedPoint label] +upperSlopeChain direction = reverse . List.foldl' insertUpper [] + where + insertUpper + :: [LiftedPoint label] + -> LiftedPoint label + -> [LiftedPoint label] + insertUpper (secondPoint : firstPoint : remaining) candidate + | slopeChainTurn direction firstPoint secondPoint candidate >= 0 = + insertUpper (firstPoint : remaining) candidate + insertUpper retained candidate = candidate : retained + +slopeChainTurn + :: (ExactRational, ExactRational) + -> LiftedPoint label + -> LiftedPoint label + -> LiftedPoint label + -> ExactRational +slopeChainTurn direction firstPoint secondPoint thirdPoint = + let firstT = slopeParameter direction firstPoint + secondT = slopeParameter direction secondPoint + thirdT = slopeParameter direction thirdPoint + (_, _, firstConstant) = liftedCoordinates firstPoint + (_, _, secondConstant) = liftedCoordinates secondPoint + (_, _, thirdConstant) = liftedCoordinates thirdPoint + in (secondT - firstT) * (thirdConstant - firstConstant) + - (secondConstant - firstConstant) * (thirdT - firstT) + +upperChainPointSet + :: (ExactRational, ExactRational) + -> [LiftedPoint label] + -> [LiftedPoint label] + -> Set (LiftedPoint label) +upperChainPointSet direction chain = + snd + . List.foldl' + classifyPoint + (consecutivePairs chain, Set.empty) + where + classifyPoint + :: ([(LiftedPoint label, LiftedPoint label)], Set (LiftedPoint label)) + -> LiftedPoint label + -> ([(LiftedPoint label, LiftedPoint label)], Set (LiftedPoint label)) + classifyPoint (remainingEdges, members) point = + let pointParameter = slopeParameter direction point + candidateEdges = + List.dropWhile + ((< pointParameter) . slopeParameter direction . snd) + remainingEdges + retainedMembers = + case candidateEdges of + (firstPoint, secondPoint) : _ + | slopeParameter direction firstPoint <= pointParameter + && slopeChainTurn direction firstPoint secondPoint point == 0 -> + Set.insert point members + _ -> members + in (candidateEdges, retainedMembers) + +fullLineEdge + :: (LiftedPoint label, LiftedPoint label) + -> Either (RegularTopologyError label) (GeneratorRegularEdge label) +fullLineEdge (firstPoint, secondPoint) = do + axis <- generatorAxis firstPoint secondPoint + pure (regularEdge firstPoint secondPoint (GeneratorDualLine axis)) + +topologyFromHullFaces + :: [(HullFace label, ExactPoint)] + -> Either + (RegularTopologyError label) + ([GeneratorRegularFace label], [GeneratorRegularEdge label]) +topologyFromHullFaces dualFaces = do + let dualByFace = IntMap.fromList [(hullFaceId face, dual) | (face, dual) <- dualFaces] + edgeIncidence = + List.foldl' + (\incidence (face, _) -> + List.foldl' + (\current (firstPoint, secondPoint, thirdPoint) -> + Map.insertWith + (<>) + (hullEdgeKey firstPoint secondPoint) + ((face, firstPoint, secondPoint, thirdPoint) :| []) + current) + incidence + (faceEdgesWithOpposite face)) + Map.empty + dualFaces + edges <- traverse (dualEdge dualByFace) (Map.elems edgeIncidence) + pure + ( [ GeneratorRegularFace + (pointLabel (hullFaceFirst face)) + (pointLabel (hullFaceSecond face)) + (pointLabel (hullFaceThird face)) + dual + | (face, dual) <- dualFaces + ] + , edges + ) + +hullFaceDual + :: HullFace label + -> Either (RegularTopologyError label) (HullFace label, ExactPoint) +hullFaceDual face = do + let firstPoint = hullFaceFirst face + secondPoint = hullFaceSecond face + thirdPoint = hullFaceThird face + firstAxis <- generatorAxis firstPoint secondPoint + secondAxis <- generatorAxis firstPoint thirdPoint + dual <- + first + ( RegularTopologyDualVertexInvalid + (pointLabel firstPoint) + (pointLabel secondPoint) + (pointLabel thirdPoint) + ) + (exactAffineLineIntersection firstAxis secondAxis) + pure (face, dual) + +faceEdgesWithOpposite + :: HullFace label + -> [(LiftedPoint label, LiftedPoint label, LiftedPoint label)] +faceEdgesWithOpposite face = + [ (hullFaceFirst face, hullFaceSecond face, hullFaceThird face) + , (hullFaceSecond face, hullFaceThird face, hullFaceFirst face) + , (hullFaceThird face, hullFaceFirst face, hullFaceSecond face) + ] + +dualEdge + :: IntMap.IntMap ExactPoint + -> NonEmpty (HullFace label, LiftedPoint label, LiftedPoint label, LiftedPoint label) + -> Either (RegularTopologyError label) (GeneratorRegularEdge label) +dualEdge dualByFace incidences = + case incidences of + (face, firstPoint, secondPoint, thirdPoint) :| [] -> do + dual <- + maybe + (Left (RegularTopologyFlatBoundary (pointLabel firstPoint) (pointLabel secondPoint) (pointLabel thirdPoint))) + Right + (IntMap.lookup (hullFaceId face) dualByFace) + ray <- boundaryDualRay dual firstPoint secondPoint thirdPoint + pure (regularEdge firstPoint secondPoint (GeneratorDualRay ray)) + (firstFace, firstPoint, secondPoint, _) :| [(secondFace, _, _, _)] -> do + firstDual <- requiredDual firstPoint secondPoint firstFace + secondDual <- requiredDual firstPoint secondPoint secondFace + if firstDual == secondDual + then pure (regularEdge firstPoint secondPoint (GeneratorDualCollapsed firstDual)) + else do + segment <- + first + (RegularTopologyDualSegmentInvalid (pointLabel firstPoint) (pointLabel secondPoint)) + (exactSegment firstDual secondDual) + pure (regularEdge firstPoint secondPoint (GeneratorDualSegment segment)) + (_, firstPoint, secondPoint, _) :| _ -> + Left + ( RegularTopologyNonManifoldEdge + (pointLabel firstPoint) + (pointLabel secondPoint) + (NonEmpty.length incidences) + ) + where + requiredDual + :: LiftedPoint label + -> LiftedPoint label + -> HullFace label + -> Either (RegularTopologyError label) ExactPoint + requiredDual firstPoint secondPoint face = + maybe + (Left (RegularTopologyFlatBoundary (pointLabel firstPoint) (pointLabel secondPoint) (pointLabel (hullFaceThird face)))) + Right + (IntMap.lookup (hullFaceId face) dualByFace) + +boundaryDualRay + :: ExactPoint + -> LiftedPoint label + -> LiftedPoint label + -> LiftedPoint label + -> Either (RegularTopologyError label) ExactRay +boundaryDualRay originPoint firstPoint secondPoint thirdPoint = do + axis <- generatorAxis firstPoint secondPoint + let (axisX, axisY, _) = exactAffineLineCoefficients axis + candidate = ExactVector axisY (negate axisX) + firstGenerator = liftedPointGenerator firstPoint + thirdGenerator = liftedPointGenerator thirdPoint + advantageX = + exactPowerGeneratorXCoefficient firstGenerator + - exactPowerGeneratorXCoefficient thirdGenerator + advantageY = + exactPowerGeneratorYCoefficient firstGenerator + - exactPowerGeneratorYCoefficient thirdGenerator + ExactVector candidateX candidateY = candidate + derivative = advantageX * candidateX + advantageY * candidateY + direction = + if derivative > 0 + then candidate + else ExactVector (negate candidateX) (negate candidateY) + if derivative == 0 + then + Left + ( RegularTopologyFlatBoundary + (pointLabel firstPoint) + (pointLabel secondPoint) + (pointLabel thirdPoint) + ) + else + first + (RegularTopologyDualRayInvalid (pointLabel firstPoint) (pointLabel secondPoint)) + (exactRay originPoint direction) + +generatorAxis + :: LiftedPoint label + -> LiftedPoint label + -> Either (RegularTopologyError label) ExactAffineLine +generatorAxis firstPoint secondPoint = + first + (RegularTopologyAxisInvalid (pointLabel firstPoint) (pointLabel secondPoint)) + (exactGeneratorAxis (liftedPointGenerator firstPoint) (liftedPointGenerator secondPoint)) + +regularEdge + :: LiftedPoint label + -> LiftedPoint label + -> GeneratorDualGeometry + -> GeneratorRegularEdge label +regularEdge firstPoint secondPoint dual = + if liftedPointId firstPoint <= liftedPointId secondPoint + then GeneratorRegularEdge (liftedPointGenerator firstPoint) (liftedPointGenerator secondPoint) dual + else GeneratorRegularEdge (liftedPointGenerator secondPoint) (liftedPointGenerator firstPoint) dual + +pointLabel :: LiftedPoint label -> label +pointLabel = exactPowerGeneratorLabel . liftedPointGenerator + +topologyFromParts + :: NonEmpty (LiftedPoint label) + -> Set (LiftedPoint label) + -> Set (LiftedPoint label) + -> [GeneratorRegularFace label] + -> [GeneratorRegularEdge label] + -> Int + -> GeneratorRegularTopology label +topologyFromParts points visible lowerDimensional faces edges peakFaces = + let dispositions = + fmap + (\point -> + ( liftedPointGenerator point + , if Set.member point visible + then RegularGeneratorVisible + else + if Set.member point lowerDimensional + then RegularGeneratorLowerDimensional + else RegularGeneratorHidden + )) + points + visibleCount = Set.size visible + lowerCount = Set.size lowerDimensional + inputCount = NonEmpty.length points + in GeneratorRegularTopology + { generatorRegularDispositions = dispositions + , generatorRegularFaces = faces + , generatorRegularEdges = edges + , generatorRegularReceipt = + GeneratorRegularReceipt + { generatorRegularInputSites = inputCount + , generatorRegularVisibleSites = visibleCount + , generatorRegularLowerDimensionalSites = lowerCount + , generatorRegularHiddenSites = inputCount - visibleCount - lowerCount + , generatorRegularFaceCount = length faces + , generatorRegularEdgeCount = length edges + , generatorRegularPeakHullFaces = peakFaces + } + } diff --git a/src-public/Moonlight/Triangulation/Minkowski.hs b/src-public/Moonlight/Triangulation/Minkowski.hs --- a/src-public/Moonlight/Triangulation/Minkowski.hs +++ b/src-public/Moonlight/Triangulation/Minkowski.hs @@ -15,6 +15,7 @@ , MinkowskiError (..) , MinkowskiReceipt (..) , convexMinkowskiSum + , reflectConvexPolygon , minkowskiSum , erodeBy , openWith @@ -41,6 +42,7 @@ ) import Moonlight.Triangulation.Exact ( ExactPoint + , exactClipExactIntersections , exactPointCoordinates ) import Moonlight.Triangulation.Internal.HandleDefs @@ -48,12 +50,9 @@ ) import Moonlight.Triangulation.Handles.Iterators.FixedIterators (innerFaces) import Moonlight.Triangulation.Internal.ExactRational - ( ExactRational - , exactRationalDenominator - , exactRationalNumerator + ( exactRationalBitWidth ) import Moonlight.Triangulation.Internal.BoundaryCycle (cyclePairs) -import Moonlight.Triangulation.Internal.Dyadic (integerBitLength) import Moonlight.Triangulation.Internal.Minkowski.Convex ( addExactPoints , admittedConvexLoop @@ -324,7 +323,8 @@ -> ConvexPolygon -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) convexErosion element source sourcePolygon = do - eroded <- erodeConvexBy sourcePolygon (structuringElementPolygon element) + (eroded, clipReceipt) <- + erodeConvexBy sourcePolygon (structuringElementPolygon element) let result = maybe emptyPlanarRegion convexPolygonRegion eroded outputCells = maybe 0 (const 1) eroded generatedEdges = maybe 0 (NonEmpty.length . convexPolygonPoints) eroded @@ -337,7 +337,8 @@ , minkowskiGeneratedPieces = outputCells , minkowskiGeneratedConvolutionEdges = generatedEdges , minkowskiOverlayPasses = 0 - , minkowskiExactCrossings = 0 + , minkowskiExactCrossings = + exactClipExactIntersections clipReceipt , minkowskiOutputCells = outputCells , minkowskiExactCoordinateBitGrowth = coordinateBitGrowth @@ -586,10 +587,6 @@ List.foldl' pointBits maximumBits . exactLoopPoints pointBits maximumBits point = let (x, y) = exactPointCoordinates point - in max maximumBits (max (rationalBits x) (rationalBits y)) - -rationalBits :: ExactRational -> Int -rationalBits value = - max - (integerBitLength (abs (exactRationalNumerator value))) - (integerBitLength (exactRationalDenominator value)) + in max + maximumBits + (max (exactRationalBitWidth x) (exactRationalBitWidth y)) diff --git a/src-public/Moonlight/Triangulation/Overlay.hs b/src-public/Moonlight/Triangulation/Overlay.hs --- a/src-public/Moonlight/Triangulation/Overlay.hs +++ b/src-public/Moonlight/Triangulation/Overlay.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} -- | Exact labelled common refinement. Source boundaries descend through one @@ -38,7 +40,11 @@ , OverlayResult , OverlaySelectionKind (..) , OverlaySelectionError (..) + , CoverGap + , coverGapRegion + , LayerCoverageError (..) , overlayLayers + , overlayAll , overlayEmbeddedTriangulation , overlayReceipt , overlayCells @@ -46,18 +52,28 @@ , overlayArrangementEdges , overlayPlanarLayer , overlaySelectedRegion + , overlayMass + , overlayConfusion + , layerCovers , overlayClosedUnion , overlayClosedIntersection , overlayRegularizedDifference ) where +import Control.DeepSeq (NFData) import Data.Bifunctor (first) import Control.Monad (filterM) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as Map import qualified Data.Vector as V -import Moonlight.Triangulation.CellSet (ExactCellSet) +import GHC.Generics (Generic) +import Moonlight.Triangulation.CellSet + ( CellSelectionError + , ExactCellSet + ) import qualified Moonlight.Triangulation.Dcel as Dcel import Moonlight.Triangulation.Dcel (vertexData) +import Moonlight.Triangulation.Exact (ExactPoint) import Moonlight.Triangulation.Internal.HandleDefs ( UndirectedEdgeId , VertexId @@ -85,19 +101,45 @@ import Moonlight.Triangulation.Internal.Types ( ConstraintMode (Constrained) ) +import Moonlight.Triangulation.Internal.Tournament + ( interpretTournament + , planTournament + ) import Moonlight.Triangulation.Region ( PlanarLayer , PlanarRegion + , PolygonComponent , RegionPublicationError (..) , emptyPlanarRegion , planarLayerOutsideLabel , planarLayerRegions + , planarRegionComponents ) import Moonlight.Triangulation.Internal.Region.Publication ( labelledPlanarLayerFromExactCoordinates , planarLayerFromAdmittedComponents ) +import Moonlight.Triangulation.Valuation + ( ExactArea + , polygonComponentArea + ) +-- | Exact full-dimensional part of a requested window not owned by any +-- bounded label region in the candidate layer. +newtype CoverGap = CoverGap PlanarRegion + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +coverGapRegion :: CoverGap -> PlanarRegion +coverGapRegion (CoverGap region) = region + +data LayerCoverageError label + = LayerCoverageOverlayFailed !(OverlayError Bool label) + | LayerCoverageGapPublicationFailed !RegionPublicationError + | LayerCoverageGap !CoverGap + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + -- | Construct the exact common refinement and its one faithful resident DCEL. overlayLayers :: (Ord leftLabel, Ord rightLabel) @@ -113,6 +155,65 @@ (planarLayerOutsideLabel leftLayer, planarLayerOutsideLabel rightLayer) certified +-- | Construct the common refinement of a nonempty family in input order. +-- Adjacent layers glue in a balanced tree, so an early boundary participates +-- in logarithmically many intermediate arrangements rather than every later +-- left-associated step. Each intermediate layer is projected directly from +-- its certified binary result. +overlayAll + :: Ord label + => NonEmpty (PlanarLayer label) + -> Either + (OverlayError (NonEmpty label) (NonEmpty label)) + (PlanarLayer (NonEmpty label)) +overlayAll = + interpretTournament overlayLayerPair + . planTournament + . fmap singletonLabelLayer + +overlayLayerPair + :: Ord label + => PlanarLayer (NonEmpty label) + -> PlanarLayer (NonEmpty label) + -> Either + (OverlayError (NonEmpty label) (NonEmpty label)) + (PlanarLayer (NonEmpty label)) +overlayLayerPair leftLayer rightLayer = + flattenNaryOverlay <$> overlayLayers leftLayer rightLayer + +singletonLabelLayer :: Ord label => PlanarLayer label -> PlanarLayer (NonEmpty label) +singletonLabelLayer layer = + planarLayerFromAdmittedComponents + (planarLayerOutsideLabel layer :| []) + [ (label :| [], component) + | (label, region) <- Map.toAscList (planarLayerRegions layer) + , component <- planarRegionComponents region + ] + +flattenNaryOverlay + :: Ord label + => OverlayResult (NonEmpty label) (NonEmpty label) + -> PlanarLayer (NonEmpty label) +flattenNaryOverlay = projectOverlayLayerWith (uncurry (<>)) + +projectOverlayLayerWith + :: (Eq leftLabel, Eq rightLabel, Ord projectedLabel) + => ((leftLabel, rightLabel) -> projectedLabel) + -> OverlayResult leftLabel rightLabel + -> PlanarLayer projectedLabel +projectOverlayLayerWith projectLabel result = + planarLayerFromAdmittedComponents + (projectLabel (overlayResultOutsideLabels result)) + [ (projectLabel (overlayCellLabels cell), component) + | cell <- V.toList (overlayResultCells result) + , overlayCellLabels cell /= overlayResultOutsideLabels result + , BoundedOverlayCell component <- [overlayCellGeometry cell] + ] + +overlayCellLabels :: OverlayCell leftLabel rightLabel -> (leftLabel, rightLabel) +overlayCellLabels cell = (overlayCellLeft cell, overlayCellRight cell) +{-# INLINE overlayCellLabels #-} + -- | The binary64 realization used by existing DCEL observations. Exact overlay -- operations accept 'OverlayResult', never this projection. overlayEmbeddedTriangulation @@ -158,17 +259,7 @@ :: (Ord leftLabel, Ord rightLabel) => OverlayResult leftLabel rightLabel -> PlanarLayer (leftLabel, rightLabel) -overlayPlanarLayer result = - planarLayerFromAdmittedComponents - (overlayResultOutsideLabels result) - [ ( (overlayCellLeft cell, overlayCellRight cell) - , component - ) - | cell <- V.toList (overlayResultCells result) - , (overlayCellLeft cell, overlayCellRight cell) - /= overlayResultOutsideLabels result - , BoundedOverlayCell component <- [overlayCellGeometry cell] - ] +overlayPlanarLayer = projectOverlayLayerWith id -- | Publish the selected two-dimensional cells. Internal arrangement edges -- between differently labelled but jointly selected cells dissolve because @@ -188,13 +279,92 @@ labelFace pure (Map.findWithDefault emptyPlanarRegion True (planarLayerRegions published)) where - triangulation = overlayResultTriangulation result - exactPointAt vertex = Right (overlayExactPoint (vertexData triangulation vertex)) - labelFace face - | faceCarriesExactArea result face = - selected <$> regionFaceLabels result face - | otherwise = Right False + triangulation = overlayResultTriangulation result + exactPointAt :: VertexId -> Either RegionPublicationError ExactPoint + exactPointAt vertex = Right (overlayExactPoint (vertexData triangulation vertex)) + labelFace face + | faceCarriesExactArea result face = + selected <$> regionFaceLabels result face + | otherwise = Right False +-- | Sum selected exact bounded cells without publishing a polygonal union or +-- computing its perimeter. Selecting the unbounded outside pair is refused by +-- the same obstruction used by 'overlaySelectedRegion'. +overlayMass + :: ((leftLabel, rightLabel) -> Bool) + -> OverlayResult leftLabel rightLabel + -> Either RegionPublicationError ExactArea +overlayMass selected result + | selected (overlayResultOutsideLabels result) = Left RegionUnboundedSelection + | otherwise = + Right (foldBoundedOverlayCells selectedCellArea mempty result) + where + selectedCellArea area labels component + | selected labels = area <> polygonComponentArea component + | otherwise = area + +-- | Exact finite confusion masses, grouped by label pair in one traversal. +-- The outside pair is absent because its complete planar cell is unbounded; +-- bounded cavities carrying that same pair are not misreported as its total. +overlayConfusion + :: (Ord leftLabel, Ord rightLabel) + => OverlayResult leftLabel rightLabel + -> Map.Map (leftLabel, rightLabel) ExactArea +overlayConfusion result = + foldBoundedOverlayCells accumulateCell Map.empty result + where + outsideLabels = overlayResultOutsideLabels result + accumulateCell masses labels component + | labels == outsideLabels = masses + | otherwise = Map.insertWith (<>) labels (polygonComponentArea component) masses + +foldBoundedOverlayCells + :: (accumulator -> (leftLabel, rightLabel) -> PolygonComponent -> accumulator) + -> accumulator + -> OverlayResult leftLabel rightLabel + -> accumulator +foldBoundedOverlayCells accumulate initial result = + V.foldl' descend initial (overlayResultCells result) + where + descend accumulator cell = + case overlayCellGeometry cell of + BoundedOverlayCell component -> + accumulate accumulator (overlayCellLabels cell) component + UnboundedOverlayCell _ -> accumulator +{-# INLINE foldBoundedOverlayCells #-} + +-- | Certify full-dimensional coverage of an admitted polygonal window. The +-- success path inspects certified cells only; an exact gap region is glued +-- solely when the obstruction actually exists. +layerCovers + :: Ord label + => PlanarLayer label + -> PolygonComponent + -> Either (LayerCoverageError label) () +layerCovers layer window = do + let outside = planarLayerOutsideLabel layer + windowLayer = planarLayerFromAdmittedComponents False [(True, window)] + result <- first LayerCoverageOverlayFailed (overlayLayers windowLayer layer) + if V.any (isGapCell outside) (overlayResultCells result) + then do + gap <- + first LayerCoverageGapPublicationFailed + ( overlaySelectedRegion + (\(insideWindow, label) -> + insideWindow && label == outside) + result + ) + Left (LayerCoverageGap (CoverGap gap)) + else Right () + +isGapCell :: Eq label => label -> OverlayCell Bool label -> Bool +isGapCell outside cell = + overlayCellLeft cell + && overlayCellRight cell == outside + && case overlayCellGeometry cell of + BoundedOverlayCell _ -> True + UnboundedOverlayCell _ -> False + overlayClosedUnion :: (Ord leftLabel, Ord rightLabel) => (leftLabel -> Bool) @@ -270,6 +440,7 @@ -> Either OverlaySelectionError ExactCellSet closeSelectedCells selectedVertices selectedEdges selectFace result = let triangulation = overlayResultTriangulation result + exactPointAt :: VertexId -> Either CellSelectionError ExactPoint exactPointAt vertex = Right (overlayExactPoint (vertexData triangulation vertex)) in do selectedFaces <- diff --git a/src-public/Moonlight/Triangulation/PowerDiagram.hs b/src-public/Moonlight/Triangulation/PowerDiagram.hs new file mode 100644 --- /dev/null +++ b/src-public/Moonlight/Triangulation/PowerDiagram.hs @@ -0,0 +1,955 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Exact regular topology and power cells. Labelled cell dispositions are +-- authoritative; regular topology and planar layers are derived views. +module Moonlight.Triangulation.PowerDiagram + ( 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 + ) where + +import Control.DeepSeq (NFData) +import Data.Bifunctor (first) +import qualified Data.Foldable as Foldable +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import Data.Ord (comparing) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Vector as Vector +import GHC.Generics (Generic) +import Moonlight.Triangulation.Exact + ( ExactClipDisposition (..) + , ExactClipError + , ExactClipReceipt (..) + , ExactAffineLine + , ExactClosedHalfPlane + , ExactHalfPlaneError + , ExactPoint + , ExactRay + , ExactRetainedPolygon + , ExactSegment + , exactClipRetainedPolygon + , exactClosedHalfPlane + , exactPointCoordinates + , exactPointBitWidth + , exactPointFromQueryPoint + , exactRetainedPolygon + , oppositeExactAffineLine + ) +import Moonlight.Triangulation.Internal.ExactRational + ( ExactRational + , exactRationalBitWidth + , exactRationalFromFiniteDouble + ) +import Moonlight.Triangulation.Internal.BoundaryCycle + ( consecutivePairs ) +import Moonlight.Triangulation.Internal.RegularTriangulation + ( DistinctSlopeGenerators (..) + , ExactPowerGenerator (..) + , GeneratorDualGeometry (..) + , GeneratorRegularEdge (..) + , GeneratorRegularFace (..) + , GeneratorRegularReceipt (..) + , GeneratorRegularTopology (..) + , RegularGeneratorDisposition (..) + , RegularTopologyError (..) + , exactGeneratorAxis + , regularGeneratorTopology + ) +import Moonlight.Triangulation.Internal.Minkowski.Convex + ( convexHullPolygon + , convexPolygonComponent + , convexPolygonFromRetained + ) +import Moonlight.Triangulation.Internal.Overlay.Types + ( OverlayCell (..) + , OverlayCellGeometry (..) + , OverlayError + , OverlayResult (..) + ) +import Moonlight.Triangulation.Internal.Region.Publication + ( planarLayerFromAdmittedComponents + ) +import Moonlight.Triangulation.Math (mkQueryPoint) +import Moonlight.Triangulation.Minkowski + ( ConvexPolygon + , MinkowskiError + , convexPolygonPoints + ) +import Moonlight.Triangulation.Overlay + ( overlayLayers ) +import Moonlight.Triangulation.Region + ( PlanarLayer + , PolygonComponent + , exactLoopPoints + , polygonOuterLoop + ) +import Moonlight.Triangulation.Types + ( NonFiniteValue + , Point + , PointValidationError + , QueryPoint + , classifyNonFinite + , queryPointValue + ) + +-- | An admitted signed additive power offset. Power distance is +-- @||x-p||^2-w@, so negative values are lawful and this is deliberately not a +-- squared-radius refinement. +newtype PowerWeight = PowerWeight ExactRational + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | The sole obstruction to admitting a signed binary64 power offset. +data PowerWeightError + = PowerWeightNonFinite !NonFiniteValue + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Admit a finite binary64 power offset exactly. +powerWeight :: Double -> Either PowerWeightError PowerWeight +powerWeight value = + case classifyNonFinite value of + Just obstruction -> Left (PowerWeightNonFinite obstruction) + Nothing -> Right (PowerWeight (exactRationalFromFiniteDouble value)) + +-- | Exact rational value of an admitted power offset. +powerWeightExact :: PowerWeight -> ExactRational +powerWeightExact (PowerWeight value) = value + +-- | One labelled, admitted weighted site. Construction validates and +-- canonicalizes the binary64 position once. +data PowerSite label = PowerSite + { powerSiteLabel :: !label + , powerSiteQueryPoint :: !QueryPoint + , powerSiteWeight :: !PowerWeight + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +powerSite + :: label + -> Point + -> PowerWeight + -> Either (PowerDiagramError label) (PowerSite label) +powerSite label point weight = + PowerSite label <$> first (PowerSitePositionInvalid label) (mkQueryPoint point) <*> pure weight + +powerSitePosition :: PowerSite label -> Point +powerSitePosition = queryPointValue . powerSiteQueryPoint + +-- | Exactly one authoritative result for each submitted label. +data PowerCellDisposition label + = PublishedPowerCell !ConvexPolygon + | LowerDimensionalPowerCell !(NonEmpty ExactPoint) + | EmptyPowerCell + | CoincidentEquivalentTo !label + | CoincidentDominatedBy !label + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Visibility of one submitted label in the exact regular subdivision. +data RegularSiteDisposition label + = RegularSiteVisible + | RegularSiteLowerDimensional + | RegularSiteHidden + | RegularSiteCoincidentEquivalentTo !label + | RegularSiteCoincidentDominatedBy !label + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | One oriented regular face and its exact weighted-dual vertex. +data RegularFace label = RegularFace !label !label !label !ExactPoint + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +regularFaceLabels :: RegularFace label -> (label, label, label) +regularFaceLabels (RegularFace firstLabel secondLabel thirdLabel _) = + (firstLabel, secondLabel, thirdLabel) + +regularFaceDualPoint :: RegularFace label -> ExactPoint +regularFaceDualPoint (RegularFace _ _ _ dualPoint) = dualPoint + +-- | Exact weighted Voronoi geometry dual to one regular edge. +data PowerDualEdge + = BoundedPowerDual !ExactSegment + | UnboundedPowerDual !ExactRay + | FullLinePowerDual !ExactAffineLine + | CollapsedPowerDual !ExactPoint + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | One unordered regular edge and its exact dual geometry. +data RegularEdge label = RegularEdge !label !label !PowerDualEdge + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +regularEdgeLabels :: RegularEdge label -> (label, label) +regularEdgeLabels (RegularEdge firstLabel secondLabel _) = + (firstLabel, secondLabel) + +regularEdgeDual :: RegularEdge label -> PowerDualEdge +regularEdgeDual (RegularEdge _ _ dual) = dual + +-- | Exact regular subdivision, opaque so incidence and visibility cannot +-- disagree. +data RegularTriangulation label = RegularTriangulation + { storedRegularDispositions :: !(Map label (RegularSiteDisposition label)) + , storedRegularFaces :: ![RegularFace label] + , storedRegularEdges :: ![RegularEdge label] + , storedRegularNeighbours :: !(Map label (Set label)) + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +data RegularTriangulationReceipt = RegularTriangulationReceipt + { regularTriangulationInputSites :: !Int + , regularTriangulationRepresentativeSites :: !Int + , regularTriangulationVisibleSites :: !Int + , regularTriangulationLowerDimensionalSites :: !Int + , regularTriangulationHiddenSites :: !Int + , regularTriangulationCoincidentSites :: !Int + , regularTriangulationFaces :: !Int + , regularTriangulationEdges :: !Int + , regularTriangulationPeakHullFaces :: !Int + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Total labelled result, opaque so callers cannot omit a submitted label. +newtype BoundedPowerDiagram label = + BoundedPowerDiagram (Map label (PowerCellDisposition label)) + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +data PowerDiagramError label + = PowerSitePositionInvalid !label !PointValidationError + | DuplicatePowerSiteLabel !label + | PowerDomainInvalid !ExactHalfPlaneError + | PowerBisectorInvalid !label !label !ExactHalfPlaneError + | PowerRegularTopologyFailed !(RegularTopologyError label) + | PowerCellClipFailed !label !ExactClipError + | PowerDiagramOutsideLabelCollides !label + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +data PowerDiagramReceipt = PowerDiagramReceipt + { powerDiagramDomainVertices :: !Int + , powerDiagramSubmittedSiteConstraints :: !Int + , powerDiagramActiveBoundaries :: !Int + , powerDiagramBoundaryCompatibilityChecks :: !Int + , powerDiagramExactIntersections :: !Int + , powerDiagramPublishedCells :: !Int + , powerDiagramLowerDimensionalCells :: !Int + , powerDiagramEmptyCells :: !Int + , powerDiagramCoincidentEquivalentCells :: !Int + , powerDiagramCoincidentDominatedCells :: !Int + , powerDiagramRegularFaces :: !Int + , powerDiagramRegularEdges :: !Int + , powerDiagramOracleCells :: !Int + , powerDiagramMaximumCellConstraints :: !Int + , powerDiagramMaximumInputBits :: !Int + , powerDiagramMaximumAffineCoefficientBits :: !Int + , powerDiagramPeakIntermediateCoordinateBits :: !Int + , powerDiagramFinalCoordinateBits :: !Int + , powerDiagramFinalDenominatorBits :: !Int + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Submitted sites, derived from the exhaustive disposition partition. +powerDiagramInputSites :: PowerDiagramReceipt -> Int +powerDiagramInputSites receipt = + powerDiagramPublishedCells receipt + + powerDiagramLowerDimensionalCells receipt + + powerDiagramEmptyCells receipt + + powerDiagramCoincidentEquivalentCells receipt + + powerDiagramCoincidentDominatedCells receipt +{-# INLINE powerDiagramInputSites #-} + +-- | Peak exact-coordinate width beyond the widest admitted input. +powerDiagramPeakIntermediateBitGrowth :: PowerDiagramReceipt -> Int +powerDiagramPeakIntermediateBitGrowth receipt = + max + 0 + ( powerDiagramPeakIntermediateCoordinateBits receipt + - powerDiagramMaximumInputBits receipt + ) +{-# INLINE powerDiagramPeakIntermediateBitGrowth #-} + +-- | Published coordinate width beyond the widest admitted input. +powerDiagramFinalCoordinateBitGrowth :: PowerDiagramReceipt -> Int +powerDiagramFinalCoordinateBitGrowth receipt = + max + 0 + ( powerDiagramFinalCoordinateBits receipt + - powerDiagramMaximumInputBits receipt + ) +{-# INLINE powerDiagramFinalCoordinateBitGrowth #-} + +-- | One exact affine form @c0 + cx*x + cy*y@. +data AffineForm = AffineForm + { affineFormConstant :: !ExactRational + , affineFormXCoefficient :: !ExactRational + , affineFormYCoefficient :: !ExactRational + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Typed obstructions from exact affine argmax decomposition. Power-cell +-- construction remains the canonical geometric owner; window restriction is +-- the only additional boundary. +data UpperEnvelopeError label + = UpperEnvelopeEmptyForms + | UpperEnvelopeWindowHullFailed !MinkowskiError + | UpperEnvelopePowerConstructionFailed !(PowerDiagramError label) + | UpperEnvelopeWindowOverlayFailed !(OverlayError (Maybe label) Bool) + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | Construct the exact regular subdivision before any bounded clipping. +regularTriangulation + :: Ord label + => NonEmpty (PowerSite label) + -> Either + (PowerDiagramError label) + (RegularTriangulation label, RegularTriangulationReceipt) +regularTriangulation submitted = do + sortedSites <- validateAndSortSites submitted + let generators = fmap (fst . prepareExactPowerGenerator) sortedSites + section <- resolvedGeneratorSection generators + pure (publishRegularSection section) + +regularSiteDisposition + :: Ord label + => label + -> RegularTriangulation label + -> Maybe (RegularSiteDisposition label) +regularSiteDisposition label = Map.lookup label . storedRegularDispositions + +regularFaces :: RegularTriangulation label -> [RegularFace label] +regularFaces = storedRegularFaces + +regularEdges :: RegularTriangulation label -> [RegularEdge label] +regularEdges = storedRegularEdges + +regularNeighbours + :: Ord label + => label + -> RegularTriangulation label + -> Set label +regularNeighbours label = + Map.findWithDefault Set.empty label . storedRegularNeighbours + +boundedPowerDiagram + :: Ord label + => ConvexPolygon + -> NonEmpty (PowerSite label) + -> Either (PowerDiagramError label) (BoundedPowerDiagram label, PowerDiagramReceipt) +boundedPowerDiagram domain submitted = do + sortedSites <- validateAndSortSites submitted + let preparedGenerators = fmap prepareExactPowerGenerator sortedSites + generators = fmap fst preparedGenerators + siteInputBits = + Foldable.foldl' (\bits preparation -> max bits (snd preparation)) 0 preparedGenerators + (dispositions, clipReceipt, regularReceipt, maximumCellConstraints) <- + exactGeneratorDispositionsWith (<>) mempty domain generators + let receipt = + aggregateReceipt + domain + dispositions + siteInputBits + clipReceipt + regularReceipt + maximumCellConstraints + pure (BoundedPowerDiagram dispositions, receipt) + +-- | Full-dimensional labelled argmax regions for affine forms +-- @c0 + cx*x + cy*y@ inside an admitted polygonal window. The result is a +-- planar projection: lower-dimensional and empty winners intentionally have +-- no region. Use 'regularTriangulation' on corresponding weighted sites when +-- those dispositions or exact unbounded duals are required. Identical forms +-- choose the least label, independent of map construction order. +upperEnvelope + :: Ord label + => PolygonComponent + -> Map label AffineForm + -> Either (UpperEnvelopeError label) (PlanarLayer (Maybe label)) +upperEnvelope window forms = do + generators <- affineFormGenerators forms + domain <- + first UpperEnvelopeWindowHullFailed + (convexHullPolygon (exactLoopPoints (polygonOuterLoop window))) + (dispositions, _, _, _) <- + first UpperEnvelopePowerConstructionFailed + (exactGeneratorDispositionsWith discardClipReceipt () domain generators) + let envelopeLayer = affineDispositionLayer dispositions + if convexPolygonComponent domain == window + then Right envelopeLayer + else restrictEnvelopeToWindow window envelopeLayer + +powerCellDisposition + :: Ord label + => label + -> BoundedPowerDiagram label + -> Maybe (PowerCellDisposition label) +powerCellDisposition label (BoundedPowerDiagram dispositions) = + Map.lookup label dispositions + +powerCellDispositions + :: BoundedPowerDiagram label + -> [(label, PowerCellDisposition label)] +powerCellDispositions (BoundedPowerDiagram dispositions) = Map.toAscList dispositions + +-- | Publish only full-dimensional cells. The outside label is a caller-owned +-- view choice and may not collide with any submitted site label. +powerDiagramPlanarLayer + :: Ord label + => label + -> BoundedPowerDiagram label + -> Either (PowerDiagramError label) (PlanarLayer label) +powerDiagramPlanarLayer outside (BoundedPowerDiagram dispositions) + | Map.member outside dispositions = Left (PowerDiagramOutsideLabelCollides outside) + | otherwise = + Right (publishedPowerLayer outside id dispositions) + +affineDispositionLayer + :: Ord label + => Map label (PowerCellDisposition label) + -> PlanarLayer (Maybe label) +affineDispositionLayer = publishedPowerLayer Nothing Just + +publishedPowerLayer + :: Ord publishedLabel + => publishedLabel + -> (label -> publishedLabel) + -> Map label (PowerCellDisposition label) + -> PlanarLayer publishedLabel +publishedPowerLayer outside publishLabel dispositions = + planarLayerFromAdmittedComponents + outside + [ (publishLabel label, convexPolygonComponent polygon) + | (label, PublishedPowerCell polygon) <- Map.toAscList dispositions + ] + +restrictEnvelopeToWindow + :: Ord label + => PolygonComponent + -> PlanarLayer (Maybe label) + -> Either (UpperEnvelopeError label) (PlanarLayer (Maybe label)) +restrictEnvelopeToWindow window envelopeLayer = do + let windowLayer = planarLayerFromAdmittedComponents False [(True, window)] + clipped <- + first UpperEnvelopeWindowOverlayFailed + (overlayLayers envelopeLayer windowLayer) + pure + ( planarLayerFromAdmittedComponents + Nothing + [ (Just label, component) + | cell <- Vector.toList (overlayResultCells clipped) + , overlayCellRight cell + , Just label <- [overlayCellLeft cell] + , BoundedOverlayCell component <- [overlayCellGeometry cell] + ] + ) + +validateAndSortSites + :: Ord label + => NonEmpty (PowerSite label) + -> Either (PowerDiagramError label) (NonEmpty (PowerSite label)) +validateAndSortSites submitted = + let sorted = NonEmpty.sortBy (comparing powerSiteLabel) submitted + in case List.find (uncurry sameLabel) (consecutivePairs (NonEmpty.toList sorted)) of + Just (duplicate, _) -> Left (DuplicatePowerSiteLabel (powerSiteLabel duplicate)) + Nothing -> Right sorted + where + sameLabel :: Eq label => PowerSite label -> PowerSite label -> Bool + sameLabel left right = powerSiteLabel left == powerSiteLabel right + +prepareExactPowerGenerator :: PowerSite label -> (ExactPowerGenerator label, Int) +prepareExactPowerGenerator site = + let point = exactPointFromQueryPoint (powerSiteQueryPoint site) + (coordinateX, coordinateY) = exactPointCoordinates point + weight = powerWeightExact (powerSiteWeight site) + in ( ExactPowerGenerator + { exactPowerGeneratorLabel = powerSiteLabel site + , exactPowerGeneratorXCoefficient = 2 * coordinateX + , exactPowerGeneratorYCoefficient = 2 * coordinateY + , exactPowerGeneratorConstant = + weight - coordinateX * coordinateX - coordinateY * coordinateY + } + , max (exactPointBitWidth point) (exactRationalBitWidth weight) + ) + +affineFormGenerators + :: Map label AffineForm + -> Either (UpperEnvelopeError label) (NonEmpty (ExactPowerGenerator label)) +affineFormGenerators forms = + case Map.minViewWithKey forms of + Nothing -> Left UpperEnvelopeEmptyForms + Just ((firstLabel, firstForm), remaining) -> + Right + ( affineFormGenerator firstLabel firstForm + :| fmap (uncurry affineFormGenerator) (Map.toAscList remaining) + ) + +affineFormGenerator + :: label + -> AffineForm + -> ExactPowerGenerator label +affineFormGenerator label form = + ExactPowerGenerator + { exactPowerGeneratorLabel = label + , exactPowerGeneratorXCoefficient = affineFormXCoefficient form + , exactPowerGeneratorYCoefficient = affineFormYCoefficient form + , exactPowerGeneratorConstant = affineFormConstant form + } + +exactGeneratorDispositionsWith + :: Ord label + => (summary -> ExactClipReceipt -> summary) + -> summary + -> ConvexPolygon + -> NonEmpty (ExactPowerGenerator label) + -> Either + (PowerDiagramError label) + ( Map label (PowerCellDisposition label) + , summary + , GeneratorRegularReceipt + , Int + ) +exactGeneratorDispositionsWith summarizeReceipt initialSummary domain generators = do + retainedDomain <- + first PowerDomainInvalid (exactRetainedPolygon (convexPolygonPoints domain)) + section <- resolvedGeneratorSection generators + let topology = resolvedRegularTopology section + constraints <- prepareRegularConstraintSection topology + clipped <- + traverse + (clipPowerCell retainedDomain section constraints) + (generatorRegularDispositions topology) + let (publishedAssociations, summary, maximumCellConstraints) = + Foldable.foldl' + (\(associations, accumulatedSummary, peak) (label, disposition, cellReceipt, cellAxes) -> + let !combinedSummary = summarizeReceipt accumulatedSummary cellReceipt + in ( (label, disposition) : associations + , combinedSummary + , max peak cellAxes + )) + ([], initialSummary, 0) + clipped + publishedDispositions = Map.fromList publishedAssociations + dispositions = + fmap coincidentPowerDisposition (resolvedCoincidentDispositions section) + <> publishedDispositions + pure + ( dispositions + , summary + , generatorRegularReceipt topology + , maximumCellConstraints + ) + +discardClipReceipt :: () -> ExactClipReceipt -> () +discardClipReceipt _ _ = () + +groupGeneratorsBySlope + :: NonEmpty (ExactPowerGenerator label) + -> NonEmpty (NonEmpty (ExactPowerGenerator label)) +groupGeneratorsBySlope (initial :| remaining) = + let initialSlope = exactGeneratorSlope initial + (sameInitialSlope, otherGenerators) = + List.partition ((== initialSlope) . exactGeneratorSlope) remaining + otherGroups = + Map.fromListWith + (<>) + [ (exactGeneratorSlope generator, generator :| []) + | generator <- otherGenerators + ] + in (initial :| sameInitialSlope) :| Map.elems otherGroups + +exactGeneratorSlope + :: ExactPowerGenerator label + -> (ExactRational, ExactRational) +exactGeneratorSlope generator = + ( exactPowerGeneratorXCoefficient generator + , exactPowerGeneratorYCoefficient generator + ) + +resolveCoincidentGeneratorGroup + :: Ord label + => NonEmpty (ExactPowerGenerator label) + -> (ExactPowerGenerator label, [(label, CoincidentGeneratorDisposition label)]) +resolveCoincidentGeneratorGroup generators@(initial :| remaining) = + let representative = List.foldl' chooseRepresentative initial remaining + representativeLabel = exactPowerGeneratorLabel representative + in ( representative + , [ ( exactPowerGeneratorLabel generator + , classifyCoincidentGenerator representative generator + ) + | generator <- NonEmpty.toList generators + , exactPowerGeneratorLabel generator /= representativeLabel + ] + ) + where + chooseRepresentative + :: Ord label + => ExactPowerGenerator label + -> ExactPowerGenerator label + -> ExactPowerGenerator label + chooseRepresentative selected candidate = + case compare + (exactPowerGeneratorConstant candidate) + (exactPowerGeneratorConstant selected) of + GT -> candidate + LT -> selected + EQ -> + if exactPowerGeneratorLabel candidate < exactPowerGeneratorLabel selected + then candidate + else selected + +classifyCoincidentGenerator + :: ExactPowerGenerator label + -> ExactPowerGenerator label + -> CoincidentGeneratorDisposition label +classifyCoincidentGenerator representative candidate + | exactPowerGeneratorConstant candidate == exactPowerGeneratorConstant representative = + CoincidentGeneratorEquivalentTo (exactPowerGeneratorLabel representative) + | otherwise = CoincidentGeneratorDominatedBy (exactPowerGeneratorLabel representative) + +data CoincidentGeneratorDisposition label + = CoincidentGeneratorEquivalentTo !label + | CoincidentGeneratorDominatedBy !label + +coincidentPowerDisposition + :: CoincidentGeneratorDisposition label + -> PowerCellDisposition label +coincidentPowerDisposition disposition = + case disposition of + CoincidentGeneratorEquivalentTo label -> CoincidentEquivalentTo label + CoincidentGeneratorDominatedBy label -> CoincidentDominatedBy label + +coincidentRegularDisposition + :: CoincidentGeneratorDisposition label + -> RegularSiteDisposition label +coincidentRegularDisposition disposition = + case disposition of + CoincidentGeneratorEquivalentTo label -> RegularSiteCoincidentEquivalentTo label + CoincidentGeneratorDominatedBy label -> RegularSiteCoincidentDominatedBy label + +data ResolvedGeneratorSection label = ResolvedGeneratorSection + { resolvedCoincidentDispositions :: !(Map label (CoincidentGeneratorDisposition label)) + , resolvedRegularTopology :: !(GeneratorRegularTopology label) + } + +resolvedGeneratorSection + :: Ord label + => NonEmpty (ExactPowerGenerator label) + -> Either (PowerDiagramError label) (ResolvedGeneratorSection label) +resolvedGeneratorSection generators = do + let resolvedGroups = fmap resolveCoincidentGeneratorGroup (groupGeneratorsBySlope generators) + representatives = fmap fst resolvedGroups + coincidentDispositions = + Map.fromList (concatMap snd (NonEmpty.toList resolvedGroups)) + topology <- + first PowerRegularTopologyFailed + (regularGeneratorTopology (DistinctSlopeGenerators representatives)) + pure + ResolvedGeneratorSection + { resolvedCoincidentDispositions = coincidentDispositions + , resolvedRegularTopology = topology + } + +publishRegularSection + :: Ord label + => ResolvedGeneratorSection label + -> (RegularTriangulation label, RegularTriangulationReceipt) +publishRegularSection section = + let topology = resolvedRegularTopology section + coincident = resolvedCoincidentDispositions section + dispositions = + Map.fromList + [ ( exactPowerGeneratorLabel generator + , publishGeneratorDisposition disposition + ) + | (generator, disposition) <- + NonEmpty.toList (generatorRegularDispositions topology) + ] + <> fmap coincidentRegularDisposition coincident + faces = fmap publishGeneratorFace (generatorRegularFaces topology) + edges = fmap publishGeneratorEdge (generatorRegularEdges topology) + generatorReceipt = generatorRegularReceipt topology + coincidentCount = Map.size coincident + in ( RegularTriangulation + { storedRegularDispositions = dispositions + , storedRegularFaces = faces + , storedRegularEdges = edges + , storedRegularNeighbours = regularNeighbourSection topology + } + , RegularTriangulationReceipt + { regularTriangulationInputSites = + generatorRegularInputSites generatorReceipt + coincidentCount + , regularTriangulationRepresentativeSites = + generatorRegularInputSites generatorReceipt + , regularTriangulationVisibleSites = + generatorRegularVisibleSites generatorReceipt + , regularTriangulationLowerDimensionalSites = + generatorRegularLowerDimensionalSites generatorReceipt + , regularTriangulationHiddenSites = + generatorRegularHiddenSites generatorReceipt + , regularTriangulationCoincidentSites = coincidentCount + , regularTriangulationFaces = generatorRegularFaceCount generatorReceipt + , regularTriangulationEdges = generatorRegularEdgeCount generatorReceipt + , regularTriangulationPeakHullFaces = + generatorRegularPeakHullFaces generatorReceipt + } + ) + +publishGeneratorDisposition + :: RegularGeneratorDisposition + -> RegularSiteDisposition label +publishGeneratorDisposition disposition = + case disposition of + RegularGeneratorVisible -> RegularSiteVisible + RegularGeneratorLowerDimensional -> RegularSiteLowerDimensional + RegularGeneratorHidden -> RegularSiteHidden + +publishGeneratorFace :: GeneratorRegularFace label -> RegularFace label +publishGeneratorFace face = + RegularFace + (generatorRegularFaceFirst face) + (generatorRegularFaceSecond face) + (generatorRegularFaceThird face) + (generatorRegularFaceDualPoint face) + +publishGeneratorEdge :: GeneratorRegularEdge label -> RegularEdge label +publishGeneratorEdge edge = + RegularEdge + (exactPowerGeneratorLabel (generatorRegularEdgeFirst edge)) + (exactPowerGeneratorLabel (generatorRegularEdgeSecond edge)) + (case generatorRegularEdgeDual edge of + GeneratorDualSegment segment -> BoundedPowerDual segment + GeneratorDualRay ray -> UnboundedPowerDual ray + GeneratorDualLine line -> FullLinePowerDual line + GeneratorDualCollapsed point -> CollapsedPowerDual point) + +regularNeighbourSection + :: Ord label + => GeneratorRegularTopology label + -> Map label (Set label) +regularNeighbourSection = + List.foldl' insertRegularNeighbourEdge Map.empty . generatorRegularEdges + +insertRegularNeighbourEdge + :: Ord label + => Map label (Set label) + -> GeneratorRegularEdge label + -> Map label (Set label) +insertRegularNeighbourEdge neighbours edge = + let firstLabel = exactPowerGeneratorLabel (generatorRegularEdgeFirst edge) + secondLabel = exactPowerGeneratorLabel (generatorRegularEdgeSecond edge) + in Map.insertWith Set.union firstLabel (Set.singleton secondLabel) + (Map.insertWith Set.union secondLabel (Set.singleton firstLabel) neighbours) + +prepareRadicalAxis + :: ExactPowerGenerator label + -> ExactPowerGenerator label + -> Either (PowerDiagramError label) ExactAffineLine +prepareRadicalAxis firstGenerator secondGenerator = + first + ( PowerBisectorInvalid + (exactPowerGeneratorLabel firstGenerator) + (exactPowerGeneratorLabel secondGenerator) + ) + (exactGeneratorAxis firstGenerator secondGenerator) + +prepareRegularConstraintSection + :: Ord label + => GeneratorRegularTopology label + -> Either (PowerDiagramError label) (Map label [ExactClosedHalfPlane]) +prepareRegularConstraintSection = + Foldable.foldlM prepareRegularConstraintEdge Map.empty . generatorRegularEdges + +prepareRegularConstraintEdge + :: Ord label + => Map label [ExactClosedHalfPlane] + -> GeneratorRegularEdge label + -> Either (PowerDiagramError label) (Map label [ExactClosedHalfPlane]) +prepareRegularConstraintEdge constraints edge = do + let firstGenerator = generatorRegularEdgeFirst edge + secondGenerator = generatorRegularEdgeSecond edge + firstLabel = exactPowerGeneratorLabel firstGenerator + secondLabel = exactPowerGeneratorLabel secondGenerator + axis <- prepareRadicalAxis firstGenerator secondGenerator + pure + ( Map.insertWith (<>) secondLabel [exactClosedHalfPlane (oppositeExactAffineLine axis)] + (Map.insertWith (<>) firstLabel [exactClosedHalfPlane axis] constraints) + ) + +clipPowerCell + :: Ord label + => ExactRetainedPolygon + -> ResolvedGeneratorSection label + -> Map label [ExactClosedHalfPlane] + -> (ExactPowerGenerator label, RegularGeneratorDisposition) + -> Either + (PowerDiagramError label) + (label, PowerCellDisposition label, ExactClipReceipt, Int) +clipPowerCell retainedDomain section constraints (ownerGenerator, disposition) = + let ownerLabel = exactPowerGeneratorLabel ownerGenerator + topology = resolvedRegularTopology section + in case disposition of + RegularGeneratorHidden -> + pure (ownerLabel, EmptyPowerCell, mempty, 0) + RegularGeneratorVisible -> + finishPowerCell + retainedDomain + ownerGenerator + (Map.findWithDefault [] ownerLabel constraints) + RegularGeneratorLowerDimensional -> do + let competitors = + [ generator + | (generator, _) <- + NonEmpty.toList (generatorRegularDispositions topology) + , exactPowerGeneratorLabel generator /= ownerLabel + ] + halfPlanes <- traverse (preparedDirectHalfPlane ownerGenerator) competitors + finishPowerCell retainedDomain ownerGenerator halfPlanes + +preparedDirectHalfPlane + :: ExactPowerGenerator label + -> ExactPowerGenerator label + -> Either (PowerDiagramError label) ExactClosedHalfPlane +preparedDirectHalfPlane owner competitor = + exactClosedHalfPlane <$> prepareRadicalAxis owner competitor + +finishPowerCell + :: ExactRetainedPolygon + -> ExactPowerGenerator label + -> [ExactClosedHalfPlane] + -> Either + (PowerDiagramError label) + (label, PowerCellDisposition label, ExactClipReceipt, Int) +finishPowerCell retainedDomain ownerGenerator halfPlanes = do + (exactDisposition, receipt) <- + first (PowerCellClipFailed (exactPowerGeneratorLabel ownerGenerator)) + (exactClipRetainedPolygon retainedDomain halfPlanes) + pure + ( exactPowerGeneratorLabel ownerGenerator + , case exactDisposition of + ExactClipFullDimensional retained -> + PublishedPowerCell (convexPolygonFromRetained retained) + ExactClipLowerDimensional points -> LowerDimensionalPowerCell points + ExactClipEmpty -> EmptyPowerCell + , receipt + , length halfPlanes + ) + +aggregateReceipt + :: ConvexPolygon + -> Map label (PowerCellDisposition label) + -> Int + -> ExactClipReceipt + -> GeneratorRegularReceipt + -> Int + -> PowerDiagramReceipt +aggregateReceipt domain dispositions siteInputBits clipReceipt regularReceipt maximumCellConstraints = + let inputBits = max siteInputBits (exactClipInputCoordinateBits clipReceipt) + peakBits = exactClipPeakIntermediateCoordinateBits clipReceipt + finalBits = exactClipFinalCoordinateBits clipReceipt + dispositionCounts = countPowerDispositions dispositions + in PowerDiagramReceipt + { powerDiagramDomainVertices = NonEmpty.length (convexPolygonPoints domain) + , powerDiagramSubmittedSiteConstraints = exactClipSubmittedHalfPlanes clipReceipt + , powerDiagramActiveBoundaries = exactClipActiveBoundaries clipReceipt + , powerDiagramBoundaryCompatibilityChecks = exactClipBoundaryCompatibilityChecks clipReceipt + , powerDiagramExactIntersections = exactClipExactIntersections clipReceipt + , powerDiagramPublishedCells = countedPublishedCells dispositionCounts + , powerDiagramLowerDimensionalCells = countedLowerDimensionalCells dispositionCounts + , powerDiagramEmptyCells = countedEmptyCells dispositionCounts + , powerDiagramCoincidentEquivalentCells = countedCoincidentEquivalentCells dispositionCounts + , powerDiagramCoincidentDominatedCells = countedCoincidentDominatedCells dispositionCounts + , powerDiagramRegularFaces = generatorRegularFaceCount regularReceipt + , powerDiagramRegularEdges = generatorRegularEdgeCount regularReceipt + , powerDiagramOracleCells = generatorRegularLowerDimensionalSites regularReceipt + , powerDiagramMaximumCellConstraints = maximumCellConstraints + , powerDiagramMaximumInputBits = inputBits + , powerDiagramMaximumAffineCoefficientBits = exactClipMaximumAffineCoefficientBits clipReceipt + , powerDiagramPeakIntermediateCoordinateBits = peakBits + , powerDiagramFinalCoordinateBits = finalBits + , powerDiagramFinalDenominatorBits = exactClipFinalDenominatorBits clipReceipt + } + +data PowerDispositionCounts = PowerDispositionCounts + { countedPublishedCells :: !Int + , countedLowerDimensionalCells :: !Int + , countedEmptyCells :: !Int + , countedCoincidentEquivalentCells :: !Int + , countedCoincidentDominatedCells :: !Int + } + +countPowerDispositions + :: Map label (PowerCellDisposition label) + -> PowerDispositionCounts +countPowerDispositions = + Map.foldl' + (\counts disposition -> case disposition of + PublishedPowerCell _ -> + counts {countedPublishedCells = countedPublishedCells counts + 1} + LowerDimensionalPowerCell _ -> + counts {countedLowerDimensionalCells = countedLowerDimensionalCells counts + 1} + EmptyPowerCell -> + counts {countedEmptyCells = countedEmptyCells counts + 1} + CoincidentEquivalentTo _ -> + counts {countedCoincidentEquivalentCells = countedCoincidentEquivalentCells counts + 1} + CoincidentDominatedBy _ -> + counts {countedCoincidentDominatedCells = countedCoincidentDominatedCells counts + 1}) + PowerDispositionCounts + { countedPublishedCells = 0 + , countedLowerDimensionalCells = 0 + , countedEmptyCells = 0 + , countedCoincidentEquivalentCells = 0 + , countedCoincidentDominatedCells = 0 + } diff --git a/test/algebra/Main.hs b/test/algebra/Main.hs --- a/test/algebra/Main.hs +++ b/test/algebra/Main.hs @@ -1,7 +1,6 @@ module Main (main) where import qualified Moonlight.Triangulation.AlgebraSpec as AlgebraSpec -import qualified Moonlight.Triangulation.MinkowskiSpec as MinkowskiSpec import qualified Moonlight.Triangulation.RegionAlgebraSpec as RegionAlgebraSpec import qualified Moonlight.Triangulation.ScheduleAgreementSpec as ScheduleAgreementSpec import qualified Moonlight.Triangulation.ValuationSpec as ValuationSpec @@ -11,5 +10,4 @@ AlgebraSpec.tests RegionAlgebraSpec.tests ValuationSpec.tests - MinkowskiSpec.tests ScheduleAgreementSpec.tests diff --git a/test/algebra/Moonlight/Triangulation/ExactClipRetentionSpec.hs b/test/algebra/Moonlight/Triangulation/ExactClipRetentionSpec.hs new file mode 100644 --- /dev/null +++ b/test/algebra/Moonlight/Triangulation/ExactClipRetentionSpec.hs @@ -0,0 +1,536 @@ +-- | Independent endpoint-reconstruction oracle for the retained-line clipper. +-- +-- The oracle is deliberately test-only. Production has one clipping authority: +-- 'exactClipRetainedPolygon'. +module Moonlight.Triangulation.ExactClipRetentionSpec (tests) where + +import Control.Monad (foldM, unless) +import Data.Foldable (traverse_) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (maybeToList) +import Moonlight.Triangulation.Exact + ( ExactAffineLine + , ExactClipDisposition (..) + , ExactClipReceipt (..) + , ExactClosedHalfPlane + , ExactHalfPlaneError (..) + , ExactIntersectionError + , ExactPoint + , ExactRetainedPolygon + , SegmentRelation (..) + , classifyExactPoint + , exactAffineLine + , exactAffineLineCoefficients + , exactAffineLineIntersection + , exactClipRetainedPolygon + , exactClosedHalfPlane + , exactClosedHalfPlaneFromDirectedEdge + , exactClosedHalfPlaneLine + , exactOrient2d + , exactPoint + , exactPointCoordinates + , exactRetainedPolygon + , exactRetainedPolygonPoints + ) +import Moonlight.Triangulation.Internal.BoundaryCycle + ( cyclePairsNonEmpty + , cyclicTriples + ) +import Moonlight.Triangulation.Internal.ExactRational + ( ExactRational + , exactRational + , exactRationalBitWidth + , exactRationalDenominatorBitWidth + ) +import Support (assertEqual, integerPoint, requireRight) + +tests :: IO () +tests = do + testAffineIntersectionCrossProducts + testSelfIntersectingAllLeftCycleRefused + testRetainedClosingLineSurvivesSecondClip + testAngularHalfPlanePermutation + testClosedDimensionalDispositions + initialPolygon <- + requireRight + "retained-line fixture polygon" + ( exactRetainedPolygon + ( integerPoint (-1000) (-1000) + :| [ integerPoint 1000 (-1000) + , integerPoint 1000 1000 + , integerPoint (-1000) 1000 + ] + ) + ) + halfPlanes <- traverse fixtureHalfPlane fixtureCoefficients + (retainedDisposition, retainedReceipt) <- + requireRight + "retained-line fixture clipping" + (exactClipRetainedPolygon initialPolygon halfPlanes) + retainedPoints <- + case retainedDisposition of + ExactClipFullDimensional polygon -> pure (exactRetainedPolygonPoints polygon) + other -> fail ("retained-line fixture lost full dimension: " <> show other) + (endpointPoints, endpointReceipt) <- + requireRight + "endpoint-reconstruction oracle" + (endpointClipSequence (exactRetainedPolygonPoints initialPolygon) halfPlanes) + + assertExactPointSet "final exact polygon" retainedPoints endpointPoints + assertEqual + "final reduced denominator width is representation invariant" + (exactClipFinalDenominatorBits retainedReceipt) + (endpointFinalDenominatorBits endpointReceipt) + assertEqual "measured retained coefficient width" 21 (exactClipMaximumAffineCoefficientBits retainedReceipt) + assertEqual "measured endpoint coefficient width" 32 (endpointPeakAffineCoefficientBits endpointReceipt) + unless + ( endpointPeakAffineCoefficientBits endpointReceipt + > exactClipMaximumAffineCoefficientBits retainedReceipt + ) + ( fail + "endpoint reconstruction did not exhibit strictly larger affine coefficients" + ) + + -- Equality is checked at every local section, not merely after global gluing. + -- This is the reason no honest coordinate-width counterexample can exist. + traverse_ + (assertPrefixAgreement initialPolygon) + (List.inits halfPlanes) + putStrLn "exact retained-line clipping: ok (source coefficients 21 bits; endpoint oracle 32 bits)" + +testAffineIntersectionCrossProducts :: IO () +testAffineIntersectionCrossProducts = do + oneHalf <- rationalCoefficient 1 2 + oneThird <- rationalCoefficient 1 3 + twoFifths <- rationalCoefficient 2 5 + negativeOneSeventh <- rationalCoefficient (-1) 7 + negativeOne <- rationalCoefficient (-1) 1 + oneEleventh <- rationalCoefficient 1 11 + firstLine <- + requireRight + "first rational intersection line" + (exactAffineLine oneHalf oneThird negativeOne) + secondLine <- + requireRight + "second rational intersection line" + (exactAffineLine twoFifths negativeOneSeventh oneEleventh) + intersection <- + requireRight + "homogeneous integer affine intersection" + (exactAffineLineIntersection firstLine secondLine) + expectedX <- requireRight "expected rational x" (exactRational 260 473) + expectedY <- requireRight "expected rational y" (exactRational 1029 473) + assertEqual + "homogeneous integer intersection agrees with rational Cramer's rule" + (exactPoint expectedX expectedY) + intersection + assertEqual + "intersection remains on the first source line" + EQ + (classifyExactPoint (exactClosedHalfPlane firstLine) intersection) + assertEqual + "intersection remains on the second source line" + EQ + (classifyExactPoint (exactClosedHalfPlane secondLine) intersection) + where + rationalCoefficient :: Integer -> Integer -> IO ExactRational + rationalCoefficient numerator denominator = + requireRight + "rational intersection coefficient" + (exactRational numerator denominator) + +testAngularHalfPlanePermutation :: IO () +testAngularHalfPlanePermutation = do + square <- retainedSquare + halfPlanes <- + traverse + fixtureHalfPlane + [ (1, 0, -2) + , (2, 0, -4) + , (-1, 0, 8) + , (0, 1, -1) + , (0, -1, 9) + ] + (expected, expectedReceipt) <- + requireRight + "angular half-plane canonical result" + (exactClipRetainedPolygon square halfPlanes) + case expected of + ExactClipFullDimensional polygon -> + assertExactPointSet + "parallel descent retains the strongest boundaries" + ( integerPoint 2 1 + :| [integerPoint 8 1, integerPoint 8 9, integerPoint 2 9] + ) + (exactRetainedPolygonPoints polygon) + other -> fail ("expected a full-dimensional canonical section, got " <> show other) + traverse_ + (\permutation -> do + (actual, receipt) <- + requireRight + "permuted angular half-plane intersection" + (exactClipRetainedPolygon square permutation) + assertEqual "angular half-plane permutation" expected actual + assertEqual + "submitted half-plane count" + (length halfPlanes) + (exactClipSubmittedHalfPlanes receipt)) + (List.permutations halfPlanes) + unless (exactClipBoundaryCompatibilityChecks expectedReceipt > 0) $ + fail "angular descent reported no boundary compatibility work" + +testClosedDimensionalDispositions :: IO () +testClosedDimensionalDispositions = do + square <- retainedSquare + xAtOne <- traverse fixtureHalfPlane [(1, 0, -1), (-1, 0, 1)] + (segmentDisposition, _) <- + requireRight + "closed segment half-plane intersection" + (exactClipRetainedPolygon square xAtOne) + case segmentDisposition of + ExactClipLowerDimensional points -> + assertEqual + "opposing closed half-planes retain their shared segment" + (List.sort [integerPoint 1 0, integerPoint 1 10]) + (List.sort (NonEmpty.toList points)) + other -> fail ("expected a closed segment, got " <> show other) + + yAtThree <- traverse fixtureHalfPlane [(0, 1, -3), (0, -1, 3)] + (pointDisposition, _) <- + requireRight + "closed point half-plane intersection" + (exactClipRetainedPolygon square (xAtOne <> yAtThree)) + case pointDisposition of + ExactClipLowerDimensional points -> + assertEqual + "two zero-width closed sections retain their shared point" + [integerPoint 1 3] + (List.sort (NonEmpty.toList points)) + other -> fail ("expected a closed point, got " <> show other) + + incompatible <- traverse fixtureHalfPlane [(1, 0, -6), (-1, 0, 5)] + (emptyDisposition, _) <- + requireRight + "incompatible closed half-plane intersection" + (exactClipRetainedPolygon square incompatible) + assertEqual "separated opposing boundaries are empty" ExactClipEmpty emptyDisposition + +retainedSquare :: IO ExactRetainedPolygon +retainedSquare = + requireRight + "retained square" + ( exactRetainedPolygon + ( integerPoint 0 0 + :| [integerPoint 10 0, integerPoint 10 10, integerPoint 0 10] + ) + ) + +testSelfIntersectingAllLeftCycleRefused :: IO () +testSelfIntersectingAllLeftCycleRefused = do + let points = + integerPoint 0 0 + :| [ integerPoint 5 3 + , integerPoint (-1) 3 + , integerPoint 4 0 + , integerPoint 2 5 + ] + turns = + fmap + (\(previous, current, next) -> exactOrient2d previous current next) + (cyclicTriples (NonEmpty.toList points)) + assertEqual "self-intersection fixture has only local left turns" (replicate 5 GT) turns + case exactRetainedPolygon points of + Left (ExactRetainedPolygonSelfRelation 0 2 SegmentsProperlyCross) -> pure () + other -> + fail + ( "self-intersecting all-left retained polygon: expected edge 0/2 crossing, got " + <> show other + ) + +-- The first clip emits its first point twice. The closing occurrence carries +-- the source line of the retained bottom edge; preserving the opening record +-- instead corrupts that edge into the square's stale right boundary and makes +-- the second clip spuriously report parallel lines. +testRetainedClosingLineSurvivesSecondClip :: IO () +testRetainedClosingLineSurvivesSecondClip = do + square <- + requireRight + "retained square" + ( exactRetainedPolygon + ( integerPoint 0 0 + :| [ integerPoint 10 0 + , integerPoint 10 10 + , integerPoint 0 10 + ] + ) + ) + diagonalLine <- requireRight "diagonal clipping line" (exactAffineLine (-1) (-1) 10) + verticalLine <- requireRight "vertical clipping line" (exactAffineLine (-1) 0 5) + let diagonalHalfPlane = exactClosedHalfPlane diagonalLine + verticalHalfPlane = exactClosedHalfPlane verticalLine + retainedHalfPlanes = diagonalHalfPlane :| [verticalHalfPlane] + (diagonalDisposition, _) <- + requireRight + "retained square diagonal clip" + (exactClipRetainedPolygon square [diagonalHalfPlane]) + diagonalPolygon <- + requireFullDimensionalClip + "retained square diagonal clip" + diagonalDisposition + assertExactPointSet + "first clip retains the expected triangle" + (integerPoint 0 0 :| [integerPoint 10 0, integerPoint 0 10]) + (exactRetainedPolygonPoints diagonalPolygon) + (sequentialDisposition, _) <- + requireRight + "second clip over the retained first result" + (exactClipRetainedPolygon diagonalPolygon [verticalHalfPlane]) + sequentialPolygon <- + requireFullDimensionalClip + "second clip over the retained first result" + sequentialDisposition + (combinedDisposition, combinedReceipt) <- + requireRight + "combined retained two-clip descent" + (exactClipRetainedPolygon square (NonEmpty.toList retainedHalfPlanes)) + combinedPolygon <- + requireFullDimensionalClip + "combined retained two-clip descent" + combinedDisposition + let expectedFinalPoints = + integerPoint 0 0 + :| [integerPoint 5 0, integerPoint 5 5, integerPoint 0 10] + assertExactPointSet + "second clip intersects the retained bottom and diagonal source lines" + expectedFinalPoints + (exactRetainedPolygonPoints sequentialPolygon) + assertEqual + "sequential and combined clipping preserve the same retained polygon" + sequentialPolygon + combinedPolygon + assertEqual + "combined clipping records both submitted half-planes" + 2 + (exactClipSubmittedHalfPlanes combinedReceipt) + assertRetainedVerticesInside + retainedHalfPlanes + (exactRetainedPolygonPoints combinedPolygon) + +requireFullDimensionalClip + :: String + -> ExactClipDisposition + -> IO ExactRetainedPolygon +requireFullDimensionalClip _ (ExactClipFullDimensional polygon) = pure polygon +requireFullDimensionalClip label disposition = + fail (label <> ": expected a full-dimensional polygon, got " <> show disposition) + +assertExactPointSet + :: String + -> NonEmpty ExactPoint + -> NonEmpty ExactPoint + -> IO () +assertExactPointSet label expected actual = + assertEqual + label + (List.sort (NonEmpty.toList expected)) + (List.sort (NonEmpty.toList actual)) + +assertRetainedVerticesInside + :: NonEmpty ExactClosedHalfPlane + -> NonEmpty ExactPoint + -> IO () +assertRetainedVerticesInside halfPlanes points = + traverse_ + (\halfPlane -> + traverse_ + (\point -> + unless (classifyExactPoint halfPlane point /= LT) $ + fail ("retained vertex violates clipping half-plane: " <> show point)) + points) + halfPlanes + +data EndpointOracleError + = EndpointOracleHalfPlane !ExactHalfPlaneError + | EndpointOracleIntersection !ExactIntersectionError + | EndpointOracleLostFullDimension ![ExactPoint] + deriving stock (Eq, Show) + +data EndpointOracleReceipt = EndpointOracleReceipt + { endpointPeakAffineCoefficientBits :: !Int + , endpointPeakCoordinateBits :: !Int + , endpointFinalDenominatorBits :: !Int + } + deriving stock (Eq, Show) + +data EndpointEdgeClip = EndpointEdgeClip + { endpointEdgePoints :: ![ExactPoint] + , endpointEdgeReconstructedCoefficientBits :: !(Maybe Int) + } + deriving stock (Eq, Show) + +endpointClipSequence + :: NonEmpty ExactPoint + -> [ExactClosedHalfPlane] + -> Either EndpointOracleError (NonEmpty ExactPoint, EndpointOracleReceipt) +endpointClipSequence initialPoints halfPlanes = do + let initialReceipt = + EndpointOracleReceipt + { endpointPeakAffineCoefficientBits = 0 + , endpointPeakCoordinateBits = pointCycleBitWidth initialPoints + , endpointFinalDenominatorBits = pointCycleDenominatorBitWidth initialPoints + } + (finalPoints, accumulatedReceipt) <- + foldM endpointClipStep (initialPoints, initialReceipt) halfPlanes + pure + ( finalPoints + , accumulatedReceipt + { endpointFinalDenominatorBits = + pointCycleDenominatorBitWidth finalPoints + } + ) + +endpointClipStep + :: (NonEmpty ExactPoint, EndpointOracleReceipt) + -> ExactClosedHalfPlane + -> Either EndpointOracleError (NonEmpty ExactPoint, EndpointOracleReceipt) +endpointClipStep (points, receipt) halfPlane = do + clippedEdges <- + traverse (clipEndpointEdge halfPlane) (cyclePairsNonEmpty points) + let clippedPoints = concatMap endpointEdgePoints clippedEdges + stepCoefficientBits = + maximumOrZero + ( foldMap + (maybeToList . endpointEdgeReconstructedCoefficientBits) + clippedEdges + ) + nextPoints <- + maybe + (Left (EndpointOracleLostFullDimension clippedPoints)) + Right + (NonEmpty.nonEmpty clippedPoints) + if NonEmpty.length nextPoints < 3 + then Left (EndpointOracleLostFullDimension clippedPoints) + else + Right + ( nextPoints + , receipt + { endpointPeakAffineCoefficientBits = + max + (endpointPeakAffineCoefficientBits receipt) + stepCoefficientBits + , endpointPeakCoordinateBits = + max + (endpointPeakCoordinateBits receipt) + (pointCycleBitWidth nextPoints) + } + ) + +clipEndpointEdge + :: ExactClosedHalfPlane + -> (ExactPoint, ExactPoint) + -> Either EndpointOracleError EndpointEdgeClip +clipEndpointEdge halfPlane (from, to) = + let fromInside = classifyExactPoint halfPlane from /= LT + toInside = classifyExactPoint halfPlane to /= LT + crossing = do + reconstructedBoundary <- + either + (Left . EndpointOracleHalfPlane) + (Right . exactClosedHalfPlaneLine) + (exactClosedHalfPlaneFromDirectedEdge from to) + point <- + either + (Left . EndpointOracleIntersection) + Right + ( exactAffineLineIntersection + reconstructedBoundary + (exactClosedHalfPlaneLine halfPlane) + ) + pure (point, affineLineBitWidth reconstructedBoundary) + in case (fromInside, toInside) of + (True, True) -> Right (EndpointEdgeClip [to] Nothing) + (True, False) -> + (\(point, coefficientBits) -> + EndpointEdgeClip [point] (Just coefficientBits)) + <$> crossing + (False, True) -> + (\(point, coefficientBits) -> + EndpointEdgeClip [point, to] (Just coefficientBits)) + <$> crossing + (False, False) -> Right (EndpointEdgeClip [] Nothing) + +assertPrefixAgreement + :: ExactRetainedPolygon + -> [ExactClosedHalfPlane] + -> IO () +assertPrefixAgreement initialPolygon prefix = do + (retainedDisposition, retainedReceipt) <- + requireRight + "retained-line prefix" + (exactClipRetainedPolygon initialPolygon prefix) + retainedPoints <- + case retainedDisposition of + ExactClipFullDimensional polygon -> pure (exactRetainedPolygonPoints polygon) + other -> fail ("retained-line prefix lost full dimension: " <> show other) + (endpointPoints, endpointReceipt) <- + requireRight + "endpoint prefix" + (endpointClipSequence (exactRetainedPolygonPoints initialPolygon) prefix) + assertExactPointSet "prefix exact polygon" retainedPoints endpointPoints + assertEqual + "prefix denominator width" + (exactClipFinalDenominatorBits retainedReceipt) + (endpointFinalDenominatorBits endpointReceipt) + +fixtureHalfPlane + :: (Integer, Integer, Integer) + -> IO ExactClosedHalfPlane +fixtureHalfPlane (coefficientX, coefficientY, constant) = + exactClosedHalfPlane + <$> requireRight + "fixture affine half-plane" + ( exactAffineLine + (fromInteger coefficientX) + (fromInteger coefficientY) + (fromInteger constant) + ) + +fixtureCoefficients :: [(Integer, Integer, Integer)] +fixtureCoefficients = + [ (1, 2, 1300) + , (-3, 5, 1700) + , (-7, -2, 1900) + , (4, -9, 2200) + , (11, 3, 1800) + , (-5, 13, 2100) + , (-17, -4, 2300) + , (6, -19, 2400) + , (23, 7, 2500) + , (-8, 29, 2600) + ] + +affineLineBitWidth :: ExactAffineLine -> Int +affineLineBitWidth line = + let (coefficientX, coefficientY, constant) = exactAffineLineCoefficients line + in maximumOrZero (fmap exactRationalBitWidth [coefficientX, coefficientY, constant]) + +pointCycleBitWidth :: NonEmpty ExactPoint -> Int +pointCycleBitWidth = + maximumOrZero + . concatMap + (\point -> + let (x, y) = exactPointCoordinates point + in fmap exactRationalBitWidth [x, y]) + +pointCycleDenominatorBitWidth :: NonEmpty ExactPoint -> Int +pointCycleDenominatorBitWidth = + maximumOrZero + . concatMap + (\point -> + let (x, y) = exactPointCoordinates point + in fmap exactRationalDenominatorBitWidth [x, y]) + +maximumOrZero :: Foldable collection => collection Int -> Int +maximumOrZero = List.foldl' max 0 diff --git a/test/algebra/Moonlight/Triangulation/LayerOperationsSpec.hs b/test/algebra/Moonlight/Triangulation/LayerOperationsSpec.hs new file mode 100644 --- /dev/null +++ b/test/algebra/Moonlight/Triangulation/LayerOperationsSpec.hs @@ -0,0 +1,275 @@ +-- | Exact affine-envelope and compositional layer laws through the public +-- facade. Every comparison is against an independently composed public view. +module Moonlight.Triangulation.LayerOperationsSpec (tests) where + +import Control.Monad (unless) +import Data.Foldable (traverse_) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import Moonlight.Triangulation + ( AffineForm (..) + , CoverGap + , ExactPoint + , ExactRational + , LayerCoverageError (..) + , PlanarLayer + , PlanarRegion + , PolygonComponent + , RegionPublicationError (RegionUnboundedSelection) + , UpperEnvelopeError (UpperEnvelopeEmptyForms) + , coverGapRegion + , exactAreaValue + , exactLoop + , exactLoopPoints + , exactPoint + , exactPointCoordinates + , layerCovers + , overlayAll + , overlayConfusion + , overlayLayers + , overlayMass + , overlaySelectedRegion + , planarLayer + , planarLayerLabelAt + , planarLayerRegions + , planarRegion + , planarRegionComponents + , polygonComponent + , polygonHoleLoops + , polygonOuterLoop + , regionValuations + , upperEnvelope + , valuationArea + ) +import Moonlight.Triangulation.AlgebraFixtures + ( insideLayer + , rectangleComponent + , rectangleRegion + ) +import Support (assertEqual, integerPoint, requireRight) + +tests :: IO () +tests = do + testConvexUpperEnvelope + testNonconvexAndHoledUpperEnvelope + testEmptyUpperEnvelope + testLayerCoverage + testNaryOverlayLabels + testOverlayMassAndConfusion + putStrLn "layer operations: ok" + +testConvexUpperEnvelope :: IO () +testConvexUpperEnvelope = do + window <- rectangleComponent 0 0 10 10 + let forms = + Map.fromList + [ (0 :: Int, AffineForm 0 (-1) 0) + , (1, AffineForm 0 (-1) 0) + , (2, AffineForm (-10) 1 0) + , (3, AffineForm (-11) 1 0) + ] + layer <- requireRight "convex exact upper envelope" (upperEnvelope window forms) + reordered <- + requireRight + "upper envelope is independent of map construction order" + (upperEnvelope window (Map.fromList (reverse (Map.toList forms)))) + assertEqual "upper envelope map-order invariance" layer reordered + assertEqual "identical and dominated forms own no cell" [Just 0, Just 2] (Map.keys (planarLayerRegions layer)) + assertEnvelopeDominance forms layer + assertEqual "left affine winner" (Just 0) (planarLayerLabelAt layer (exactPoint 2 5)) + assertEqual "right affine winner" (Just 2) (planarLayerLabelAt layer (exactPoint 8 5)) + assertEqual "outside finite window" Nothing (planarLayerLabelAt layer (exactPoint (-1) 5)) + requireCoverage "upper envelope covers its convex window" layer window + +testNonconvexAndHoledUpperEnvelope :: IO () +testNonconvexAndHoledUpperEnvelope = do + nonconvex <- lShapedComponent + holed <- holedComponent + let constantForm = Map.singleton (7 :: Int) (AffineForm 1 0 0) + assertEnvelopeEqualsWindow "nonconvex envelope restriction" nonconvex constantForm + assertEnvelopeEqualsWindow "holed envelope restriction" holed constantForm + +testEmptyUpperEnvelope :: IO () +testEmptyUpperEnvelope = do + window <- rectangleComponent 0 0 1 1 + case upperEnvelope window (Map.empty :: Map.Map Int AffineForm) of + Left UpperEnvelopeEmptyForms -> pure () + result -> fail ("empty upper envelope: unexpected result " <> show result) + +testLayerCoverage :: IO () +testLayerCoverage = do + window <- rectangleComponent 0 0 10 10 + half <- rectangleRegion 0 0 5 10 + incomplete <- insideLayer half + case layerCovers incomplete window of + Left (LayerCoverageGap gap) -> assertGapArea 50 gap + result -> fail ("incomplete layer coverage: unexpected result " <> show result) + completeRegion <- requireRight "complete coverage region" (planarRegion [window]) + complete <- requireRight "complete coverage layer" (planarLayer False (Map.singleton True completeRegion)) + requireCoverage "complete layer" complete window + +testNaryOverlayLabels :: IO () +testNaryOverlayLabels = do + vertical <- rectangleRegion 0 0 6 10 >>= insideLayer + horizontal <- rectangleRegion 0 0 10 6 >>= insideLayer + central <- rectangleRegion 2 2 8 8 >>= insideLayer + let sourceLayers = vertical :| [horizontal, central] + refined <- requireRight "balanced n-ary overlay" (overlayAll sourceLayers) + assertNaryLabel sourceLayers refined (exactPoint 3 3) + assertNaryLabel sourceLayers refined (exactPoint 7 3) + assertNaryLabel sourceLayers refined (exactPoint 9 9) + assertNaryLabel sourceLayers refined (exactPoint (-1) (-1)) + singleton <- requireRight "singleton n-ary overlay" (overlayAll (vertical :| [])) + assertNaryLabel (vertical :| []) singleton (exactPoint 3 3) + +testOverlayMassAndConfusion :: IO () +testOverlayMassAndConfusion = do + left <- rectangleRegion 0 0 6 10 >>= insideLayer + right <- rectangleRegion 4 0 10 10 >>= insideLayer + result <- requireRight "mass overlay" (overlayLayers left right) + direct <- requireRight "direct overlap mass" (overlayMass (== (True, True)) result) + published <- + requireRight + "published overlap region" + (overlaySelectedRegion (== (True, True)) result) + publishedValues <- requireRight "published overlap valuation" (regionValuations published) + assertEqual + "direct mass equals published-region valuation" + (exactAreaValue (valuationArea publishedValues)) + (exactAreaValue direct) + assertEqual "overlap mass" 20 (exactAreaValue direct) + case overlayMass (== (False, False)) result of + Left RegionUnboundedSelection -> pure () + value -> fail ("unbounded overlay mass: unexpected result " <> show value) + assertEqual + "one-pass finite confusion masses" + ( Map.fromList + [ ((False, True), 40) + , ((True, False), 40) + , ((True, True), 20) + ] + ) + (fmap exactAreaValue (overlayConfusion result)) + traverse_ + (\(labels, expected) -> do + measured <- requireRight "direct confusion-cell mass" (overlayMass (== labels) result) + assertEqual "confusion entry equals direct mass" expected (exactAreaValue measured)) + (Map.toAscList (fmap exactAreaValue (overlayConfusion result))) + +assertEnvelopeDominance + :: Map.Map Int AffineForm + -> PlanarLayer (Maybe Int) + -> IO () +assertEnvelopeDominance forms layer = + traverse_ checkRegion (Map.toAscList (planarLayerRegions layer)) + where + checkRegion :: (Maybe Int, PlanarRegion) -> IO () + checkRegion (Nothing, _) = fail "bounded upper-envelope region has the outside label" + checkRegion (Just winner, region) = + case Map.lookup winner forms of + Nothing -> fail ("upper-envelope winner is absent from its input map: " <> show winner) + Just winnerForm -> + traverse_ + (checkWinnerAtPoint winner winnerForm) + (concatMap componentBoundaryPoints (planarRegionComponents region)) + + checkWinnerAtPoint + :: Int + -> AffineForm + -> ExactPoint + -> IO () + checkWinnerAtPoint winner winnerForm point = + let winnerValue = affineValue winnerForm point + in traverse_ + (\(candidate, candidateForm) -> + unless (winnerValue >= affineValue candidateForm point) $ + fail + ( "upper-envelope dominance failed: winner " + <> show winner + <> ", candidate " + <> show candidate + )) + (Map.toAscList forms) + +componentBoundaryPoints :: PolygonComponent -> [ExactPoint] +componentBoundaryPoints component = + NonEmpty.toList (exactLoopPoints (polygonOuterLoop component)) + <> concatMap (NonEmpty.toList . exactLoopPoints) (polygonHoleLoops component) + +affineValue + :: AffineForm + -> ExactPoint + -> ExactRational +affineValue form point = + let (coordinateX, coordinateY) = exactPointCoordinates point + in affineFormConstant form + + affineFormXCoefficient form * coordinateX + + affineFormYCoefficient form * coordinateY + +assertEnvelopeEqualsWindow + :: String + -> PolygonComponent + -> Map.Map Int AffineForm + -> IO () +assertEnvelopeEqualsWindow label window forms = do + expected <- requireRight (label <> " expected region") (planarRegion [window]) + layer <- requireRight label (upperEnvelope window forms) + assertEqual label (Just expected) (Map.lookup (Just 7) (planarLayerRegions layer)) + requireCoverage (label <> " coverage") layer window + +assertGapArea :: Integer -> CoverGap -> IO () +assertGapArea expected gap = do + values <- requireRight "gap valuation" (regionValuations (coverGapRegion gap)) + assertEqual "coverage obstruction retains exact gap" (fromInteger expected) (exactAreaValue (valuationArea values)) + +assertNaryLabel + :: NonEmpty (PlanarLayer Bool) + -> PlanarLayer (NonEmpty Bool) + -> ExactPoint + -> IO () +assertNaryLabel sourceLayers refined point = + assertEqual + "n-ary label tuple follows source order" + (fmap (`planarLayerLabelAt` point) sourceLayers) + (planarLayerLabelAt refined point) + +requireCoverage + :: (Ord label, Show label) + => String + -> PlanarLayer label + -> PolygonComponent + -> IO () +requireCoverage label layer window = + case layerCovers layer window of + Right () -> pure () + Left failure -> fail (label <> ": " <> show failure) + +lShapedComponent :: IO PolygonComponent +lShapedComponent = do + outer <- + requireRight + "L-shaped outer loop" + ( exactLoop + ( integerPoint 0 0 + :| [ integerPoint 4 0 + , integerPoint 4 1 + , integerPoint 1 1 + , integerPoint 1 4 + , integerPoint 0 4 + ] + ) + ) + requireRight "L-shaped component" (polygonComponent outer []) + +holedComponent :: IO PolygonComponent +holedComponent = do + outer <- + requireRight + "holed outer loop" + (exactLoop (integerPoint 0 0 :| [integerPoint 6 0, integerPoint 6 6, integerPoint 0 6])) + hole <- + requireRight + "clockwise hole loop" + (exactLoop (integerPoint 2 2 :| [integerPoint 2 4, integerPoint 4 4, integerPoint 4 2])) + requireRight "holed component" (polygonComponent outer [hole]) diff --git a/test/algebra/Moonlight/Triangulation/MinkowskiSpec.hs b/test/algebra/Moonlight/Triangulation/MinkowskiSpec.hs --- a/test/algebra/Moonlight/Triangulation/MinkowskiSpec.hs +++ b/test/algebra/Moonlight/Triangulation/MinkowskiSpec.hs @@ -18,13 +18,16 @@ , closeWith , convexMinkowskiSum , convexPolygon + , convexPolygonPoints , erodeBy , minkowskiGeneratedPieces + , minkowskiExactCrossings , minkowskiOperation , minkowskiOverlayPasses , minkowskiSum , openWith , polygonOffset + , reflectConvexPolygon , structuringElement ) import Moonlight.Triangulation.Region @@ -45,6 +48,7 @@ tests :: IO () tests = do testConvexConvolution + testConvexReflection testGeneralAddition testOffsetClosure testConvexMorphology @@ -52,6 +56,23 @@ testHoledAndNeckedErosion putStrLn "minkowski: ok" +testConvexReflection :: IO () +testConvexReflection = do + triangle <- + requireRight + "asymmetric convex triangle" + (convexPolygon (exactPoint 0 0 :| [exactPoint 3 0, exactPoint 1 2])) + let reflected = reflectConvexPolygon triangle + readmitted <- + requireRight + "reflected convex polygon preserves counter-clockwise orientation" + (convexPolygon (convexPolygonPoints reflected)) + assertEqual "reflected carrier remains admissible" reflected readmitted + assertEqual + "convex reflection is involutive" + triangle + (reflectConvexPolygon reflected) + testConvexConvolution :: IO () testConvexConvolution = do leftComponent <- rectangleComponent 0 0 1 1 @@ -183,6 +204,10 @@ expectedErosion <- rectangleRegion (-1) (-1) 1 1 assertEqual "convex support-half-plane erosion" expectedErosion eroded assertEqual "convex erosion needs no overlay" 0 (minkowskiOverlayPasses erosionReceipt) + assertEqual + "convex erosion reports exact HPI line intersections" + 4 + (minkowskiExactCrossings erosionReceipt) exactFitSource <- rectangleRegion (-1) (-1) 1 1 (lowerDimensionalResidual, _) <- requireRight "exact-fit regularized erosion" (erodeBy element exactFitSource) diff --git a/test/algebra/Moonlight/Triangulation/PowerDiagramSpec.hs b/test/algebra/Moonlight/Triangulation/PowerDiagramSpec.hs new file mode 100644 --- /dev/null +++ b/test/algebra/Moonlight/Triangulation/PowerDiagramSpec.hs @@ -0,0 +1,734 @@ +-- | Exact bounded power-cell laws through the public owner. +module Moonlight.Triangulation.PowerDiagramSpec (tests) where + +import Control.Monad (unless) +import Data.Foldable (traverse_) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Moonlight.Triangulation + ( ExactPoint + , ExactRational + , ExactVector (..) + , BoundedPowerDiagram + , ConvexPolygon + , Point (..) + , PowerCellDisposition (..) + , PowerDualEdge (..) + , PowerDiagramError (..) + , PowerSite + , PowerWeight + , PowerWeightError (..) + , RegularSiteDisposition (..) + , RegularEdge + , boundedPowerDiagram + , convexPolygon + , convexPolygonPoints + , exactPointCoordinates + , exactPointFromPoint + , exactRayDirection + , exactRayOrigin + , exactSegmentEndpoints + , planarLayerRegions + , powerCellDisposition + , powerCellDispositions + , powerDiagramActiveBoundaries + , powerDiagramCoincidentEquivalentCells + , powerDiagramCoincidentDominatedCells + , powerDiagramEmptyCells + , powerDiagramInputSites + , powerDiagramLowerDimensionalCells + , powerDiagramPlanarLayer + , powerDiagramPublishedCells + , powerDiagramOracleCells + , powerDiagramMaximumCellConstraints + , powerDiagramRegularEdges + , powerDiagramSubmittedSiteConstraints + , powerSite + , powerSiteLabel + , powerSitePosition + , powerSiteWeight + , powerWeight + , powerWeightExact + , regularEdgeDual + , regularEdgeLabels + , regularEdges + , regularFaceDualPoint + , regularFaces + , regularNeighbours + , regularSiteDisposition + , regularTriangulation + , regularTriangulationEdges + , regularTriangulationFaces + , regularTriangulationVisibleSites + , translateExactPoint + ) +import Moonlight.Triangulation.Exact + ( ExactClipDisposition (..) + , ExactClosedHalfPlane + , exactAffineLine + , exactClipRetainedPolygon + , exactClosedHalfPlane + , exactRetainedPolygon + , exactRetainedPolygonPoints + ) +import Support (assertEqual, integerPoint, requireRight) + +tests :: IO () +tests = do + testEqualWeightsAndCommonShift + testThreeSiteExactPartitionCoverage + testRegularTriangleDualRays + testRegularBoundedDualSegment + testRegularCoplanarUpperFacet + testRegularCollinearClassification + testRegularLowerDimensionalAndHiddenSites + testSparsePowerMatchesCompleteOracle + testEqualCoincidentResolution + testDominantCoincidentResolution + testLowerDimensionalCell + testDistinctEmptyCell + testDyadicNearParallelBisectors + testBinary64PrecisionSites + testDuplicateLabels + testNonFiniteWeight + putStrLn "power diagram: ok" + +testRegularTriangleDualRays :: IO () +testRegularTriangleDualRays = do + zero <- admittedWeight 0 + firstSite <- admittedSite "first" (Point 0 0) zero + secondSite <- admittedSite "second" (Point 2 0) zero + thirdSite <- admittedSite "third" (Point 0 2) zero + let sites = firstSite :| [secondSite, thirdSite] + (regular, receipt) <- + requireRight "three-site regular topology" (regularTriangulation sites) + assertEqual "three visible regular sites" 3 (regularTriangulationVisibleSites receipt) + assertEqual "one regular face" 1 (length (regularFaces regular)) + assertEqual "three regular boundary edges" 3 (length (regularEdges regular)) + dualPoint <- + case regularFaces regular of + [face] -> pure (regularFaceDualPoint face) + faces -> fail ("three-site topology expected one face, got " <> show (length faces)) + traverse_ (assertBoundaryDualRay sites dualPoint) (regularEdges regular) + traverse_ + (\site -> + let label = powerSiteLabel site + in do + assertEqual + ("visible regular disposition for " <> label) + (Just RegularSiteVisible) + (regularSiteDisposition label regular) + assertEqual + ("two regular neighbours for " <> label) + 2 + (Set.size (regularNeighbours label regular))) + sites + +testRegularBoundedDualSegment :: IO () +testRegularBoundedDualSegment = do + zero <- admittedWeight 0 + sites <- + traverse + (\(label, point) -> admittedSite label point zero) + ( ("south-west", Point 0 0) + :| [ ("south-east", Point 4 0) + , ("north-east", Point 3 3) + , ("north-west", Point 0 4) + ] + ) + (regular, receipt) <- + requireRight "four-site regular topology" (regularTriangulation sites) + assertEqual + "regular planar Euler equation" + 1 + ( regularTriangulationVisibleSites receipt + - regularTriangulationEdges receipt + + regularTriangulationFaces receipt + ) + let faceDuals = Set.fromList (fmap regularFaceDualPoint (regularFaces regular)) + bounded = + [ segment + | edge <- regularEdges regular + , BoundedPowerDual segment <- [regularEdgeDual edge] + ] + case bounded of + [segment] -> + let (firstEndpoint, secondEndpoint) = exactSegmentEndpoints segment + in unless + (Set.member firstEndpoint faceDuals && Set.member secondEndpoint faceDuals) + (fail "bounded regular dual does not join its two incident face duals") + segments -> + fail ("four-site topology expected one bounded dual, got " <> show (length segments)) + +testRegularCoplanarUpperFacet :: IO () +testRegularCoplanarUpperFacet = do + sites <- + traverse + prepareOracleSite + ( ("a-bottom", Point 0.25 0.25, -0.875) + :| [ ("b-south-west", Point 0 0, 0) + , ("c-south-east", Point 1 0, 1) + , ("d-center", Point 0.5 0.5, 0.5) + , ("e-north-east", Point 1 1, 2) + , ("f-north-west", Point 0 1, 1) + ] + ) + (regular, receipt) <- + requireRight "coplanar upper regular facet" (regularTriangulation sites) + traverse_ + (\label -> + assertEqual + ("upper-facet vertex remains visible: " <> label) + (Just RegularSiteVisible) + (regularSiteDisposition label regular)) + ["b-south-west", "c-south-east", "e-north-east", "f-north-west"] + assertEqual + "upper-facet interior generator remains lower-dimensional" + (Just RegularSiteLowerDimensional) + (regularSiteDisposition "d-center" regular) + assertEqual + "strictly lower lifted generator remains hidden" + (Just RegularSiteHidden) + (regularSiteDisposition "a-bottom" regular) + assertEqual "coplanar upper facet has four visible vertices" 4 (regularTriangulationVisibleSites receipt) + assertEqual "coplanar upper facet receives one deterministic diagonal" 2 (regularTriangulationFaces receipt) + +testRegularLowerDimensionalAndHiddenSites :: IO () +testRegularLowerDimensionalAndHiddenSites = do + domain <- squareDomain + zero <- admittedWeight 0 + lowerWeight <- admittedWeight (-1.5) + hiddenWeight <- admittedWeight (-2) + firstSite <- admittedSite "first" (Point 0 0) zero + secondSite <- admittedSite "second" (Point 2 0) zero + thirdSite <- admittedSite "third" (Point 0 2) zero + lowerSite <- admittedSite "center" (Point 0.5 0.5) lowerWeight + hiddenSite <- admittedSite "center" (Point 0.5 0.5) hiddenWeight + let lowerSites = firstSite :| [secondSite, thirdSite, lowerSite] + hiddenSites = firstSite :| [secondSite, thirdSite, hiddenSite] + (lowerRegular, _) <- + requireRight "coplanar regular topology" (regularTriangulation lowerSites) + assertEqual + "coplanar interior generator remains lower-dimensional" + (Just RegularSiteLowerDimensional) + (regularSiteDisposition "center" lowerRegular) + (lowerDiagram, lowerReceipt) <- + requireRight "bounded lower-dimensional power cell" (boundedPowerDiagram domain lowerSites) + case powerCellDisposition "center" lowerDiagram of + Just (LowerDimensionalPowerCell _) -> pure () + other -> fail ("expected lower-dimensional center cell, got " <> dispositionTag other) + assertEqual "one lower-dimensional oracle cell" 1 (powerDiagramOracleCells lowerReceipt) + (hiddenRegular, _) <- + requireRight "hidden regular topology" (regularTriangulation hiddenSites) + assertEqual + "strictly interior lifted generator is hidden" + (Just RegularSiteHidden) + (regularSiteDisposition "center" hiddenRegular) + (hiddenDiagram, hiddenReceipt) <- + requireRight "bounded hidden power cell" (boundedPowerDiagram domain hiddenSites) + assertEqual "hidden generator has empty cell" (Just EmptyPowerCell) (powerCellDisposition "center" hiddenDiagram) + assertEqual "hidden generator needs no HPI oracle" 0 (powerDiagramOracleCells hiddenReceipt) + unless + ( powerDiagramMaximumCellConstraints hiddenReceipt <= powerDiagramRegularEdges hiddenReceipt + ) + (fail "power construction retained more axes than the regular graph") + +testRegularCollinearClassification :: IO () +testRegularCollinearClassification = do + sites <- traverse prepareCollinearSite (0 :| [1 .. 8]) + (regular, _) <- + requireRight "collinear regular topology" (regularTriangulation sites) + traverse_ + (\index -> + assertEqual + ("collinear disposition for " <> show index) + (Just (if even index then RegularSiteVisible else RegularSiteHidden)) + (regularSiteDisposition (show index) regular)) + ([0 .. 8] :: [Int]) + where + prepareCollinearSite :: Int -> IO (PowerSite String) + prepareCollinearSite index = do + weight <- admittedWeight (if odd index then -(2 / 256) else 0) + admittedSite (show index) (Point (fromIntegral index / 16) 0) weight + +testSparsePowerMatchesCompleteOracle :: IO () +testSparsePowerMatchesCompleteOracle = do + domain <- squareDomain + sites <- + traverse + prepareOracleSite + ( ("a", Point 1.0 1.0, 0.25) + :| [ ("b", Point 3.0 0.8, -0.125) + , ("c", Point 5.2 1.4, 0.375) + , ("d", Point 8.5 1.0, 0.0) + , ("e", Point 1.7 3.8, -0.25) + , ("f", Point 4.1 4.4, 0.125) + , ("g", Point 7.6 3.5, -0.375) + , ("h", Point 9.1 5.4, 0.25) + , ("i", Point 1.0 7.8, 0.0) + , ("j", Point 3.6 8.9, 0.5) + , ("k", Point 6.4 7.5, -0.125) + , ("l", Point 8.8 9.0, 0.375) + ] + ) + (diagram, receipt) <- + requireRight "sparse regular-neighbour power diagram" (boundedPowerDiagram domain sites) + traverse_ + (\site -> do + oracle <- completeOraclePowerCell domain sites site + assertEqual + ("regular-neighbour cell equals complete HPI oracle for " <> powerSiteLabel site) + (Just oracle) + (powerCellDisposition (powerSiteLabel site) diagram)) + sites + let siteCount = NonEmpty.length sites + completeConstraintCount = siteCount * (siteCount - 1) + unless (powerDiagramSubmittedSiteConstraints receipt < completeConstraintCount) $ + fail "regular-neighbour construction did not eliminate the complete pairwise cell schedule" + unless (powerDiagramMaximumCellConstraints receipt <= powerDiagramRegularEdges receipt) $ + fail "regular-neighbour construction retained a non-topological radical axis" + +prepareOracleSite + :: (String, Point, Double) + -> IO (PowerSite String) +prepareOracleSite (label, point, weightValue) = do + weight <- admittedWeight weightValue + admittedSite label point weight + +data OracleScore = OracleScore + { oracleXCoefficient :: !ExactRational + , oracleYCoefficient :: !ExactRational + , oracleConstant :: !ExactRational + } + +oracleScore :: PowerSite label -> IO OracleScore +oracleScore site = do + point <- requireRight "oracle source point" (exactPointFromPoint (powerSitePosition site)) + let (coordinateX, coordinateY) = exactPointCoordinates point + pure + OracleScore + { oracleXCoefficient = 2 * coordinateX + , oracleYCoefficient = 2 * coordinateY + , oracleConstant = + powerWeightExact (powerSiteWeight site) + - coordinateX * coordinateX + - coordinateY * coordinateY + } + +completeOraclePowerCell + :: ConvexPolygon + -> NonEmpty (PowerSite String) + -> PowerSite String + -> IO (PowerCellDisposition String) +completeOraclePowerCell domain sites owner = do + retainedDomain <- + requireRight "oracle retained domain" (exactRetainedPolygon (convexPolygonPoints domain)) + ownerScore <- oracleScore owner + halfPlanes <- + traverse + (oracleWinningHalfPlane ownerScore) + ( filter + ((/= powerSiteLabel owner) . powerSiteLabel) + (NonEmpty.toList sites) + ) + (disposition, _) <- + requireRight + ("complete HPI oracle for " <> powerSiteLabel owner) + (exactClipRetainedPolygon retainedDomain halfPlanes) + case disposition of + ExactClipFullDimensional retained -> + PublishedPowerCell + <$> requireRight + "oracle convex publication" + (convexPolygon (exactRetainedPolygonPoints retained)) + ExactClipLowerDimensional points -> + pure (LowerDimensionalPowerCell points) + ExactClipEmpty -> pure EmptyPowerCell + +oracleWinningHalfPlane + :: OracleScore + -> PowerSite label + -> IO ExactClosedHalfPlane +oracleWinningHalfPlane owner competitor = do + competitorScore <- oracleScore competitor + line <- + requireRight + "oracle radical axis" + ( exactAffineLine + (oracleXCoefficient owner - oracleXCoefficient competitorScore) + (oracleYCoefficient owner - oracleYCoefficient competitorScore) + (oracleConstant owner - oracleConstant competitorScore) + ) + pure (exactClosedHalfPlane line) + +assertBoundaryDualRay + :: NonEmpty (PowerSite String) + -> ExactPoint + -> RegularEdge String + -> IO () +assertBoundaryDualRay sites expectedOrigin edge = + case regularEdgeDual edge of + UnboundedPowerDual ray -> do + assertEqual "regular ray starts at incident face dual" expectedOrigin (exactRayOrigin ray) + let ExactVector directionX directionY = exactRayDirection ray + unless (directionX /= 0 || directionY /= 0) $ + fail ("regular edge has a zero dual-ray direction: " <> show (regularEdgeLabels edge)) + let sample = translateExactPoint expectedOrigin (exactRayDirection ray) + (firstLabel, secondLabel) = regularEdgeLabels edge + firstSite <- requireSite firstLabel sites + secondSite <- requireSite secondLabel sites + firstDistance <- powerDistance sample firstSite + secondDistance <- powerDistance sample secondSite + assertEqual "regular ray remains on its radical axis" firstDistance secondDistance + traverse_ + (\competitor -> do + competitorDistance <- powerDistance sample competitor + unless (firstDistance <= competitorDistance) $ + fail ("regular ray points outside the common winning cone: " <> show (firstLabel, secondLabel))) + sites + other -> fail ("regular triangle boundary expected a ray, got " <> show other) + +requireSite :: Eq label => label -> NonEmpty (PowerSite label) -> IO (PowerSite label) +requireSite label sites = + case List.find ((== label) . powerSiteLabel) (NonEmpty.toList sites) of + Nothing -> fail "regular topology references a missing source site" + Just site -> pure site + +testEqualWeightsAndCommonShift :: IO () +testEqualWeightsAndCommonShift = do + domain <- squareDomain + zero <- admittedWeight 0 + shifted <- admittedWeight 7 + zeroSites <- + ( :| ) + <$> admittedSite "left" (Point 2 5) zero + <*> traverse (uncurry3 admittedSite) [("right", Point 8 5, zero)] + shiftedSites <- + ( :| ) + <$> admittedSite "left" (Point 2 5) shifted + <*> traverse (uncurry3 admittedSite) [("right", Point 8 5, shifted)] + (diagram, receipt) <- requireRight "equal-weight power diagram" (boundedPowerDiagram domain zeroSites) + (shiftedDiagram, _) <- requireRight "common-shift power diagram" (boundedPowerDiagram domain shiftedSites) + assertEqual "common additive power shift" (powerCellDispositions diagram) (powerCellDispositions shiftedDiagram) + assertPermutationInvariant "equal-weight power diagram" domain zeroSites diagram + assertPermutationInvariant "common-shift power diagram" domain shiftedSites shiftedDiagram + expectedLeft <- + requireRight + "expected left power cell" + (convexPolygon (integerPoint 0 0 :| [integerPoint 5 0, integerPoint 5 10, integerPoint 0 10])) + expectedRight <- + requireRight + "expected right power cell" + (convexPolygon (integerPoint 5 0 :| [integerPoint 10 0, integerPoint 10 10, integerPoint 5 10])) + assertEqual "equal-weight left bisector cell" (Just (PublishedPowerCell expectedLeft)) (powerCellDisposition "left" diagram) + assertEqual "equal-weight right bisector cell" (Just (PublishedPowerCell expectedRight)) (powerCellDisposition "right" diagram) + assertEqual "receipt input sites" 2 (powerDiagramInputSites receipt) + assertEqual + "one submitted site constraint per cell" + 2 + (powerDiagramSubmittedSiteConstraints receipt) + assertEqual + "parallel domain and site boundaries coalesce" + 8 + (powerDiagramActiveBoundaries receipt) + assertEqual "receipt published cells" 2 (powerDiagramPublishedCells receipt) + assertEqual "receipt empty cells" 0 (powerDiagramEmptyCells receipt) + traverse_ (assertPublishedVerticesWin zeroSites) (powerCellDispositions diagram) + layer <- requireRight "power diagram planar layer" (powerDiagramPlanarLayer "outside" diagram) + assertEqual "derived layer contains both cells" ["left", "right"] (Map.keys (planarLayerRegions layer)) + assertOutsideCollision diagram + +testThreeSiteExactPartitionCoverage :: IO () +testThreeSiteExactPartitionCoverage = do + domain <- squareDomain + weight <- admittedWeight 0 + left <- admittedSite "left" (Point 2 5) weight + middle <- admittedSite "middle" (Point 5 5) weight + right <- admittedSite "right" (Point 8 5) weight + let sites = left :| [middle, right] + (diagram, receipt) <- + requireRight "three-site exact partition" (boundedPowerDiagram domain sites) + assertEqual "three-site partition publishes every cell" 3 (powerDiagramPublishedCells receipt) + assertEqual + "three-site exact cell areas cover the square" + 200 + (publishedTwiceAreaSum diagram) + traverse_ + (\permutation -> do + (permuted, _) <- + requireRight + "permuted three-site exact partition" + (boundedPowerDiagram domain permutation) + assertEqual + "three-site partition is permutation invariant" + (powerCellDispositions diagram) + (powerCellDispositions permuted) + assertEqual + "permuted exact cell areas cover the square" + 200 + (publishedTwiceAreaSum permuted)) + (nonEmptyPermutations sites) + +nonEmptyPermutations :: NonEmpty value -> [NonEmpty value] +nonEmptyPermutations = + foldMap (maybe [] pure . NonEmpty.nonEmpty) + . List.permutations + . NonEmpty.toList + +assertPermutationInvariant + :: String + -> ConvexPolygon + -> NonEmpty (PowerSite String) + -> BoundedPowerDiagram String + -> IO () +assertPermutationInvariant label domain sites expected = + traverse_ + (\permutation -> do + (permuted, _) <- + requireRight + (label <> " permutation") + (boundedPowerDiagram domain permutation) + assertEqual + (label <> " is permutation invariant") + (powerCellDispositions expected) + (powerCellDispositions permuted)) + (nonEmptyPermutations sites) + +publishedTwiceAreaSum :: BoundedPowerDiagram label -> ExactRational +publishedTwiceAreaSum = + List.foldl' + (\total (_, disposition) -> case disposition of + PublishedPowerCell polygon -> total + exactPolygonTwiceArea (convexPolygonPoints polygon) + LowerDimensionalPowerCell _ -> total + EmptyPowerCell -> total + CoincidentEquivalentTo _ -> total + CoincidentDominatedBy _ -> total) + 0 + . powerCellDispositions + +exactPolygonTwiceArea :: NonEmpty ExactPoint -> ExactRational +exactPolygonTwiceArea points = + abs + ( List.foldl' + (\twiceArea (firstPoint, secondPoint) -> + let (firstX, firstY) = exactPointCoordinates firstPoint + (secondX, secondY) = exactPointCoordinates secondPoint + in twiceArea + firstX * secondY - firstY * secondX) + 0 + (cyclicPairs points) + ) + +cyclicPairs :: NonEmpty value -> [(value, value)] +cyclicPairs (firstValue :| remainingValues) = + zip + (firstValue : remainingValues) + (remainingValues <> [firstValue]) + +testEqualCoincidentResolution :: IO () +testEqualCoincidentResolution = do + domain <- squareDomain + weight <- admittedWeight 3 + a <- admittedSite "a" (Point 4 4) weight + b <- admittedSite "b" (Point 4 4) weight + (diagram, receipt) <- requireRight "equivalent coincident power sites" (boundedPowerDiagram domain (b :| [a])) + assertPublished "coincident canonical representative" (powerCellDisposition "a" diagram) + assertEqual "equal-function coincident alias" (Just (CoincidentEquivalentTo "a")) (powerCellDisposition "b" diagram) + assertEqual "equivalent coincidence receipt" 1 (powerDiagramCoincidentEquivalentCells receipt) + assertEqual "equivalent coincidence is not dominance" 0 (powerDiagramCoincidentDominatedCells receipt) + (permuted, _) <- requireRight "permuted equivalent sites" (boundedPowerDiagram domain (a :| [b])) + assertEqual "equivalent resolution permutation invariance" (powerCellDispositions diagram) (powerCellDispositions permuted) + +testDominantCoincidentResolution :: IO () +testDominantCoincidentResolution = do + domain <- squareDomain + high <- admittedWeight 3 + low <- admittedWeight 2 + winner <- admittedSite "winner" (Point 4 4) high + dominated <- admittedSite "dominated" (Point 4 4) low + (diagram, receipt) <- requireRight "dominant coincident power sites" (boundedPowerDiagram domain (dominated :| [winner])) + assertPublished "dominant coincident representative" (powerCellDisposition "winner" diagram) + assertEqual "lower-weight coincident site" (Just (CoincidentDominatedBy "winner")) (powerCellDisposition "dominated" diagram) + assertEqual "dominant coincidence receipt" 1 (powerDiagramCoincidentDominatedCells receipt) + assertEqual "dominance is not equivalence" 0 (powerDiagramCoincidentEquivalentCells receipt) + assertPermutationInvariant "dominant coincident power sites" domain (dominated :| [winner]) diagram + +testLowerDimensionalCell :: IO () +testLowerDimensionalCell = do + domain <- squareDomain + zero <- admittedWeight 0 + suppressed <- admittedWeight (-1) + left <- admittedSite "left" (Point 0 5) zero + right <- admittedSite "right" (Point 2 5) zero + middle <- admittedSite "middle" (Point 1 5) suppressed + let sites = left :| [right, middle] + (diagram, receipt) <- requireRight "one-dimensional bounded power cell" (boundedPowerDiagram domain sites) + case powerCellDisposition "middle" diagram of + Just (LowerDimensionalPowerCell points) -> + assertEqual + "middle cell is the exact x=1 segment" + (List.sort [integerPoint 1 0, integerPoint 1 10]) + (List.sort (NonEmpty.toList points)) + other -> fail ("one-dimensional power cell: expected retained segment, got " <> dispositionTag other) + assertEqual "lower-dimensional receipt" 1 (powerDiagramLowerDimensionalCells receipt) + assertEqual "lower-dimensional cell is not empty" 0 (powerDiagramEmptyCells receipt) + assertEqual "two full-dimensional neighbours" 2 (powerDiagramPublishedCells receipt) + traverse_ (assertPublishedVerticesWin sites) (powerCellDispositions diagram) + layer <- requireRight "lower-dimensional derived layer" (powerDiagramPlanarLayer "outside" diagram) + assertEqual "derived layer omits the one-dimensional cell" ["left", "right"] (Map.keys (planarLayerRegions layer)) + assertPermutationInvariant "one-dimensional bounded power cell" domain sites diagram + +testDistinctEmptyCell :: IO () +testDistinctEmptyCell = do + domain <- squareDomain + ordinary <- admittedWeight 0 + suppressed <- admittedWeight (-1000) + winner <- admittedSite "winner" (Point 0 0) ordinary + hidden <- admittedSite "hidden" (Point 5 5) suppressed + (diagram, receipt) <- requireRight "distinct empty power cell" (boundedPowerDiagram domain (winner :| [hidden])) + assertPublished "dominant distinct site" (powerCellDisposition "winner" diagram) + assertEqual "distinct site may have empty bounded cell" (Just EmptyPowerCell) (powerCellDisposition "hidden" diagram) + assertEqual "empty disposition receipt" 1 (powerDiagramEmptyCells receipt) + assertPermutationInvariant "distinct empty power cell" domain (winner :| [hidden]) diagram + +testDyadicNearParallelBisectors :: IO () +testDyadicNearParallelBisectors = do + domain <- squareDomain + weight <- admittedWeight 0 + let epsilon = 2 ** (-20) :: Double + origin <- admittedSite "origin" (Point 0 0) weight + horizontal <- admittedSite "horizontal" (Point 2 0) weight + tilted <- admittedSite "tilted" (Point 2 epsilon) weight + let sites = origin :| [horizontal, tilted] + (diagram, receipt) <- + requireRight + "dyadic near-parallel power bisectors" + (boundedPowerDiagram domain sites) + assertEqual "near-parallel cells retain full dimension" 3 (powerDiagramPublishedCells receipt) + traverse_ (assertPublishedVerticesWin sites) (powerCellDispositions diagram) + assertPermutationInvariant "dyadic near-parallel power bisectors" domain sites diagram + +testBinary64PrecisionSites :: IO () +testBinary64PrecisionSites = do + domain <- squareDomain + firstWeight <- admittedWeight 0.2 + secondWeight <- admittedWeight (-0.3) + thirdWeight <- admittedWeight 0.7 + firstSite <- admittedSite "first" (Point 0.1 0.3) firstWeight + secondSite <- admittedSite "second" (Point 9.7 0.2) secondWeight + thirdSite <- admittedSite "third" (Point 4.9 9.6) thirdWeight + let sites = firstSite :| [secondSite, thirdSite] + (diagram, receipt) <- + requireRight + "exact binary64 power sites" + (boundedPowerDiagram domain sites) + assertEqual "binary64 fixture publishes every cell" 3 (powerDiagramPublishedCells receipt) + traverse_ (assertPublishedVerticesWin sites) (powerCellDispositions diagram) + assertPermutationInvariant "exact binary64 power sites" domain sites diagram + +testDuplicateLabels :: IO () +testDuplicateLabels = do + domain <- squareDomain + weight <- admittedWeight 0 + firstSite <- admittedSite "duplicate" (Point 1 1) weight + secondSite <- admittedSite "duplicate" (Point 9 9) weight + case boundedPowerDiagram domain (firstSite :| [secondSite]) of + Left (DuplicatePowerSiteLabel "duplicate") -> pure () + other -> fail ("duplicate power-site label: expected typed refusal, got " <> show other) + +testNonFiniteWeight :: IO () +testNonFiniteWeight = + case powerWeight (0 / 0) of + Left (PowerWeightNonFinite _) -> pure () + other -> fail ("non-finite power weight: expected typed refusal, got " <> show other) + +squareDomain :: IO ConvexPolygon +squareDomain = + requireRight + "square clipping domain" + (convexPolygon (integerPoint 0 0 :| [integerPoint 10 0, integerPoint 10 10, integerPoint 0 10])) + +admittedWeight :: Double -> IO PowerWeight +admittedWeight value = + requireRight + "finite power weight" + (powerWeight value) + +admittedSite :: String -> Point -> PowerWeight -> IO (PowerSite String) +admittedSite label point weight = requireRight "admitted power site" (powerSite label point weight) + +uncurry3 :: (a -> b -> c -> result) -> (a, b, c) -> result +uncurry3 function (firstValue, secondValue, thirdValue) = function firstValue secondValue thirdValue + +assertPublished :: String -> Maybe (PowerCellDisposition label) -> IO () +assertPublished _ (Just (PublishedPowerCell _)) = pure () +assertPublished label other = fail (label <> ": expected published cell, got " <> dispositionTag other) + +dispositionTag :: Maybe (PowerCellDisposition label) -> String +dispositionTag Nothing = "missing" +dispositionTag (Just (PublishedPowerCell _)) = "published" +dispositionTag (Just (LowerDimensionalPowerCell _)) = "lower-dimensional" +dispositionTag (Just EmptyPowerCell) = "empty" +dispositionTag (Just (CoincidentEquivalentTo _)) = "coincident-equivalent" +dispositionTag (Just (CoincidentDominatedBy _)) = "coincident-dominated" + +assertOutsideCollision :: BoundedPowerDiagram String -> IO () +assertOutsideCollision diagram = + case powerDiagramPlanarLayer "left" diagram of + Left (PowerDiagramOutsideLabelCollides "left") -> pure () + other -> fail ("power layer outside-label collision: expected refusal, got " <> show other) + +assertPublishedVerticesWin + :: NonEmpty (PowerSite String) + -> (String, PowerCellDisposition String) + -> IO () +assertPublishedVerticesWin sites (ownerLabel, disposition) = + case disposition of + PublishedPowerCell polygon -> + assertCellPointsWin ownerLabel sites (convexPolygonPoints polygon) + LowerDimensionalPowerCell points -> + assertCellPointsWin ownerLabel sites points + EmptyPowerCell -> pure () + CoincidentEquivalentTo _ -> pure () + CoincidentDominatedBy _ -> pure () + +assertCellPointsWin + :: String + -> NonEmpty (PowerSite String) + -> NonEmpty ExactPoint + -> IO () +assertCellPointsWin ownerLabel sites points = + case lookupOwner ownerLabel (NonEmpty.toList sites) of + Nothing -> fail ("power-cell owner missing: " <> ownerLabel) + Just owner -> + traverse_ + (\point -> traverse_ (assertOwnerWinsAt point owner) sites) + points + +lookupOwner :: Eq label => label -> [PowerSite label] -> Maybe (PowerSite label) +lookupOwner label = List.find ((== label) . powerSiteLabel) + +assertOwnerWinsAt + :: ExactPoint + -> PowerSite String + -> PowerSite String + -> IO () +assertOwnerWinsAt point owner competitor = do + ownerValue <- powerDistance point owner + competitorValue <- powerDistance point competitor + unless (ownerValue <= competitorValue) $ + fail + ( "power-cell vertex violates source inequality: " + <> show (powerSiteLabel owner, powerSiteLabel competitor, ownerValue, competitorValue) + ) + +powerDistance :: ExactPoint -> PowerSite label -> IO ExactRational +powerDistance point site = do + exactSite <- requireRight "site exact position" (exactPointFromPoint (powerSitePosition site)) + let (x, y) = exactPointCoordinates point + (siteX, siteY) = exactPointCoordinates exactSite + deltaX = x - siteX + deltaY = y - siteY + pure (deltaX * deltaX + deltaY * deltaY - powerWeightExact (powerSiteWeight site)) diff --git a/test/coherence/Main.hs b/test/coherence/Main.hs --- a/test/coherence/Main.hs +++ b/test/coherence/Main.hs @@ -1,12 +1,15 @@ -- | Compile every test slice against the union of their dependencies. Empty -- imports make module and instance collisions observable without executing the --- four focused behavioral suites twice. +-- behavioral suites twice. module Main (main) where import Moonlight.Triangulation.AlgebraSpec () +import Moonlight.Triangulation.ExactClipRetentionSpec () +import Moonlight.Triangulation.LayerOperationsSpec () import Moonlight.Triangulation.MinkowskiSpec () import Moonlight.Triangulation.NativeSpec () import Moonlight.Triangulation.ParallelSpec () +import Moonlight.Triangulation.PowerDiagramSpec () import Moonlight.Triangulation.RegionAlgebraSpec () import Moonlight.Triangulation.ScheduleAgreementSpec () import Moonlight.Triangulation.SerializationSpec () diff --git a/test/exact-planar/Main.hs b/test/exact-planar/Main.hs new file mode 100644 --- /dev/null +++ b/test/exact-planar/Main.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import qualified Moonlight.Triangulation.ExactClipRetentionSpec as ExactClipRetentionSpec +import qualified Moonlight.Triangulation.LayerOperationsSpec as LayerOperationsSpec +import qualified Moonlight.Triangulation.MinkowskiSpec as MinkowskiSpec +import qualified Moonlight.Triangulation.PowerDiagramSpec as PowerDiagramSpec + +main :: IO () +main = + sequence_ + [ ExactClipRetentionSpec.tests + , MinkowskiSpec.tests + , PowerDiagramSpec.tests + , LayerOperationsSpec.tests + ] diff --git a/test/native/Moonlight/Triangulation/ExactEmbeddingSpec.hs b/test/native/Moonlight/Triangulation/ExactEmbeddingSpec.hs --- a/test/native/Moonlight/Triangulation/ExactEmbeddingSpec.hs +++ b/test/native/Moonlight/Triangulation/ExactEmbeddingSpec.hs @@ -36,7 +36,7 @@ , exactRationalNumerator , exactSignum ) -import Moonlight.Triangulation.Internal.Overlay.Embedding +import Moonlight.Triangulation.Embedding ( DraftIncidence (..) , DraftId (..) , DraftNeighborhood (..) @@ -44,7 +44,12 @@ , DraftVertexId , EmbeddingObligation (..) , ExactArrangementDraft (..) - , LocalEmbeddingCertificate (..) + , certificateIncidenceRelationPreservationCount + , certificateNeighborhoodRotationPreservationCount + , certificateResidual + , certificateRoundedVertexDistinctnessCount + , certificateRoundedVertices + , certificateSplitOrderPreservationCount , OverlayEmbeddingObstruction (..) , certifyLocalEmbedding , residualUndischargedObligations diff --git a/test/public-components/Main.hs b/test/public-components/Main.hs --- a/test/public-components/Main.hs +++ b/test/public-components/Main.hs @@ -11,6 +11,11 @@ import Moonlight.Triangulation.Handles.Iterators.DynamicIterators ( vertexHandles ) +import Moonlight.Triangulation.Handles.Scoped + ( scopedVertexPoint + , scopedVertices + , withScopedTriangulation + ) import Moonlight.Triangulation.PointLocation (locatePoint) import Moonlight.Triangulation.Session ( insertVertexAt @@ -37,6 +42,7 @@ data PublicComponentSummary = PublicComponentSummary { residentVertices :: !Int , owningVertexHandles :: !Int + , scopedVertexPoints :: !Int , rectangleVertices :: !Int , locatedResidentVertex :: !Bool , sessionInsertedVertex :: !Bool @@ -80,6 +86,9 @@ PublicComponentSummary { residentVertices = numVertices restored , owningVertexHandles = length (vertexHandles restored) + , scopedVertexPoints = + withScopedTriangulation restored $ \scoped -> + length (fmap (scopedVertexPoint scoped) (scopedVertices scoped)) , rectangleVertices = length inside , locatedResidentVertex = case locatePoint restored query of OnVertex _ -> True @@ -104,6 +113,7 @@ PublicComponentSummary { residentVertices = 4 , owningVertexHandles = 4 + , scopedVertexPoints = 4 , rectangleVertices = 4 , locatedResidentVertex = True , sessionInsertedVertex = True