diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,62 @@ The serialization format carries its own version tag, independent of the package version; any change to it is recorded here explicitly. +## 1.3.0.0 + +* Add the public GHC-9.14 `cell-complex` component. It interprets an admitted + `ExactCellSet` as Homology's generic `CellComplex2D` without copying the mesh + or introducing a second cell inventory, and the accompanying observatory + executable derives its incidence category and normalized flag nerve. +* Keep the LLVM-optimized hot modules buildable with GHC 9.8 by restoring the + legacy LLVM pass manager that its supported LLVM 15 toolchain requires. +* Withdraw `constrainedExtensionTriangulation`, + `constrainedExtensionConstraintOutcomes` and + `constrainedExtensionConstraintStats`. A constrained extension now publishes + one `ConstraintBatchResult` through `constrainedExtensionConstraintBatch`, + read with `constraintBatchTriangulation`, `constraintBatchOutcomes` and + `constraintBatchStats`; `constrainedExtensionBuildStats` is unchanged. The + batch is the same value `recoverConstraints` returns, so extension and + standalone recovery are now read through one accessor set instead of two. +* Withdraw the aggregator modules `Moonlight.Triangulation.Handles`, + `Moonlight.Triangulation.Handles.Iterators` and + `Moonlight.Triangulation.Internal.DcelOperations` from the exposed module + list. Every leaf they re-exported remains exposed under its own name; import + the leaf. +* Add `BoundaryOrientation`, `boundaryLoopOrientation` and + `componentBoundaryLoops`, so a face component publishes all of its boundary + loops with each loop's orientation rather than only the outer one. +* Add `planarValuationsPerimeter`, the certified perimeter of a planar region + taken directly from its valuations. +* Advance the C boundary to ABI version 2 with opaque exact-region and reusable + structuring-element handles, one-call bulk authoring/projection, exact region + union/intersection/difference/symmetric difference, point location, exact + area plus Euler and certified perimeter observations, and existing polygonal + Minkowski morphology with fixed-width receipts. +* Rename the former mesh Boolean symbols and Python, TypeScript, and Rust + methods to `site_*`; they combine Delaunay site sets and are deliberately not + compatibility aliases for the new polygonal region operations. +* Restore `-O0` for ordinary test bodies while retaining the filtered-predicate + allocation witness at module-local `-O1`. +* Move the existing exact Overlay/Minkowski implementations from the `build` + sublibrary into the main library and move `HintGenerator` from `dual` into + that same apex owner. The `dual` sublibrary is now dcel-only and can compile + concurrently with `build`; direct `:dual` consumers of `HintGenerator` must + depend on the main library instead. No geometry type or runtime operation is + duplicated. +* Reserve the planar DCEL bound rather than the general one when joining two + separated triangulations. The separated seam copies two planar sources and + then only adds, so its peak is its published result; the general reservation + was a third again as much arena as the merge can ever reach. Measured at + twenty thousand sites over twenty-one processes per arm, the separated join + lanes fall 36.4% to 41.3% in allocation and 10.2% to 22.0% in elapsed time, + with every unaffected lane byte-identical. +* Stop materializing an intermediate validated vector in `mesh_insert_many_f64`. + Admission is unchanged — a malformed point anywhere still refuses the whole + batch before any insertion — but the canonical coordinate is now applied + where the point is used. Against a fifty-thousand-site mesh, allocation falls + 5.3% at a thousand added points and 26.5% at fifty thousand; wall time is + unmoved, because geometric insertion, not admission, is the critical path. + ## 1.2.0.1 * Admit GHC 9.8 as a tested compiler by spelling the package language as diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -36,6 +36,7 @@ | `cellValuations` / `regionValuations` | intrinsic measurement | Exact Euler characteristic and rational area plus symbolic radical length with certified bounds. | | `minkowskiSum` | polygonal convolution | Exact convex or general polygonal Minkowski addition, with work recorded in a receipt. | | `erodeBy` / `openWith` / `closeWith` | regularized morphology | Full-dimensional polygonal erosion and its opening/closing compositions for an origin-anchored convex kernel. | +| `fromExactCellSet` | topology interpretation | An opaque `DCELComplex` view of the already-admitted cell inventory; no mesh copy or second validation authority. | ### Choose the operation @@ -70,16 +71,55 @@ | Keep Delaunay faces below an alpha threshold | `alphaShapeContainsFace threshold mesh` | This is the filled-face filtration, not palette logic and not a claim to expose every simplex of a full alpha-complex carrier. | | Require construction-independent numbering | `canonicalize` at the observation boundary | Do not canonicalize every intermediate value; it is intentionally global work. | +### Cell-complex and category interpretation + +The `cell-complex` component interprets an `ExactCellSet` as +Homology's generic `CellComplex2D`. The carrier is opaque and retains the +authoritative selected handles and resident DCEL; `fromExactCellSet` is total +because `ExactCellSet` construction has already discharged downward closure and +handle validity. + +The interpretation is available on GHC 9.14 and newer. Existing Triangulation +components retain the package's GHC 9.8–9.14 support range: below 9.14 Cabal +marks only `cell-complex`, its focused test, and the category-observatory +exporter unbuildable. Hackage aggregates dependencies from every component on +the package page, but an ordinary main-library consumer does not inherit the +Homology or Category closure. + +```cabal +-- the consumer package +build-depends: + moonlight-triangulation:cell-complex >= 1.3 && < 1.4, + moonlight-homology:cell-category >= 0.1 && < 0.2 +``` + +```haskell +import Moonlight.Homology.Pure.Topology.CellCategory (complexCategory) +import Moonlight.Triangulation.CellComplex (fromExactCellSet) + +incidenceCategory = complexCategory . fromExactCellSet +``` + +`moonlight-triangulation-category-observatory-export` is the executable witness: +it constructs a real Delaunay mesh, selects its bounded cells, derives the finite +incidence category and normalized nerve, validates their overlap counts, and emits +only the checked visualization projection. + ## Foreign bindings The `moonlight-triangulation-c` foreign-library component exposes opaque -immutable geometry meshes, batch insertion, finite-set operations, and dense -vertex and triangle projections through one versioned C ABI. Python, -TypeScript, and Rust bindings live beneath [`bindings/`](bindings/README.md) -and descend through that same ABI; none restates the triangulation engine or -introduces a second mesh representation. +immutable geometry meshes, admitted exact planar regions, and reusable +polygonal structuring elements through ABI version 2. Mesh `site_*` operations +combine Delaunay sites; region operations perform actual polygonal Boolean +selection through the exact overlay owner. Regions cross in one bulk call as +coordinates plus loop/component counts and project back as components, loops, +and binary64 rendering points. Exact area remains lossless as a reduced ratio; +Euler is integral and perimeter carries certified bounds. Python, TypeScript, +and Rust bindings live beneath [`bindings/`](bindings/README.md) and descend +through that same ABI; none restates overlay, publication, valuation, or +morphology. -`union a a` is `a`; commutativity and associativity hold after explicit +For the Haskell mesh algebra, `union a a` is `a`; commutativity and associativity hold after explicit `canonicalize`; and a join adds no sites: the result carries `|A| + |B| − |A ∩ B|` of them. Structural `Eq` remains exact resident equality for caches and serialization rather than secretly rebuilding the mesh. @@ -103,19 +143,54 @@ | `extendConstrainedWith` | Copy-on-write only for a base of at least 200,000 sites, at most 128 incoming sites, exactly one incoming segment, and a pre-thaw corridor with no resident intersection. Every unmeasured or resident-corridor case stays dense. | | `refineWithinDomain` | Dense publication. The local transaction candidate preserved semantics but did not improve wall time, so it was removed. | -### Benchmark highlights +### Overall Moonlight–Spade comparison -Fresh source build on 2026-08-12. The comparison binaries passed exact -canonical-output agreement before seven interleaved fresh-process timing -rounds; brackets are the observed range. Lower is better. +The overall referent is broader than the construction board below. Its live +inventory contains 17 parity lanes and eight diagnostic cliff lanes. Every +timing descends through its declared artifact gate first: cross-language +canonical equality where the result is unique, and pinned per-side artifacts +where valid refinement or floating-point accumulation may differ. -| Operation | Workload | Moonlight | Spade 2.15.1 | Result | -| --- | ---: | ---: | ---: | ---: | -| Removal | remove 125k / 500k sites | 522.067 ms [514.481–539.392] | 16.576 s [15.304–17.308] | **31.75× faster** | -| Removal | remove 25k / 100k sites | 72.164 ms [67.604–78.116] | 360.899 ms [264.639–406.783] | **5.00× faster** median | -| Natural-neighbour interpolation | 2k queries / 400k sites | 192.792 ms [178.064–201.805] | 233.688 ms [214.695–250.986] | **1.21× faster** | -| Incremental insertion | 500k sites | 33.403 s [32.592–36.813] | 30.506 s [28.809–31.688] | within **1.09×** | +| Surface | Parity workloads | +| --- | --- | +| Construction | bulk load at 1k and 10k sites; incremental insertion at 1k, 10k, and 500k sites | +| Search and dual | 5k nearest-neighbour queries over 20k sites; Voronoi dual sweep over 1k sites; DCEL traversal over 2k sites | +| Constraints | recover 800 constraints over 8k sites; refine with 625 and 2,500 Steiner-site budgets | +| Persistent update | remove 250 / 1k, 2.5k / 10k, and 25k / 100k sites | +| Natural-neighbour interpolation | 1k queries over 10k sites; 2k queries over 100k sites | +| Segment traversal | 500 line intersections over 10k sites | +The eight diagnostic lanes cover one-at-a-time constraint recovery, constraint +splitting, hierarchy insertion, duplicate insertion, hierarchy removal, +single-angle sweep collapse, exactly collinear construction with face-less +location, and line intersection from outside the hull. They expose known +complexity cliffs; they are not omitted merely because the numbers are ugly. + +The package-owned [operation suite](bench/spade-compare/README.md) documents the +complete inventory, semantic descent, timing protocol, and evidence rules. Its +`scorecard.sh` entry point consumes the closed Haskell lane registry directly; +`list` exposes the operation surface, while only a complete, attributable +`refresh` may create a retained performance board. + +```console +compiler/foundation/moonlight-triangulation/bench/spade-compare/scorecard.sh list +compiler/foundation/moonlight-triangulation/bench/spade-compare/scorecard.sh check +``` + +### Package-owned Delaunay construction board + +The Haskell-owned port of Spade's construction matrix lives with the +triangulation library at [`bench/delaunay-compare`](bench/delaunay-compare/README.md). +It appends Moonlight to Spade, Spade hierarchy, `cdt`, and `delaunator`, checks +all 24 fixture summaries across all five implementations before timing, and +derives both pictures from the retained 120-case CSV. + +![Moonlight Delaunay construction over the small Spade fixtures](https://raw.githubusercontent.com/PaleRoses/moonlight/main/moonlight-triangulation/bench/delaunay-compare/results/moonlight-delaunay-compare-small.svg) + +The [benchmark README](bench/delaunay-compare/README.md) owns the single +retained board, its result, receipt, big-point picture, and reproduction +procedure. This package overview does not maintain a second benchmark history. + Spade exposes no public triangulation set algebra corresponding to these operations. Their independently witnessed Moonlight publication costs are: @@ -199,10 +274,11 @@ * One half-edge mesh underneath. `Cdt` is a mode index on it, not a second structure. -The Haskell facade carries the exact region, overlay, valuation, and morphology -algebra. `ExactCellSet` preserves closed point, edge, and face selections; -`PlanarRegion` is its full-dimensional polygonal publication. The C ABI and -Python, TypeScript, and Rust bindings carry the immutable binary64 mesh surface. +The Haskell facade is the authority for exact region, overlay, valuation, and +morphology. `ExactCellSet` preserves closed point, edge, and face selections; +`PlanarRegion` is its full-dimensional polygonal publication. ABI version 2 +retains that admitted region behind an opaque handle; foreign binary64 points +are authoring/rendering boundaries, not a competing exact representation. ## Use @@ -517,11 +593,34 @@ | --- | --- | | `core` | Exact-arithmetic scalars (`Scalar`, `LineSideInfo`) over paged, copy-on-write storage (`Internal.Dyadic`, `.Paged`, `.BoxedPaged`, `.PageDirectory`, `.Growable`, `.PackedIndex`, `.FaceQueue`). Depends only on `base`/`containers`/`deepseq`/`vector` — no other sublibrary. | | `dcel` | The finite half-edge mesh and its whole read surface: `Types`, `Math`, exact geometry, closed `CellSet`, `Region`, `Valuation`, `Interop`, `Dcel`, `Payload`, `JoinSemilattice`, `Handles` with its iterator family, `PointLocation`, `Validation`, `FloodFillIterator`, `IntersectionIterator`. Adds `primitive` and `vector-algorithms` over `core`. | -| `build` | Everything that *constructs*: `BulkLoad`, `Session`, `Removal`, typed `SetAlgebra`, `Cdt` constraint recovery, `Overlay`, `Minkowski`, and `Refinement`. Adds no external dependency over `core` and `dcel`. | +| `build` | The construction kernel: `BulkLoad`, `Session`, `Removal`, typed `SetAlgebra`, `Cdt` constraint recovery, and `Refinement`. Adds no external dependency over `core` and `dcel`. | | `parallel` | Concurrent evaluation of the pure union plan. Adds `async` at this effect boundary rather than below it. | | `serialize` | `Serialization` — the versioned binary envelope, and the only sublibrary that costs you `binary`, `bytestring`, and `transformers`. Deliberately absent from the facade. | -| `dual` | The Voronoi dual and what reads it: `Voronoi`, `Voronoi.Handles`, `Interpolation` (natural-neighbour), `HintGenerator` (Delaunay hierarchy hints). Sits over `core`, `dcel` and `build`. | -| facade (`moonlight-triangulation`) | `Moonlight.Triangulation` alone: the equational surface, one export list stating a theory. It re-exports selected names from `core`/`dcel`/`build`/`dual` — and *not* `serialize`. A caller who wants more than the theory names the machine-room module directly. | +| `dual` | The dcel-only Voronoi dual and its readers: `Voronoi`, `Voronoi.Handles`, and `Interpolation` (natural-neighbour). It can compile concurrently with `build`. | +| facade (`moonlight-triangulation`) | The equational surface plus the two real overlaps: exact `Overlay`/`Minkowski` operations that descend through `build`, and `HintGenerator`, which glues construction to the dual. It re-exports the theory and deliberately excludes `serialize`; there is no duplicate facade implementation beneath it. | + +### Fast local feedback + +Run exact components through the repository build guard so a local edit never +silently expands into the complete package. From the repository's `compiler/` +directory, the optimized construction kernel is: + + ../scripts/safe-cabal.sh build moonlight-triangulation:lib:build \ + --project-file=cabal.project.triangulation-dev \ + --builddir=dist-newstyle-triangulation-dev + +For type-and-interface feedback where no benchmarkable artifact is required, +use the same component and cache at `-O0`: + + ../scripts/safe-cabal.sh build moonlight-triangulation:lib:build \ + --project-file=cabal.project.triangulation-dev \ + --builddir=dist-newstyle-triangulation-fast \ + --disable-optimization + +The full facade is still an admitted five-component closure. Release and +runtime claims use the optimized profile; the `-O0` command is deliberately a +different feedback workload, not counterfeit evidence of a faster production +build. ## Surface diff --git a/app/category-observatory/Main.hs b/app/category-observatory/Main.hs new file mode 100644 --- /dev/null +++ b/app/category-observatory/Main.hs @@ -0,0 +1,562 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Main (main) where + +import Data.Aeson (ToJSON) +import Data.Aeson qualified as Aeson +import Data.Bifunctor (first) +import Data.ByteString.Lazy.Char8 qualified as LazyByteString +import Data.Containers.ListUtils (nubOrd) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Vector qualified as Vector +import GHC.Generics (Generic) +import Moonlight.Homology.Pure.Topology.CellCategory + ( ComplexCat, + ComplexMor (..), + ComplexOb (..), + complexCategory, + ) +import Moonlight.Triangulation.CellComplex + ( DCELComplex, + fromExactCellSet, + ) +import Moonlight.Category + ( Category (..), + FiniteComposableCategory (..), + chainVertices, + ) +import Moonlight.Category.Simplicial + ( GeneratedSSet, + NerveSimplex, + TruncatedNormalizedSSet, + generatedSimplicesAtDimension, + nerveSimplexChain, + normalizedNerve, + simplicesAtDimension, + unnormalizedNerve, + ) +import Moonlight.Homology.Pure.Topology.CellComplex + ( CellComplex2D (..), + CellTypes (..), + OrientedEdge (..), + ) +import Moonlight.Triangulation.BulkLoad (delaunayGeometry) +import Moonlight.Triangulation.CellSet + ( CellSelectionError, + ExactCellSet, + closeFaceCellSet, + exactCellSetEdgeCount, + exactCellSetFaceCount, + exactCellSetVertexCount, + ) +import Moonlight.Triangulation.Dcel + ( faceVertices, + undirectedEndpoints, + vertexPoint, + ) +import Moonlight.Triangulation.Handles.HandleDefs + ( FaceId, + UndirectedEdgeId, + VertexId, + unFaceId, + unUndirectedEdgeId, + unVertexId, + ) +import Moonlight.Triangulation.Handles.Iterators.FixedIterators (innerFaces) +import Moonlight.Triangulation.Types + ( BuildError, + DelaunayTriangulation, + Point (..), + ) +import Numeric.Natural (Natural) +import System.Exit (die) + +main :: IO () +main = + either + (die . renderExhibitError) + (LazyByteString.putStrLn . Aeson.encode) + buildExhibit + +data ExhibitError + = ExhibitTriangulationBuildFailed BuildError + | ExhibitCellSelectionFailed CellSelectionError + | ExhibitMorphismEndpointUnavailable MorphismEndpoint Int + | ExhibitFaceWithoutVertices FaceId + | ExhibitMalformedTwoSimplex Int + | ExhibitInventoryMismatch (Int, Int, Int) (Int, Int, Int) + | ExhibitCategoryEnumerationMismatch (Int, Int, Int, Int) (Int, Int, Int, Int) + | ExhibitNerveCountMismatch Int Int + deriving stock (Show) + +data MorphismEndpoint + = MorphismSource + | MorphismTarget + deriving stock (Show) + +renderExhibitError :: ExhibitError -> String +renderExhibitError = show + +data Exhibit = Exhibit + { schemaVersion :: Int, + exhibitTitle :: String, + mesh :: MeshProjection, + category :: CategoryProjection, + nerve :: NerveProjection + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data MeshProjection = MeshProjection + { meshVertices :: [MeshVertex], + meshEdges :: [MeshEdge], + meshFaces :: [MeshFace] + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data MeshVertex = MeshVertex + { meshVertexIdentifier :: String, + meshVertexObjectIdentifier :: String, + meshVertexPosition :: Position + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data MeshEdge = MeshEdge + { meshEdgeIdentifier :: String, + meshEdgeObjectIdentifier :: String, + meshEdgeVertexIdentifiers :: [String] + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data MeshFace = MeshFace + { meshFaceIdentifier :: String, + meshFaceObjectIdentifier :: String, + meshFaceVertexIdentifiers :: [String] + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data Position = Position + { positionX :: Double, + positionY :: Double + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data CategoryProjection = CategoryProjection + { categoryObjects :: [CategoryObject], + categoryMorphisms :: [CategoryMorphism] + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data CategoryObject = CategoryObject + { categoryObjectIdentifier :: String, + categoryObjectKind :: CategoryObjectKind, + categoryObjectLabel :: String, + categoryObjectPosition :: Position + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data CategoryObjectKind + = VertexObject + | EdgeObject + | FaceObject + deriving stock (Generic) + deriving anyclass (ToJSON) + +data CategoryMorphism = CategoryMorphism + { categoryMorphismIdentifier :: String, + categoryMorphismKind :: CategoryMorphismKind, + categoryMorphismSourceObject :: String, + categoryMorphismTargetObject :: String + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data CategoryMorphismKind + = IdentityMorphism + | FaceEdgeMorphism + | EdgeVertexMorphism + | FaceVertexComposite + deriving stock (Generic) + deriving anyclass (ToJSON) + +data NerveProjection = NerveProjection + { nerveTwoSimplices :: [NerveTwoSimplex], + nerveSimplexCounts :: [NerveSimplexCount] + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data NerveSimplexCount = NerveSimplexCount + { nerveDimension :: Natural, + normalizedSimplexCount :: Int, + unnormalizedSimplexCount :: Int + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +data NerveTwoSimplex = NerveTwoSimplex + { nerveSimplexIdentifier :: String, + nerveSimplexObjectIdentifiers :: [String] + } + deriving stock (Generic) + deriving anyclass (ToJSON) + +buildExhibit :: Either ExhibitError Exhibit +buildExhibit = do + triangulation <- first ExhibitTriangulationBuildFailed (delaunayGeometry exhibitPoints) + selectedCells <- + first ExhibitCellSelectionFailed + (closeFaceCellSet triangulation (innerFaces triangulation)) + let complexValue = fromExactCellSet selectedCells + categoryValue = complexCategory complexValue + validateInventory selectedCells complexValue + validateCategoryEnumeration complexValue categoryValue + categoryProjection <- projectCategory triangulation categoryValue + nerveProjection <- projectNerve categoryValue + validateNerveCount complexValue nerveProjection + pure + Exhibit + { schemaVersion = 2, + exhibitTitle = "Triangulation, incidence category, and flag nerve", + mesh = projectMesh triangulation complexValue, + category = categoryProjection, + nerve = nerveProjection + } + +validateInventory :: ExactCellSet -> DCELComplex -> Either ExhibitError () +validateInventory cellSet complexValue = + let expectedCounts = + ( exactCellSetVertexCount cellSet, + exactCellSetEdgeCount cellSet, + exactCellSetFaceCount cellSet + ) + observedCounts = + ( length (vertices complexValue), + length (edges complexValue), + length (faces complexValue) + ) + in if observedCounts == expectedCounts + then Right () + else Left (ExhibitInventoryMismatch expectedCounts observedCounts) + +validateCategoryEnumeration :: + DCELComplex -> + ComplexCat DCELComplex -> + Either ExhibitError () +validateCategoryEnumeration complexValue categoryValue = + let morphisms = enumerateMorphisms categoryValue + expectedCounts = + ( length (vertices complexValue) + length (edges complexValue) + length (faces complexValue), + sum (fmap (length . faceBoundary complexValue) (faces complexValue)), + sum (fmap (edgeEndpointCount complexValue) (edges complexValue)), + sum (fmap (faceFlagCount complexValue) (faces complexValue)) + ) + observedCounts = + ( length (filter isIdentityMorphism morphisms), + length (filter isFaceEdgeMorphism morphisms), + length (filter isEdgeVertexMorphism morphisms), + length (filter isFaceVertexMorphism morphisms) + ) + in if observedCounts == expectedCounts + then Right () + else Left (ExhibitCategoryEnumerationMismatch expectedCounts observedCounts) + +validateNerveCount :: DCELComplex -> NerveProjection -> Either ExhibitError () +validateNerveCount complexValue nerveProjection = + let expectedCount = sum (fmap (faceFlagCount complexValue) (faces complexValue)) + observedCount = length (nerveTwoSimplices nerveProjection) + in if observedCount == expectedCount + then Right () + else Left (ExhibitNerveCountMismatch expectedCount observedCount) + +edgeEndpointCount :: DCELComplex -> Edge DCELComplex -> Int +edgeEndpointCount complexValue edgeValue = + let (sourceVertex, targetVertex) = edgeBoundary complexValue edgeValue + in length (nubOrd [sourceVertex, targetVertex]) + +faceFlagCount :: DCELComplex -> Face DCELComplex -> Int +faceFlagCount complexValue faceValue = + sum + ( fmap + (edgeEndpointCount complexValue . orientedEdge) + (faceBoundary complexValue faceValue) + ) + +isIdentityMorphism :: ComplexMor DCELComplex -> Bool +isIdentityMorphism morphismValue = + case morphismValue of + IdentityMor _ -> True + _ -> False + +isFaceEdgeMorphism :: ComplexMor DCELComplex -> Bool +isFaceEdgeMorphism morphismValue = + case morphismValue of + FaceToEdge _ _ _ -> True + _ -> False + +isEdgeVertexMorphism :: ComplexMor DCELComplex -> Bool +isEdgeVertexMorphism morphismValue = + case morphismValue of + EdgeToVertex _ _ -> True + _ -> False + +isFaceVertexMorphism :: ComplexMor DCELComplex -> Bool +isFaceVertexMorphism morphismValue = + case morphismValue of + FaceToVertex _ _ _ -> True + _ -> False + +projectMesh :: DelaunayTriangulation () -> DCELComplex -> MeshProjection +projectMesh triangulation complexValue = + MeshProjection + { meshVertices = fmap (projectMeshVertex triangulation) (vertices complexValue), + meshEdges = fmap (projectMeshEdge triangulation) (edges complexValue), + meshFaces = fmap (projectMeshFace triangulation) (faces complexValue) + } + +projectMeshVertex :: DelaunayTriangulation () -> VertexId -> MeshVertex +projectMeshVertex triangulation vertexValue = + MeshVertex + { meshVertexIdentifier = vertexIdentifier vertexValue, + meshVertexObjectIdentifier = vertexObjectIdentifier vertexValue, + meshVertexPosition = pointPosition (vertexPoint triangulation vertexValue) + } + +projectMeshEdge :: DelaunayTriangulation () -> UndirectedEdgeId -> MeshEdge +projectMeshEdge triangulation edgeValue = + let (sourceVertex, targetVertex) = undirectedEndpoints triangulation edgeValue + in MeshEdge + { meshEdgeIdentifier = edgeIdentifier edgeValue, + meshEdgeObjectIdentifier = edgeObjectIdentifier edgeValue, + meshEdgeVertexIdentifiers = fmap vertexIdentifier [sourceVertex, targetVertex] + } + +projectMeshFace :: DelaunayTriangulation () -> FaceId -> MeshFace +projectMeshFace triangulation faceValue = + MeshFace + { meshFaceIdentifier = faceIdentifier faceValue, + meshFaceObjectIdentifier = faceObjectIdentifier faceValue, + meshFaceVertexIdentifiers = fmap vertexIdentifier (faceVertices triangulation faceValue) + } + +projectCategory :: + DelaunayTriangulation () -> + ComplexCat DCELComplex -> + Either ExhibitError CategoryProjection +projectCategory triangulation categoryValue = do + objectProjections <- + traverse + (projectCategoryObject triangulation) + (enumerateObjects categoryValue) + morphismProjections <- + traverse + (projectCategoryMorphism categoryValue) + (zip [0 ..] (enumerateMorphisms categoryValue)) + pure + CategoryProjection + { categoryObjects = objectProjections, + categoryMorphisms = morphismProjections + } + +projectCategoryObject :: + DelaunayTriangulation () -> + ComplexOb DCELComplex -> + Either ExhibitError CategoryObject +projectCategoryObject triangulation objectValue = do + objectPosition <- positionForObject triangulation objectValue + pure + CategoryObject + { categoryObjectIdentifier = objectIdentifier objectValue, + categoryObjectKind = objectKind objectValue, + categoryObjectLabel = objectLabel objectValue, + categoryObjectPosition = objectPosition + } + +projectCategoryMorphism :: + ComplexCat DCELComplex -> + (Int, ComplexMor DCELComplex) -> + Either ExhibitError CategoryMorphism +projectCategoryMorphism categoryValue (morphismIndex, morphismValue) = do + sourceObject <- + first + (const (ExhibitMorphismEndpointUnavailable MorphismSource morphismIndex)) + (source categoryValue morphismValue) + targetObject <- + first + (const (ExhibitMorphismEndpointUnavailable MorphismTarget morphismIndex)) + (target categoryValue morphismValue) + pure + CategoryMorphism + { categoryMorphismIdentifier = "morphism-" <> show morphismIndex, + categoryMorphismKind = morphismKind morphismValue, + categoryMorphismSourceObject = objectIdentifier sourceObject, + categoryMorphismTargetObject = objectIdentifier targetObject + } + +projectNerve :: ComplexCat DCELComplex -> Either ExhibitError NerveProjection +projectNerve categoryValue = do + let normalizedNerveValue = normalizedNerve categoryValue nerveObservationBound + unnormalizedNerveValue = unnormalizedNerve categoryValue nerveObservationBound + twoSimplices <- + traverse + projectTwoSimplex + (zip [0 ..] (simplicesAtDimension normalizedNerveValue nerveObservationBound)) + pure + NerveProjection + { nerveTwoSimplices = twoSimplices, + nerveSimplexCounts = + fmap + (projectNerveSimplexCount normalizedNerveValue unnormalizedNerveValue) + nerveObservationDimensions + } + +nerveObservationBound :: Natural +nerveObservationBound = 2 + +nerveObservationDimensions :: [Natural] +nerveObservationDimensions = [0, 1, 2] + +projectNerveSimplexCount :: + TruncatedNormalizedSSet (NerveSimplex (ComplexCat DCELComplex)) -> + GeneratedSSet (NerveSimplex (ComplexCat DCELComplex)) -> + Natural -> + NerveSimplexCount +projectNerveSimplexCount normalizedNerveValue unnormalizedNerveValue dimensionValue = + NerveSimplexCount + { nerveDimension = dimensionValue, + normalizedSimplexCount = length (simplicesAtDimension normalizedNerveValue dimensionValue), + unnormalizedSimplexCount = length (generatedSimplicesAtDimension unnormalizedNerveValue dimensionValue) + } + +projectTwoSimplex :: + (Int, NerveSimplex (ComplexCat DCELComplex)) -> + Either ExhibitError NerveTwoSimplex +projectTwoSimplex (simplexIndex, simplexValue) = + case chainVertices (nerveSimplexChain simplexValue) of + faceObject :| [edgeObject, vertexObject] -> + pure + NerveTwoSimplex + { nerveSimplexIdentifier = "simplex-" <> show simplexIndex, + nerveSimplexObjectIdentifiers = + fmap objectIdentifier [faceObject, edgeObject, vertexObject] + } + _ -> Left (ExhibitMalformedTwoSimplex simplexIndex) + +positionForObject :: + DelaunayTriangulation () -> + ComplexOb DCELComplex -> + Either ExhibitError Position +positionForObject triangulation objectValue = + case objectValue of + VertexOb vertexValue -> + Right (pointPosition (vertexPoint triangulation vertexValue)) + EdgeOb edgeValue -> + let (sourceVertex, targetVertex) = undirectedEndpoints triangulation edgeValue + in Right + ( midpoint + (pointPosition (vertexPoint triangulation sourceVertex)) + (pointPosition (vertexPoint triangulation targetVertex)) + ) + FaceOb faceValue -> + centroid faceValue + (fmap (pointPosition . vertexPoint triangulation) (faceVertices triangulation faceValue)) + +centroid :: FaceId -> [Position] -> Either ExhibitError Position +centroid faceValue positions = + case positions of + [] -> Left (ExhibitFaceWithoutVertices faceValue) + _ -> + let (totalX, totalY) = + foldl' + (\(accumulatedX, accumulatedY) positionValue -> + ( accumulatedX + positionX positionValue, + accumulatedY + positionY positionValue + ) + ) + (0, 0) + positions + positionCount = fromIntegral (length positions) + in Right (Position (totalX / positionCount) (totalY / positionCount)) + +midpoint :: Position -> Position -> Position +midpoint firstPosition secondPosition = + Position + { positionX = (positionX firstPosition + positionX secondPosition) / 2, + positionY = (positionY firstPosition + positionY secondPosition) / 2 + } + +pointPosition :: Point -> Position +pointPosition pointValue = + Position + { positionX = pointX pointValue, + positionY = pointY pointValue + } + +objectIdentifier :: ComplexOb DCELComplex -> String +objectIdentifier objectValue = + case objectValue of + VertexOb vertexValue -> vertexObjectIdentifier vertexValue + EdgeOb edgeValue -> edgeObjectIdentifier edgeValue + FaceOb faceValue -> faceObjectIdentifier faceValue + +objectKind :: ComplexOb DCELComplex -> CategoryObjectKind +objectKind objectValue = + case objectValue of + VertexOb _ -> VertexObject + EdgeOb _ -> EdgeObject + FaceOb _ -> FaceObject + +objectLabel :: ComplexOb DCELComplex -> String +objectLabel objectValue = + case objectValue of + VertexOb vertexValue -> "v" <> show (unVertexId vertexValue) + EdgeOb edgeValue -> "e" <> show (unUndirectedEdgeId edgeValue) + FaceOb faceValue -> "f" <> show (unFaceId faceValue) + +morphismKind :: ComplexMor DCELComplex -> CategoryMorphismKind +morphismKind morphismValue = + case morphismValue of + IdentityMor _ -> IdentityMorphism + FaceToEdge _ _ _ -> FaceEdgeMorphism + EdgeToVertex _ _ -> EdgeVertexMorphism + FaceToVertex _ _ _ -> FaceVertexComposite + +vertexIdentifier :: VertexId -> String +vertexIdentifier vertexValue = "vertex-" <> show (unVertexId vertexValue) + +edgeIdentifier :: UndirectedEdgeId -> String +edgeIdentifier edgeValue = "edge-" <> show (unUndirectedEdgeId edgeValue) + +faceIdentifier :: FaceId -> String +faceIdentifier faceValue = "face-" <> show (unFaceId faceValue) + +vertexObjectIdentifier :: VertexId -> String +vertexObjectIdentifier vertexValue = "object-" <> vertexIdentifier vertexValue + +edgeObjectIdentifier :: UndirectedEdgeId -> String +edgeObjectIdentifier edgeValue = "object-" <> edgeIdentifier edgeValue + +faceObjectIdentifier :: FaceId -> String +faceObjectIdentifier faceValue = "object-" <> faceIdentifier faceValue + +exhibitPoints :: Vector.Vector Point +exhibitPoints = + Vector.fromList + [ Point 80 72, + Point 222 48, + Point 362 92, + Point 52 208, + Point 176 166, + Point 310 190, + Point 414 232, + Point 112 330, + Point 258 314, + Point 380 354 + ] diff --git a/bench/build/Moonlight/Triangulation/BuildBench.hs b/bench/build/Moonlight/Triangulation/BuildBench.hs --- a/bench/build/Moonlight/Triangulation/BuildBench.hs +++ b/bench/build/Moonlight/Triangulation/BuildBench.hs @@ -18,12 +18,13 @@ import qualified Data.Vector as V import Moonlight.Triangulation import Moonlight.Triangulation.BulkLoad (empty, insert) -import Moonlight.Triangulation.Cdt (constraintBatchStats, recoverConstraints) +import Moonlight.Triangulation.Cdt (recoverConstraints) +import Moonlight.Triangulation.Foreign.ABI (insertGeometryBatch) -- The facade withholds this constructor. The benchmark indexes the builder's -- own input mapping, so every handle it forges is one the builder issued, and -- it owns that obligation explicitly by naming the module that grants it. import Moonlight.Triangulation.Handles.HandleDefs (VertexId (VertexId)) -import Moonlight.Triangulation.Session (insertVertex, withLocalSession, withSession) +import Moonlight.Triangulation.Session (insertVertex, insertVertexAt, withLocalSession, withSession) import Moonlight.Triangulation.Types ( InsertionResult (insertionTriangulation) , refinementStats @@ -38,9 +39,38 @@ putStrLn "moonlight-triangulation native construction benchmark" forM_ [1_000, 10_000, 50_000] benchmarkConstruction forM_ [1_000, 10_000, 50_000, 100_000, 1_000_000] benchmarkSingletonInsertionCrossover - benchmarkConstraints 8_000 800 + forM_ [(50_000, 1_000), (50_000, 10_000), (50_000, 50_000)] benchmarkGeometryBatchInsertion + benchmarkConstraints benchmarkRefinement 2_500 +-- | What the geometry-only foreign batch entrance costs against the session +-- insertion it is built out of. The two arms differ by exactly one thing: the +-- ABI route validates every point into an intermediate boxed vector before it +-- opens the session, and the session arm receives the same points with that +-- pass already paid. Their difference is therefore the price of admission, +-- and it is the number that decides whether a fused geometry entrance is worth +-- designing at all. Inserting into an existing mesh is not the law of fresh +-- circle sweep, so nothing here transfers from the construction lanes above. +benchmarkGeometryBatchInsertion :: (Int, Int) -> IO () +benchmarkGeometryBatchInsertion (baseCount, addedCount) = do + let label suffix = "geometry-batch-" <> suffix <> "/" <> show baseCount <> "+" <> show addedCount + basePoints = V.fromList (randomPoints 0x9e3779b97f4a7c15 baseCount) + addedPoints = V.fromList (randomPoints 0xbf58476d1ce4e5b9 addedCount) + base <- evaluate . force =<< requireRight (delaunayGeometry basePoints) + _ <- evaluate (force addedPoints) + admitted <- timedValue (label "abi") $ requireRight (insertGeometryBatch base addedPoints) + (_, sessioned, _) <- timedValue (label "session") $ + requireRight + ( withSession base (V.length addedPoints) $ + V.mapM_ (\point -> () <$ insertVertexAt point ()) addedPoints + ) + admittedCanonical <- requireRight (canonicalize admitted) + sessionedCanonical <- requireRight (canonicalize sessioned) + equal <- evaluate (force (admittedCanonical == sessionedCanonical)) + unless equal $ + fail (label "witness" <> ": the admitted and session arms disagree") + putStrLn (label "witness" <> ": ok") + benchmarkConstruction :: Int -> IO () benchmarkConstruction count = do let points = V.fromList (randomPoints 0x9e3779b97f4a7c15 count) @@ -74,8 +104,10 @@ fail ("scheduled and local singleton insertion disagree semantically at " <> show count <> " sites") putStrLn ("singleton-insertion-crossover/" <> show count <> "-semantic-witness: ok") -benchmarkConstraints :: Int -> Int -> IO () -benchmarkConstraints pointCount constraintCount = do +benchmarkConstraints :: IO () +benchmarkConstraints = do + let pointCount = 8_000 + constraintCount = 800 built <- requireRight (delaunay unitElementDefaults (V.fromList (randomPoints 0x94d049bb133111eb pointCount))) let cdt = fromDelaunay (buildTriangulation built) inputMapping = buildInputVertices built @@ -83,7 +115,7 @@ V.fromList ( take constraintCount [ (a, b) - | index <- [0 ..] + | index <- [0 .. pointCount * constraintCount - 1] , let a = index `mod` pointCount b = (index * 6151 + pointCount `quot` 2) `mod` pointCount , a /= b diff --git a/bench/delaunay-compare/Main.hs b/bench/delaunay-compare/Main.hs new file mode 100644 --- /dev/null +++ b/bench/delaunay-compare/Main.hs @@ -0,0 +1,27 @@ +-- | Haskell owner of the upstream-compatible construction comparison. +module Main (main) where + +import Moonlight.Triangulation.Bench.DelaunayCompare.Domain (renderCompareObstruction) +import Moonlight.Triangulation.Bench.DelaunayCompare.Native (withNativeApi) +import Moonlight.Triangulation.Bench.DelaunayCompare.Suite + ( preflightSuite + , suiteAgreementMessage + , suiteBenchmarks + , withPreparedSuite + ) +import System.Exit (die) +import Test.Tasty.Bench (defaultMain) + +main :: IO () +main = do + outcome <- + withNativeApi $ \api -> + withPreparedSuite api $ \suite -> do + agreement <- preflightSuite api suite + case agreement of + Left obstruction -> pure (Left obstruction) + Right () -> do + putStrLn suiteAgreementMessage + defaultMain (suiteBenchmarks api suite) + pure (Right ()) + either (die . renderCompareObstruction) pure outcome diff --git a/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Domain.hs b/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Domain.hs new file mode 100644 --- /dev/null +++ b/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Domain.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} + +-- | The closed case matrix and typed obstruction surface for the comparison. +module Moonlight.Triangulation.Bench.DelaunayCompare.Domain + ( SizeBand (..) + , allSizeBands + , sizeBandLabel + , PointDistribution (..) + , allPointDistributions + , pointDistributionLabel + , Implementation (..) + , allImplementations + , implementationLabel + , NativeImplementation (..) + , nativeImplementationLabel + , implementationOfNative + , PointCount + , pointCountValue + , pointCountsFor + , FixtureSpec (..) + , allFixtureSpecs + , DelaunaySummary (..) + , NativeStatus (..) + , NativePreparationFailure (..) + , NativeRunFailure (..) + , CompareObstruction (..) + , renderCompareObstruction + ) where + +import Control.DeepSeq (NFData) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import GHC.Generics (Generic) +import Moonlight.Triangulation.Types (BuildError) + +data SizeBand + = Small + | Big + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +allSizeBands :: [SizeBand] +allSizeBands = [Small, Big] + +sizeBandLabel :: SizeBand -> String +sizeBandLabel = \case + Small -> "small" + Big -> "big" + +data PointDistribution + = LocalInsertion + | Uniform + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +allPointDistributions :: [PointDistribution] +allPointDistributions = [LocalInsertion, Uniform] + +pointDistributionLabel :: PointDistribution -> String +pointDistributionLabel = \case + LocalInsertion -> "local insertion" + Uniform -> "uniform" + +data Implementation + = Spade + | SpadeHierarchy + | Cdt + | Delaunator + | Moonlight + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | Upstream order, with Moonlight appended rather than interposed. +allImplementations :: [Implementation] +allImplementations = [Spade, SpadeHierarchy, Cdt, Delaunator, Moonlight] + +implementationLabel :: Implementation -> String +implementationLabel = \case + Spade -> "spade 2" + SpadeHierarchy -> "spade 2 hierarchy" + Cdt -> "cdt" + Delaunator -> "delaunator" + Moonlight -> "moonlight-triangulation" + +data NativeImplementation + = NativeSpade + | NativeSpadeHierarchy + | NativeCdt + | NativeDelaunator + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +nativeImplementationLabel :: NativeImplementation -> String +nativeImplementationLabel = implementationLabel . implementationOfNative + +implementationOfNative :: NativeImplementation -> Implementation +implementationOfNative = \case + NativeSpade -> Spade + NativeSpadeHierarchy -> SpadeHierarchy + NativeCdt -> Cdt + NativeDelaunator -> Delaunator + +newtype PointCount = PointCount Int + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +pointCountValue :: PointCount -> Int +pointCountValue (PointCount count) = count + +data FixtureSpec = FixtureSpec + { fixtureSizeBand :: !SizeBand + , fixturePointDistribution :: !PointDistribution + , fixturePointCount :: !PointCount + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +allFixtureSpecs :: [FixtureSpec] +allFixtureSpecs = + concatMap + ( \sizeBand -> + liftA2 + (FixtureSpec sizeBand) + allPointDistributions + (pointCountsFor sizeBand) + ) + allSizeBands + +pointCountsFor :: SizeBand -> [PointCount] +pointCountsFor = \case + Small -> PointCount <$> [2_000, 4_000, 6_000, 8_000, 10_000, 12_000, 14_000] + Big -> PointCount <$> [50_000, 100_000, 150_000, 200_000, 250_000] + +data DelaunaySummary = DelaunaySummary + { summaryVertexCount :: !Int + , summaryTriangleCount :: !Int + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +data NativeStatus + = NativeNullPointer + | NativeUnknownTag + | NativeCoordinateCountMismatch + | NativeDistributionConstructionFailed + | NativeTriangulationFailed + | NativePanicked + | NativeUnknownStatus !Int + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +data NativePreparationFailure + = NativePreparationStatus !NativeStatus + | NativePreparationReturnedNull + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +data NativeRunFailure + = NativeRunStatus !NativeStatus + | NativeCountExceedsHaskellInt !Integer + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +data CompareObstruction + = RustManifestNotFound !(NonEmpty FilePath) + | CargoInvocationFailed !FilePath !String + | CargoBuildFailed !FilePath !Int !String + | UnsupportedDynamicLibraryHost !String + | DynamicLibraryOpenFailed !FilePath !String + | DynamicSymbolLoadFailed !FilePath !String !String + | FixtureGenerationFailed !FixtureSpec !NativeStatus + | FixturePreparationFailed !FixtureSpec !NativeImplementation !NativeStatus + | NativePreparedNull !FixtureSpec !NativeImplementation + | MoonlightConstructionFailed !FixtureSpec !BuildError + | NativeConstructionFailed !FixtureSpec !NativeImplementation !NativeRunFailure + | SummaryDisagreement !FixtureSpec !Implementation !DelaunaySummary !DelaunaySummary + | ComparisonObstructions !(NonEmpty CompareObstruction) + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +renderCompareObstruction :: CompareObstruction -> String +renderCompareObstruction = \case + RustManifestNotFound candidates -> + "Rust referent manifest not found; checked " <> show (NonEmpty.toList candidates) + CargoInvocationFailed manifest details -> + "could not invoke Cargo for " <> manifest <> ": " <> details + CargoBuildFailed manifest exitCode details -> + "Cargo failed for " + <> manifest + <> " with exit code " + <> show exitCode + <> if null details then "" else ":\n" <> details + UnsupportedDynamicLibraryHost host -> + "delaunay-compare does not know the dynamic-library suffix for host " <> show host + DynamicLibraryOpenFailed path details -> + "could not load Rust referent library " <> path <> ": " <> details + DynamicSymbolLoadFailed path symbol details -> + "could not load symbol " <> symbol <> " from " <> path <> ": " <> details + FixtureGenerationFailed fixture status -> + "upstream fixture generation failed for " <> renderFixture fixture <> ": " <> show status + FixturePreparationFailed fixture implementation status -> + "native preparation failed for " + <> nativeImplementationLabel implementation + <> " on " + <> renderFixture fixture + <> ": " + <> show status + NativePreparedNull fixture implementation -> + "native preparation returned a null handle for " + <> nativeImplementationLabel implementation + <> " on " + <> renderFixture fixture + MoonlightConstructionFailed fixture buildError -> + "Moonlight construction failed for " <> renderFixture fixture <> ": " <> show buildError + NativeConstructionFailed fixture implementation failure -> + "native construction failed for " + <> nativeImplementationLabel implementation + <> " on " + <> renderFixture fixture + <> ": " + <> show failure + SummaryDisagreement fixture implementation expected observed -> + "construction summary disagreement for " + <> implementationLabel implementation + <> " on " + <> renderFixture fixture + <> "; Moonlight=" + <> show expected + <> ", observed=" + <> show observed + ComparisonObstructions obstructions -> + unlines ("delaunay comparison obstructed:" : fmap ((" - " <>) . renderCompareObstruction) (NonEmpty.toList obstructions)) + +renderFixture :: FixtureSpec -> String +renderFixture fixture = + sizeBandLabel (fixtureSizeBand fixture) + <> "/" + <> pointDistributionLabel (fixturePointDistribution fixture) + <> "/" + <> show (pointCountValue (fixturePointCount fixture)) diff --git a/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Native.hs b/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Native.hs new file mode 100644 --- /dev/null +++ b/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Native.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Resource-safe dynamic boundary to the Rust crates under comparison. +module Moonlight.Triangulation.Bench.DelaunayCompare.Native + ( NativeApi + , NativeFixture + , GeneratedCoordinates + , withNativeApi + , generateCoordinates + , generatedCoordinatePairs + , prepareNativeFixture + , runNativeFixture + , releaseNativeFixture + ) where + +import Control.Exception (IOException, bracket, displayException, try) +import Control.Monad (filterM) +import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) +import Data.Bifunctor (first) +import Data.Int (Int32) +import Data.List (unfoldr) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Moonlight.Triangulation.Bench.DelaunayCompare.Domain +import Foreign.C.Types (CDouble, CInt (..), CSize (..)) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr (FunPtr, Ptr, nullPtr) +import Foreign.Storable (peek, poke) +import qualified Data.Vector as Vector +import qualified Data.Vector.Storable as StorableVector +import qualified Data.Vector.Storable.Mutable as MutableStorableVector +import System.Directory (doesFileExist, makeAbsolute) +import System.Environment (lookupEnv) +import System.Exit (ExitCode (..)) +import System.FilePath ((), takeDirectory) +import System.Info (os) +import System.Posix.DynamicLinker + ( DL + , RTLDFlags (RTLD_LOCAL, RTLD_NOW) + , dlclose + , dlopen + , dlsym + ) +import System.Process + ( CreateProcess (cwd) + , proc + , readCreateProcessWithExitCode + ) + +type GenerateFunction = CInt -> CSize -> Ptr CDouble -> CSize -> IO CInt +type PrepareFunction = CInt -> Ptr CDouble -> CSize -> Ptr (Ptr ()) -> IO CInt +type RunFunction = Ptr () -> Ptr CSize -> Ptr CSize -> IO CInt +type ReleaseFunction = Ptr () -> IO () + +foreign import ccall safe "dynamic" + bindGenerateFunction :: FunPtr GenerateFunction -> GenerateFunction + +foreign import ccall safe "dynamic" + bindPrepareFunction :: FunPtr PrepareFunction -> PrepareFunction + +foreign import ccall safe "dynamic" + bindRunFunction :: FunPtr RunFunction -> RunFunction + +foreign import ccall unsafe "dynamic" + bindReleaseFunction :: FunPtr ReleaseFunction -> ReleaseFunction + +data NativeApi = NativeApi + { nativeGenerate :: !GenerateFunction + , nativePrepare :: !PrepareFunction + , nativeRun :: !RunFunction + , nativeRelease :: !ReleaseFunction + } + +newtype NativeFixture = NativeFixture (Ptr ()) + +data GeneratedCoordinates = GeneratedCoordinates + { generatedPointCount :: !PointCount + , generatedCoordinateValues :: !(StorableVector.Vector CDouble) + } + +withNativeApi + :: (NativeApi -> IO (Either CompareObstruction result)) + -> IO (Either CompareObstruction result) +withNativeApi action = do + manifestResult <- resolveRustManifest + case manifestResult of + Left obstruction -> pure (Left obstruction) + Right manifest -> do + libraryResult <- buildRustLibrary manifest + case libraryResult of + Left obstruction -> pure (Left obstruction) + Right libraryPath -> withLoadedNativeApi libraryPath action + +resolveRustManifest :: IO (Either CompareObstruction FilePath) +resolveRustManifest = do + configured <- lookupEnv "MOONLIGHT_DELAUNAY_COMPARE_RUST_MANIFEST" + let candidates = + case configured of + Just path -> path :| [] + Nothing -> + "bench/delaunay-compare/rust/Cargo.toml" + :| [ "foundation/moonlight-triangulation/bench/delaunay-compare/rust/Cargo.toml" + , "compiler/foundation/moonlight-triangulation/bench/delaunay-compare/rust/Cargo.toml" + ] + existing <- filterM doesFileExist (NonEmpty.toList candidates) + case existing of + manifest : _ -> Right <$> makeAbsolute manifest + [] -> pure (Left (RustManifestNotFound candidates)) + +buildRustLibrary :: FilePath -> IO (Either CompareObstruction FilePath) +buildRustLibrary manifest = do + libraryNameResult <- dynamicLibraryName + case libraryNameResult of + Left obstruction -> pure (Left obstruction) + Right libraryName -> do + let rustRoot = takeDirectory manifest + targetDirectory = rustRoot "target" + command = + ( proc + "cargo" + [ "build" + , "--quiet" + , "--release" + , "--lib" + , "--manifest-path" + , manifest + , "--target-dir" + , targetDirectory + ] + ) + { cwd = Just rustRoot + } + invocation <- try @IOException (readCreateProcessWithExitCode command "") + pure $ + case invocation of + Left exception -> + Left (CargoInvocationFailed manifest (displayException exception)) + Right (ExitFailure exitCode, standardOutput, standardError) -> + Left + ( CargoBuildFailed + manifest + exitCode + (standardError <> standardOutput) + ) + Right (ExitSuccess, _, _) -> + Right (targetDirectory "release" libraryName) + +dynamicLibraryName :: IO (Either CompareObstruction FilePath) +dynamicLibraryName = + pure $ + case os of + "darwin" -> Right "libmoonlight_delaunay_compare_referents.dylib" + "linux" -> Right "libmoonlight_delaunay_compare_referents.so" + host -> Left (UnsupportedDynamicLibraryHost host) + +withLoadedNativeApi + :: FilePath + -> (NativeApi -> IO (Either CompareObstruction result)) + -> IO (Either CompareObstruction result) +withLoadedNativeApi libraryPath action = do + opened <- try @IOException (dlopen libraryPath [RTLD_NOW, RTLD_LOCAL]) + case opened of + Left exception -> + pure (Left (DynamicLibraryOpenFailed libraryPath (displayException exception))) + Right handle -> + bracket + (pure handle) + dlclose + ( \loadedHandle -> do + apiResult <- loadNativeApi libraryPath loadedHandle + case apiResult of + Left obstruction -> pure (Left obstruction) + Right api -> action api + ) + +loadNativeApi :: FilePath -> DL -> IO (Either CompareObstruction NativeApi) +loadNativeApi libraryPath handle = + runExceptT $ + NativeApi + <$> loadSymbol libraryPath handle "delaunay_compare_generate" bindGenerateFunction + <*> loadSymbol libraryPath handle "delaunay_compare_prepare" bindPrepareFunction + <*> loadSymbol libraryPath handle "delaunay_compare_run" bindRunFunction + <*> loadSymbol libraryPath handle "delaunay_compare_release" bindReleaseFunction + +loadSymbol + :: FilePath + -> DL + -> String + -> (FunPtr function -> boundFunction) + -> ExceptT CompareObstruction IO boundFunction +loadSymbol libraryPath handle symbol bind = + ExceptT $ do + loaded <- try @IOException (dlsym handle symbol) + pure $ + first + (DynamicSymbolLoadFailed libraryPath symbol . displayException) + (bind <$> loaded) + +generateCoordinates + :: NativeApi + -> FixtureSpec + -> IO (Either NativeStatus GeneratedCoordinates) +generateCoordinates api fixture = do + let pointCount = fixturePointCount fixture + coordinateCount = 2 * pointCountValue pointCount + mutableCoordinates <- MutableStorableVector.new coordinateCount + statusCode <- + MutableStorableVector.unsafeWith mutableCoordinates $ \coordinatePointer -> + nativeGenerate api + (distributionTag (fixturePointDistribution fixture)) + (fromIntegral (pointCountValue pointCount)) + coordinatePointer + (fromIntegral coordinateCount) + case decodeNativeStatus statusCode of + Left status -> pure (Left status) + Right () -> do + coordinates <- StorableVector.unsafeFreeze mutableCoordinates + pure (Right (GeneratedCoordinates pointCount coordinates)) + +generatedCoordinatePairs :: GeneratedCoordinates -> Vector.Vector (Double, Double) +generatedCoordinatePairs generated = + Vector.fromList + ( unfoldr + takeCoordinatePair + (realToFrac <$> StorableVector.toList (generatedCoordinateValues generated)) + ) + where + takeCoordinatePair :: [Double] -> Maybe ((Double, Double), [Double]) + takeCoordinatePair = \case + x : y : remaining -> Just ((x, y), remaining) + _ -> Nothing + +prepareNativeFixture + :: NativeApi + -> NativeImplementation + -> GeneratedCoordinates + -> IO (Either NativePreparationFailure NativeFixture) +prepareNativeFixture api implementation coordinates = + alloca $ \preparedOutput -> do + poke preparedOutput nullPtr + statusCode <- + StorableVector.unsafeWith (generatedCoordinateValues coordinates) $ \coordinatePointer -> + nativePrepare api + (implementationTag implementation) + coordinatePointer + (fromIntegral (pointCountValue (generatedPointCount coordinates))) + preparedOutput + case decodeNativeStatus statusCode of + Left status -> pure (Left (NativePreparationStatus status)) + Right () -> do + prepared <- peek preparedOutput + pure $ + if prepared == nullPtr + then Left NativePreparationReturnedNull + else Right (NativeFixture prepared) + +runNativeFixture + :: NativeApi + -> NativeFixture + -> IO (Either NativeRunFailure DelaunaySummary) +runNativeFixture api (NativeFixture prepared) = + alloca $ \vertexCountOutput -> + alloca $ \triangleCountOutput -> do + statusCode <- nativeRun api prepared vertexCountOutput triangleCountOutput + case decodeNativeStatus statusCode of + Left status -> pure (Left (NativeRunStatus status)) + Right () -> do + vertexCount <- peek vertexCountOutput + triangleCount <- peek triangleCountOutput + pure $ DelaunaySummary <$> cSizeToInt vertexCount <*> cSizeToInt triangleCount + +releaseNativeFixture :: NativeApi -> NativeFixture -> IO () +releaseNativeFixture api (NativeFixture prepared) = nativeRelease api prepared + +decodeNativeStatus :: CInt -> Either NativeStatus () +decodeNativeStatus statusCode = + case fromIntegral statusCode :: Int32 of + 0 -> Right () + 1 -> Left NativeNullPointer + 2 -> Left NativeUnknownTag + 3 -> Left NativeCoordinateCountMismatch + 4 -> Left NativeDistributionConstructionFailed + 5 -> Left NativeTriangulationFailed + 6 -> Left NativePanicked + unknown -> Left (NativeUnknownStatus (fromIntegral unknown)) + +cSizeToInt :: CSize -> Either NativeRunFailure Int +cSizeToInt value = + let integerValue = toInteger value + in if integerValue > toInteger (maxBound :: Int) + then Left (NativeCountExceedsHaskellInt integerValue) + else Right (fromInteger integerValue) + +distributionTag :: PointDistribution -> CInt +distributionTag = \case + LocalInsertion -> 0 + Uniform -> 1 + +implementationTag :: NativeImplementation -> CInt +implementationTag = \case + NativeSpade -> 0 + NativeSpadeHierarchy -> 1 + NativeCdt -> 2 + NativeDelaunator -> 3 diff --git a/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Picture.hs b/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Picture.hs new file mode 100644 --- /dev/null +++ b/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Picture.hs @@ -0,0 +1,526 @@ +{-# LANGUAGE LambdaCase #-} + +-- | Typed receipt parsing and pure Spade-style SVG projection. +module Moonlight.Triangulation.Bench.DelaunayCompare.Picture + ( BenchmarkReceipt + , PictureObstruction (..) + , parseBenchmarkReceipt + , pictureFileName + , renderComparisonPicture + , renderPictureObstruction + ) where + +import Data.List (group, sort, sortOn) +import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) +import qualified Data.Set as Set +import Moonlight.Triangulation.Bench.DelaunayCompare.Domain +import Numeric (showFFloat) +import Text.Read (readMaybe) + +data ObservationKey = ObservationKey + { observationFixture :: !FixtureSpec + , observationImplementation :: !Implementation + } + deriving stock (Eq, Ord, Show) + +data BenchmarkObservation = BenchmarkObservation + { benchmarkKey :: !ObservationKey + , benchmarkMeanPicoseconds :: !Double + , benchmarkSpreadPicoseconds :: !Double + } + deriving stock (Eq, Show) + +newtype BenchmarkReceipt = BenchmarkReceipt + { receiptObservations :: Map.Map ObservationKey BenchmarkObservation + } + +data PictureObstruction + = MissingCsvHeader + | UnexpectedCsvHeader !String + | MalformedCsvRow !Int !String + | UnknownBenchmarkName !Int !String + | InvalidBenchmarkScalar !Int !String !String + | DuplicateBenchmarkObservations ![ObservationKey] + | MissingBenchmarkObservations ![ObservationKey] + deriving stock (Eq, Show) + +parseBenchmarkReceipt :: String -> Either PictureObstruction BenchmarkReceipt +parseBenchmarkReceipt source = + case lines source of + [] -> Left MissingCsvHeader + header : rows + | header /= expectedCsvHeader -> Left (UnexpectedCsvHeader header) + | otherwise -> do + observations <- traverse (uncurry parseObservationRow) (zip [2 ..] rows) + let keys = benchmarkKey <$> observations + duplicateKeys = + mapMaybe + ( \case + key : _ : _ -> Just key + _ -> Nothing + ) + (group (sort keys)) + observationMap = Map.fromList ((\observation -> (benchmarkKey observation, observation)) <$> observations) + missingKeys = Set.toList (expectedObservationKeys `Set.difference` Map.keysSet observationMap) + case (duplicateKeys, missingKeys) of + (duplicate : duplicates, _) -> Left (DuplicateBenchmarkObservations (duplicate : duplicates)) + ([], missing : remaining) -> Left (MissingBenchmarkObservations (missing : remaining)) + ([], []) -> Right (BenchmarkReceipt observationMap) + +renderComparisonPicture + :: SizeBand + -> BenchmarkReceipt + -> String +renderComparisonPicture sizeBand receipt = + renderSvg sizeBand pointCounts axisMaximum panels + where + pointCounts = pointCountValue <$> pointCountsFor sizeBand + panels = picturePanel receipt sizeBand <$> allPointDistributions + allObservations = concatMap (concatMap pictureSeriesObservations . picturePanelSeries) panels + maximumMilliseconds = + foldr + (max . observationUpperMilliseconds) + 0 + allObservations + axisMaximum = niceCeiling maximumMilliseconds + +pictureFileName :: SizeBand -> FilePath +pictureFileName = \case + Small -> "moonlight-delaunay-compare-small.svg" + Big -> "moonlight-delaunay-compare-big.svg" + +renderPictureObstruction :: PictureObstruction -> String +renderPictureObstruction = \case + MissingCsvHeader -> "benchmark CSV has no header" + UnexpectedCsvHeader header -> + "benchmark CSV header was " <> show header <> "; expected " <> show expectedCsvHeader + MalformedCsvRow lineNumber row -> + "benchmark CSV row " <> show lineNumber <> " is not a three-column tasty-bench row: " <> show row + UnknownBenchmarkName lineNumber name -> + "benchmark CSV row " <> show lineNumber <> " names an unknown comparison case: " <> show name + InvalidBenchmarkScalar lineNumber field value -> + "benchmark CSV row " + <> show lineNumber + <> " has invalid " + <> field + <> ": " + <> show value + DuplicateBenchmarkObservations keys -> + "benchmark CSV repeats comparison cases: " <> show keys + MissingBenchmarkObservations keys -> + "benchmark CSV omits comparison cases: " <> show keys + +expectedCsvHeader :: String +expectedCsvHeader = "Name,Mean (ps),2*Stdev (ps)" + +expectedObservationKeys :: Set.Set ObservationKey +expectedObservationKeys = + Set.fromList (liftA2 ObservationKey allFixtureSpecs allImplementations) + +expectedBenchmarkNames :: Map.Map String ObservationKey +expectedBenchmarkNames = + Map.fromList ((\key -> (benchmarkName key, key)) <$> Set.toList expectedObservationKeys) + +benchmarkName :: ObservationKey -> String +benchmarkName key = + "All.comparison: creation benchmark (" + <> sizeBandLabel (fixtureSizeBand fixture) + <> ")." + <> implementationLabel (observationImplementation key) + <> "." + <> pointDistributionLabel (fixturePointDistribution fixture) + <> "." + <> show (pointCountValue (fixturePointCount fixture)) + where + fixture = observationFixture key + +parseObservationRow :: Int -> String -> Either PictureObstruction BenchmarkObservation +parseObservationRow lineNumber row = + case csvTriple row of + Nothing -> Left (MalformedCsvRow lineNumber row) + Just (name, rawMean, rawSpread) -> do + key <- maybe (Left (UnknownBenchmarkName lineNumber name)) Right (Map.lookup name expectedBenchmarkNames) + meanPicoseconds <- parseNonNegativeScalar lineNumber "mean picoseconds" rawMean + spreadPicoseconds <- parseNonNegativeScalar lineNumber "two-standard-deviation spread" rawSpread + pure + BenchmarkObservation + { benchmarkKey = key + , benchmarkMeanPicoseconds = meanPicoseconds + , benchmarkSpreadPicoseconds = spreadPicoseconds + } + +csvTriple :: String -> Maybe (String, String, String) +csvTriple row = + case break (== ',') row of + (firstColumn, ',' : remaining) -> + case break (== ',') remaining of + (secondColumn, ',' : thirdColumn) + | ',' `notElem` thirdColumn -> Just (firstColumn, secondColumn, thirdColumn) + _ -> Nothing + _ -> Nothing + +parseNonNegativeScalar :: Int -> String -> String -> Either PictureObstruction Double +parseNonNegativeScalar lineNumber field rawValue = + case readMaybe rawValue of + Just value + | value >= 0 && not (isInfinite value) && not (isNaN value) -> Right value + _ -> Left (InvalidBenchmarkScalar lineNumber field rawValue) + +data PictureSeries = PictureSeries + { pictureSeriesImplementation :: !Implementation + , pictureSeriesObservations :: ![BenchmarkObservation] + } + +data PicturePanel = PicturePanel + { picturePanelDistribution :: !PointDistribution + , picturePanelSeries :: ![PictureSeries] + } + +picturePanel + :: BenchmarkReceipt + -> SizeBand + -> PointDistribution + -> PicturePanel +picturePanel receipt sizeBand distribution = + PicturePanel distribution (pictureSeries receipt sizeBand distribution <$> allImplementations) + +pictureSeries + :: BenchmarkReceipt + -> SizeBand + -> PointDistribution + -> Implementation + -> PictureSeries +pictureSeries receipt sizeBand distribution implementation = + PictureSeries implementation observations + where + observations = + sortOn (pointCountValue . fixturePointCount . observationFixture . benchmarkKey) + [ observation + | observation <- Map.elems (receiptObservations receipt) + , let key = benchmarkKey observation + fixture = observationFixture key + , fixtureSizeBand fixture == sizeBand + , fixturePointDistribution fixture == distribution + , observationImplementation key == implementation + ] + +data PictureLayout = PictureLayout + { pictureWidth :: !Double + , pictureHeight :: !Double + , picturePlotTop :: !Double + , picturePlotBottom :: !Double + , picturePanelWidth :: !Double + , picturePanelLefts :: ![Double] + } + +pictureLayout :: PictureLayout +pictureLayout = + PictureLayout + { pictureWidth = 1280 + , pictureHeight = 720 + , picturePlotTop = 168 + , picturePlotBottom = 610 + , picturePanelWidth = 540 + , picturePanelLefts = [70, 670] + } + +renderSvg :: SizeBand -> [Int] -> Double -> [PicturePanel] -> String +renderSvg sizeBand pointCounts axisMaximum panels = + unlines + ( [ "" + , " coordinate (pictureWidth pictureLayout) + <> " " + <> coordinate (pictureHeight pictureLayout) + <> "\" role=\"img\" aria-labelledby=\"title description\">" + , "" <> pictureTitle sizeBand <> "" + , "CPU construction time for Spade, cdt, delaunator, and Moonlight over the upstream Delaunay comparison fixtures. Lower lines are faster." + , "" + , " " + , " " + , " " + , " " + , "" + , " coordinate (pictureWidth pictureLayout) + <> "\" height=\"" + <> coordinate (pictureHeight pictureLayout) + <> "\" fill=\"white\"/>" + , "" + , svgText 640 34 "middle" 24 "500" (pictureTitle sizeBand) + , svgText 640 61 "middle" 13 "400" "Moonlight against Spade's construction referents · CPU time · lower is faster" + ] + <> renderLegend + <> concat (zipWith (renderPanel pointCounts axisMaximum) (picturePanelLefts pictureLayout) panels) + <> [ svgText 640 704 "middle" 11 "400" "Whiskers show tasty-bench's reported 2× standard-deviation spread." + , "" + ] + ) + +pictureTitle :: SizeBand -> String +pictureTitle = \case + Small -> "Moonlight Delaunay construction · small point sets" + Big -> "Moonlight Delaunay construction · big point sets" + +renderLegend :: [String] +renderLegend = + concat + ( zipWith + renderLegendItem + [105, 315, 560, 735, 940] + allImplementations + ) + +renderLegendItem :: Double -> Implementation -> [String] +renderLegendItem x implementation = + [ " implementationLabel implementation <> "\">" + , " coordinate x <> "\" y1=\"101\" x2=\"" <> coordinate (x + 34) <> "\" y2=\"101\" stroke=\"" <> implementationColor implementation <> "\" stroke-width=\"" <> seriesStrokeWidth implementation <> "\"" <> seriesDash implementation <> "/>" + , " " <> renderMarker implementation (x + 17) 101 + , " " <> svgText (x + 43) 105 "start" 12 "400" (implementationLabel implementation) + , "" + ] + +renderPanel :: [Int] -> Double -> Double -> PicturePanel -> [String] +renderPanel pointCounts axisMaximum panelLeft panel = + [ " panelLabel <> "\">" + , svgText (panelLeft + panelWidth / 2) 144 "middle" 15 "500" panelLabel + ] + <> concatMap (renderHorizontalGrid panelLeft panelWidth axisMaximum) [0 .. 5] + <> concatMap (renderVerticalTick panelLeft panelWidth pointCounts) pointCounts + <> [ " coordinate panelLeft <> "\" y=\"" <> coordinate plotTop <> "\" width=\"" <> coordinate panelWidth <> "\" height=\"" <> coordinate plotHeight <> "\" fill=\"none\" stroke=\"rgb(25,25,25)\" stroke-width=\"1\"/>" + , svgText (panelLeft + panelWidth / 2) 664 "middle" 12 "400" "input size (points)" + , " coordinate (panelLeft - 55) <> "\" y=\"" <> coordinate (plotTop + plotHeight / 2) <> "\" text-anchor=\"middle\" font-family=\"Helvetica, Arial, sans-serif\" font-size=\"12\" fill=\"rgb(20,20,20)\" transform=\"rotate(-90 " <> coordinate (panelLeft - 55) <> " " <> coordinate (plotTop + plotHeight / 2) <> ")\">CPU time (ms)" + ] + <> concatMap (renderSeries panelLeft panelWidth pointCounts axisMaximum) (picturePanelSeries panel) + <> maybe + [] + (renderAdvantageCallout panelLeft panelWidth pointCounts axisMaximum) + (bestReportedSpreadAdvantage (picturePanelSeries panel)) + <> [""] + where + panelLabel = pointDistributionLabel (picturePanelDistribution panel) + panelWidth = picturePanelWidth pictureLayout + plotTop = picturePlotTop pictureLayout + plotHeight = picturePlotBottom pictureLayout - plotTop + +renderHorizontalGrid :: Double -> Double -> Double -> Int -> [String] +renderHorizontalGrid panelLeft panelWidth axisMaximum tickIndex = + [ " coordinate panelLeft <> "\" y1=\"" <> coordinate y <> "\" x2=\"" <> coordinate (panelLeft + panelWidth) <> "\" y2=\"" <> coordinate y <> "\" stroke=\"rgb(170,170,170)\" stroke-width=\"0.7\" stroke-dasharray=\"2 4\"/>" + , svgText (panelLeft - 10) (y + 4) "end" 11 "400" (axisLabel tickValue) + ] + where + tickValue = axisMaximum * fromIntegral tickIndex / 5 + y = pictureY axisMaximum tickValue + +renderVerticalTick :: Double -> Double -> [Int] -> Int -> [String] +renderVerticalTick panelLeft panelWidth pointCounts pointCount = + [ " coordinate x <> "\" y1=\"610\" x2=\"" <> coordinate x <> "\" y2=\"616\" stroke=\"rgb(25,25,25)\" stroke-width=\"1\"/>" + , svgText x 635 "middle" 11 "400" (pointCountLabel pointCount) + ] + where + x = pictureX panelLeft panelWidth pointCounts pointCount + +renderSeries :: Double -> Double -> [Int] -> Double -> PictureSeries -> [String] +renderSeries panelLeft panelWidth pointCounts axisMaximum series = + [ " implementationLabel implementation <> "\">" + , " unwords (observationPoint <$> observations) <> "\" fill=\"none\" stroke=\"" <> implementationColor implementation <> "\" stroke-width=\"" <> seriesStrokeWidth implementation <> "\" stroke-linecap=\"round\" stroke-linejoin=\"round\"" <> seriesDash implementation <> "/>" + ] + <> concatMap renderObservation observations + <> [""] + where + implementation = pictureSeriesImplementation series + observations = pictureSeriesObservations series + observationPoint observation = + coordinate (observationX observation) <> "," <> coordinate (observationY observation) + observationX = + pictureX panelLeft panelWidth pointCounts + . pointCountValue + . fixturePointCount + . observationFixture + . benchmarkKey + observationY = pictureY axisMaximum . observationMeanMilliseconds + renderObservation observation = + [ " coordinate x <> "\" y1=\"" <> coordinate upperY <> "\" x2=\"" <> coordinate x <> "\" y2=\"" <> coordinate lowerY <> "\" stroke=\"" <> implementationColor implementation <> "\" stroke-width=\"0.9\" opacity=\"0.48\"/>" + , " coordinate (x - 3) <> "\" y1=\"" <> coordinate upperY <> "\" x2=\"" <> coordinate (x + 3) <> "\" y2=\"" <> coordinate upperY <> "\" stroke=\"" <> implementationColor implementation <> "\" stroke-width=\"0.9\" opacity=\"0.48\"/>" + , " coordinate (x - 3) <> "\" y1=\"" <> coordinate lowerY <> "\" x2=\"" <> coordinate (x + 3) <> "\" y2=\"" <> coordinate lowerY <> "\" stroke=\"" <> implementationColor implementation <> "\" stroke-width=\"0.9\" opacity=\"0.48\"/>" + , " " <> renderMarker implementation x y + ] + where + x = observationX observation + y = observationY observation + upperY = pictureY axisMaximum (observationUpperMilliseconds observation) + lowerY = pictureY axisMaximum (observationLowerMilliseconds observation) + +data ReportedSpreadAdvantage = ReportedSpreadAdvantage + { advantagePointCount :: !Int + , advantageMoonlight :: !BenchmarkObservation + , advantageCompetitor :: !Implementation + , advantageReduction :: !Double + } + +bestReportedSpreadAdvantage :: [PictureSeries] -> Maybe ReportedSpreadAdvantage +bestReportedSpreadAdvantage series = foldr selectLargerReduction Nothing reportedSpreadAdvantages + where + moonlightObservations = + concatMap pictureSeriesObservations (filter ((== Moonlight) . pictureSeriesImplementation) series) + spadeSeries = + filter + ((`elem` [Spade, SpadeHierarchy]) . pictureSeriesImplementation) + series + reportedSpreadAdvantages = + [ ReportedSpreadAdvantage + { advantagePointCount = pointCountValue (fixturePointCount moonlightFixture) + , advantageMoonlight = moonlight + , advantageCompetitor = pictureSeriesImplementation competitorSeries + , advantageReduction = 1 - benchmarkMeanPicoseconds moonlight / benchmarkMeanPicoseconds competitor + } + | moonlight <- moonlightObservations + , let moonlightFixture = observationFixture (benchmarkKey moonlight) + , competitorSeries <- spadeSeries + , competitor <- pictureSeriesObservations competitorSeries + , fixturePointCount (observationFixture (benchmarkKey competitor)) == fixturePointCount moonlightFixture + , benchmarkMeanPicoseconds moonlight + benchmarkSpreadPicoseconds moonlight + < benchmarkMeanPicoseconds competitor - benchmarkSpreadPicoseconds competitor + ] + selectLargerReduction candidate = \case + Nothing -> Just candidate + Just incumbent -> + Just + ( if advantageReduction candidate > advantageReduction incumbent + then candidate + else incumbent + ) + +renderAdvantageCallout :: Double -> Double -> [Int] -> Double -> ReportedSpreadAdvantage -> [String] +renderAdvantageCallout panelLeft panelWidth pointCounts axisMaximum advantage = + [ "" + , " coordinate pointX <> "\" y1=\"" <> coordinate pointY <> "\" x2=\"" <> coordinate (labelX + 8) <> "\" y2=\"" <> coordinate (labelY + 18) <> "\" stroke=\"rgb(255,140,0)\" stroke-width=\"1.2\"/>" + , " coordinate labelX <> "\" y=\"" <> coordinate labelY <> "\" width=\"250\" height=\"38\" rx=\"6\" fill=\"white\" stroke=\"rgb(255,140,0)\" stroke-width=\"1.2\"/>" + , " " <> svgText (labelX + 10) (labelY + 16) "start" 11 "500" (show reductionPercent <> "% less time than " <> implementationLabel (advantageCompetitor advantage)) + , " " <> svgText (labelX + 10) (labelY + 31) "start" 10 "400" (pointCountLabel (advantagePointCount advantage) <> " points · reported spreads do not overlap") + , "" + ] + where + pointX = pictureX panelLeft panelWidth pointCounts (advantagePointCount advantage) + pointY = pictureY axisMaximum (observationMeanMilliseconds (advantageMoonlight advantage)) + labelX = min (panelLeft + panelWidth - 258) (pointX + 28) + labelY = max (picturePlotTop pictureLayout + 12) (pointY - 58) + reductionPercent = round (100 * advantageReduction advantage) :: Int + +implementationColor :: Implementation -> String +implementationColor = \case + Spade -> "rgb(0,0,139)" + SpadeHierarchy -> "rgb(139,0,139)" + Cdt -> "rgb(178,34,34)" + Delaunator -> "rgb(0,139,139)" + Moonlight -> "rgb(255,140,0)" + +seriesStrokeWidth :: Implementation -> String +seriesStrokeWidth = \case + Moonlight -> "3.2" + _ -> "2.0" + +seriesDash :: Implementation -> String +seriesDash = \case + SpadeHierarchy -> " stroke-dasharray=\"7 4\"" + _ -> "" + +renderMarker :: Implementation -> Double -> Double -> String +renderMarker implementation x y = + case implementation of + Spade -> circle 3.2 + SpadeHierarchy -> + " coordinate x <> " " <> coordinate (y - 4.3) <> " L " <> coordinate (x - 4.1) <> " " <> coordinate (y + 3.5) <> " L " <> coordinate (x + 4.1) <> " " <> coordinate (y + 3.5) <> " Z\" fill=\"white\" stroke=\"" <> color <> "\" stroke-width=\"1.6\"/>" + Cdt -> + " coordinate (x - 3.2) <> "\" y=\"" <> coordinate (y - 3.2) <> "\" width=\"6.4\" height=\"6.4\" fill=\"white\" stroke=\"" <> color <> "\" stroke-width=\"1.6\"/>" + Delaunator -> + " coordinate x <> " " <> coordinate (y - 4.2) <> " L " <> coordinate (x + 4.2) <> " " <> coordinate y <> " L " <> coordinate x <> " " <> coordinate (y + 4.2) <> " L " <> coordinate (x - 4.2) <> " " <> coordinate y <> " Z\" fill=\"white\" stroke=\"" <> color <> "\" stroke-width=\"1.6\"/>" + Moonlight -> + " coordinate x <> " " <> coordinate (y - 5.4) <> " L " <> coordinate (x + 1.7) <> " " <> coordinate (y - 1.7) <> " L " <> coordinate (x + 5.4) <> " " <> coordinate y <> " L " <> coordinate (x + 1.7) <> " " <> coordinate (y + 1.7) <> " L " <> coordinate x <> " " <> coordinate (y + 5.4) <> " L " <> coordinate (x - 1.7) <> " " <> coordinate (y + 1.7) <> " L " <> coordinate (x - 5.4) <> " " <> coordinate y <> " L " <> coordinate (x - 1.7) <> " " <> coordinate (y - 1.7) <> " Z\" fill=\"" <> color <> "\" stroke=\"white\" stroke-width=\"1\"/>" + where + color = implementationColor implementation + circle radius = + " coordinate x <> "\" cy=\"" <> coordinate y <> "\" r=\"" <> coordinate radius <> "\" fill=\"white\" stroke=\"" <> color <> "\" stroke-width=\"1.6\"/>" + +pictureX :: Double -> Double -> [Int] -> Int -> Double +pictureX panelLeft panelWidth pointCounts pointCount = + case pointCounts of + [] -> panelLeft + firstCount : remainingCounts -> + let minimumCount = firstCount + maximumCount = foldr max firstCount remainingCounts + countRange = maximumCount - minimumCount + in if countRange == 0 + then panelLeft + panelWidth / 2 + else + panelLeft + + panelWidth + * fromIntegral (pointCount - minimumCount) + / fromIntegral countRange + +pictureY :: Double -> Double -> Double +pictureY axisMaximum milliseconds = + picturePlotBottom pictureLayout + - plotHeight * min axisMaximum (max 0 milliseconds) / axisMaximum + where + plotHeight = picturePlotBottom pictureLayout - picturePlotTop pictureLayout + +observationMeanMilliseconds :: BenchmarkObservation -> Double +observationMeanMilliseconds = picosecondsToMilliseconds . benchmarkMeanPicoseconds + +observationUpperMilliseconds :: BenchmarkObservation -> Double +observationUpperMilliseconds observation = + picosecondsToMilliseconds + (benchmarkMeanPicoseconds observation + benchmarkSpreadPicoseconds observation) + +observationLowerMilliseconds :: BenchmarkObservation -> Double +observationLowerMilliseconds observation = + picosecondsToMilliseconds + (max 0 (benchmarkMeanPicoseconds observation - benchmarkSpreadPicoseconds observation)) + +picosecondsToMilliseconds :: Double -> Double +picosecondsToMilliseconds picoseconds = picoseconds / 1.0e9 + +niceCeiling :: Double -> Double +niceCeiling value + | value <= 0 = 1 + | otherwise = niceFraction * magnitude + where + magnitude = 10 ** fromIntegral (floor (logBase 10 value) :: Int) + fraction = value / magnitude + niceFraction + | fraction <= 1 = 1 + | fraction <= 2 = 2 + | fraction <= 5 = 5 + | otherwise = 10 + +axisLabel :: Double -> String +axisLabel value + | value >= 10 = showFFloat (Just 0) value "" + | value >= 1 = showFFloat (Just 1) value "" + | otherwise = showFFloat (Just 2) value "" + +pointCountLabel :: Int -> String +pointCountLabel pointCount + | pointCount `mod` 1000 == 0 = show (pointCount `div` 1000) <> "k" + | otherwise = show pointCount + +coordinate :: Double -> String +coordinate value = showFFloat (Just 1) value "" + +svgText :: Double -> Double -> String -> Int -> String -> String -> String +svgText x y anchor fontSize fontWeight content = + " coordinate x + <> "\" y=\"" + <> coordinate y + <> "\" text-anchor=\"" + <> anchor + <> "\" font-family=\"Helvetica, Arial, sans-serif\" font-size=\"" + <> show fontSize + <> "\" font-weight=\"" + <> fontWeight + <> "\" fill=\"rgb(20,20,20)\">" + <> content + <> "" diff --git a/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Suite.hs b/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Suite.hs new file mode 100644 --- /dev/null +++ b/bench/delaunay-compare/Moonlight/Triangulation/Bench/DelaunayCompare/Suite.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Fixture descent, compatibility gluing, and the authoritative benchmark view. +module Moonlight.Triangulation.Bench.DelaunayCompare.Suite + ( PreparedSuite + , withPreparedSuite + , preflightSuite + , suiteBenchmarks + , suiteAgreementMessage + ) where + +import Control.DeepSeq (force) +import Control.Exception (bracket, evaluate) +import Data.Bifunctor (first) +import Data.Either (lefts, rights) +import Data.Foldable (toList, traverse_) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Vector as Vector +import Moonlight.Triangulation.Bench.DelaunayCompare.Domain +import Moonlight.Triangulation.Bench.DelaunayCompare.Native +import Moonlight.Triangulation.BulkLoad (delaunayGeometry) +import Moonlight.Triangulation.Dcel (numInnerFaces, numVertices) +import Moonlight.Triangulation.Types (BuildError, Point (Point)) +import Test.Tasty.Bench (Benchmark, bench, bgroup, nf, nfIO) + +data NativeSections value = NativeSections + { nativeSpadeSection :: !value + , nativeSpadeHierarchySection :: !value + , nativeCdtSection :: !value + , nativeDelaunatorSection :: !value + } + deriving stock (Functor, Foldable, Traversable) + +nativeImplementationSections :: NativeSections NativeImplementation +nativeImplementationSections = + NativeSections + { nativeSpadeSection = NativeSpade + , nativeSpadeHierarchySection = NativeSpadeHierarchy + , nativeCdtSection = NativeCdt + , nativeDelaunatorSection = NativeDelaunator + } + +nativeSectionAt :: NativeImplementation -> NativeSections value -> value +nativeSectionAt implementation sections = + case implementation of + NativeSpade -> nativeSpadeSection sections + NativeSpadeHierarchy -> nativeSpadeHierarchySection sections + NativeCdt -> nativeCdtSection sections + NativeDelaunator -> nativeDelaunatorSection sections + +data PreparedFixture = PreparedFixture + { preparedSpec :: !FixtureSpec + , preparedMoonlightPoints :: !(Vector.Vector Point) + , preparedNativeFixtures :: !(NativeSections NativeFixture) + } + +newtype PreparedSuite = PreparedSuite [PreparedFixture] + +withPreparedSuite + :: NativeApi + -> (PreparedSuite -> IO (Either CompareObstruction result)) + -> IO (Either CompareObstruction result) +withPreparedSuite api action = do + prepared <- prepareSuite api + case prepared of + Left obstruction -> pure (Left obstruction) + Right suite -> bracket (pure suite) (releaseSuite api) action + +prepareSuite :: NativeApi -> IO (Either CompareObstruction PreparedSuite) +prepareSuite api = do + outcomes <- traverse (prepareFixture api) allFixtureSpecs + case NonEmpty.nonEmpty (lefts outcomes) of + Just obstructions -> do + traverse_ (releasePreparedFixture api) (rights outcomes) + pure (Left (ComparisonObstructions obstructions)) + Nothing -> pure (Right (PreparedSuite (rights outcomes))) + +prepareFixture :: NativeApi -> FixtureSpec -> IO (Either CompareObstruction PreparedFixture) +prepareFixture api fixture = do + generated <- generateCoordinates api fixture + case generated of + Left status -> pure (Left (FixtureGenerationFailed fixture status)) + Right coordinates -> do + nativeFixtures <- prepareNativeFixtures api fixture coordinates + pure $ + PreparedFixture + fixture + (Vector.map (uncurry Point) (generatedCoordinatePairs coordinates)) + <$> nativeFixtures + +prepareNativeFixtures + :: NativeApi + -> FixtureSpec + -> GeneratedCoordinates + -> IO (Either CompareObstruction (NativeSections NativeFixture)) +prepareNativeFixtures api fixture coordinates = do + outcomes <- traverse prepareSection nativeImplementationSections + case sequenceA outcomes of + Right nativeFixtures -> pure (Right nativeFixtures) + Left obstruction -> do + traverse_ (releaseNativeFixture api) (rights (toList outcomes)) + pure (Left obstruction) + where + prepareSection implementation = do + prepared <- prepareNativeFixture api implementation coordinates + pure $ + first + (preparationObstruction implementation) + prepared + + preparationObstruction implementation failure = + case failure of + NativePreparationStatus status -> FixturePreparationFailed fixture implementation status + NativePreparationReturnedNull -> NativePreparedNull fixture implementation + +releaseSuite :: NativeApi -> PreparedSuite -> IO () +releaseSuite api (PreparedSuite fixtures) = + traverse_ (releasePreparedFixture api) fixtures + +releasePreparedFixture :: NativeApi -> PreparedFixture -> IO () +releasePreparedFixture api = releasePreparedNativeFixtures api . preparedNativeFixtures + +releasePreparedNativeFixtures :: NativeApi -> NativeSections NativeFixture -> IO () +releasePreparedNativeFixtures api = traverse_ (releaseNativeFixture api) + +preflightSuite :: NativeApi -> PreparedSuite -> IO (Either CompareObstruction ()) +preflightSuite api (PreparedSuite fixtures) = do + outcomes <- traverse (preflightFixture api) fixtures + pure $ + case NonEmpty.nonEmpty (lefts outcomes) of + Just obstructions -> Left (ComparisonObstructions obstructions) + Nothing -> Right () + +preflightFixture :: NativeApi -> PreparedFixture -> IO (Either CompareObstruction ()) +preflightFixture api fixture = do + moonlightResult <- + evaluate + ( force + (moonlightConstructionSummary (preparedMoonlightPoints fixture)) + ) + nativeOutcomes <- traverse runSection nativeImplementationSections + pure $ do + moonlightSummary <- + first + (MoonlightConstructionFailed spec) + moonlightResult + nativeSummaries <- sequenceA nativeOutcomes + traverse_ + ( \implementation -> + requireSummaryAgreement + spec + moonlightSummary + ( implementationOfNative implementation + , nativeSectionAt implementation nativeSummaries + ) + ) + nativeImplementationSections + where + spec = preparedSpec fixture + nativeFixtures = preparedNativeFixtures fixture + runSection implementation = + first (NativeConstructionFailed spec implementation) + <$> runNativeFixture api (nativeSectionAt implementation nativeFixtures) + +requireSummaryAgreement + :: FixtureSpec + -> DelaunaySummary + -> (Implementation, DelaunaySummary) + -> Either CompareObstruction () +requireSummaryAgreement fixture expected (implementation, observed) = + if observed == expected + then Right () + else Left (SummaryDisagreement fixture implementation expected observed) + +moonlightConstructionSummary + :: Vector.Vector Point + -> Either BuildError DelaunaySummary +moonlightConstructionSummary points = do + triangulation <- delaunayGeometry points + pure + DelaunaySummary + { summaryVertexCount = numVertices triangulation + , summaryTriangleCount = numInnerFaces triangulation + } + +suiteBenchmarks :: NativeApi -> PreparedSuite -> [Benchmark] +suiteBenchmarks api (PreparedSuite fixtures) = + fmap (sizeBandBenchmarks api fixtures) allSizeBands + +sizeBandBenchmarks + :: NativeApi + -> [PreparedFixture] + -> SizeBand + -> Benchmark +sizeBandBenchmarks api fixtures sizeBand = + bgroup + ("comparison: creation benchmark (" <> sizeBandLabel sizeBand <> ")") + (fmap (implementationBenchmarks api fixtures sizeBand) allImplementations) + +implementationBenchmarks + :: NativeApi + -> [PreparedFixture] + -> SizeBand + -> Implementation + -> Benchmark +implementationBenchmarks api fixtures sizeBand implementation = + bgroup + (implementationLabel implementation) + ( fmap + (distributionBenchmarks api fixtures sizeBand implementation) + allPointDistributions + ) + +distributionBenchmarks + :: NativeApi + -> [PreparedFixture] + -> SizeBand + -> Implementation + -> PointDistribution + -> Benchmark +distributionBenchmarks api fixtures sizeBand implementation distribution = + bgroup + (pointDistributionLabel distribution) + ( fmap + (fixtureBenchmark api implementation) + ( filter + (matchesFixture sizeBand distribution . preparedSpec) + fixtures + ) + ) + +matchesFixture :: SizeBand -> PointDistribution -> FixtureSpec -> Bool +matchesFixture sizeBand distribution fixture = + fixtureSizeBand fixture == sizeBand + && fixturePointDistribution fixture == distribution + +fixtureBenchmark :: NativeApi -> Implementation -> PreparedFixture -> Benchmark +fixtureBenchmark api implementation fixture = + bench (show (pointCountValue (fixturePointCount (preparedSpec fixture)))) $ + case implementation of + Moonlight -> nf moonlightConstructionSummary (preparedMoonlightPoints fixture) + Spade -> nativeBenchmark NativeSpade + SpadeHierarchy -> nativeBenchmark NativeSpadeHierarchy + Cdt -> nativeBenchmark NativeCdt + Delaunator -> nativeBenchmark NativeDelaunator + where + nativeFixtures = preparedNativeFixtures fixture + nativeBenchmark nativeImplementation = + nfIO (runNativeFixture api (nativeSectionAt nativeImplementation nativeFixtures)) + +suiteAgreementMessage :: String +suiteAgreementMessage = + "delaunay-compare agreement: " + <> show (length allFixtureSpecs) + <> " fixtures agree on vertex and triangle counts across " + <> show (length allImplementations) + <> " implementations" diff --git a/bench/delaunay-compare/PictureMain.hs b/bench/delaunay-compare/PictureMain.hs new file mode 100644 --- /dev/null +++ b/bench/delaunay-compare/PictureMain.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} + +-- | Thin effect boundary for rendering benchmark receipts as SVG pictures. +module Main (main) where + +import Control.Exception (IOException, displayException, try) +import Control.Monad.Trans.Except (ExceptT (ExceptT), except, runExceptT) +import Data.Bifunctor (first) +import Data.Foldable (traverse_) +import Moonlight.Triangulation.Bench.DelaunayCompare.Domain (allSizeBands) +import Moonlight.Triangulation.Bench.DelaunayCompare.Picture +import System.Directory (createDirectoryIfMissing) +import System.Environment (getArgs) +import System.Exit (die) +import System.FilePath (()) +import System.IO (readFile') + +data PictureCommandFailure + = PictureCommandUsage + | PictureCommandReadFailed !FilePath !String + | PictureCommandCreateDirectoryFailed !FilePath !String + | PictureCommandReceiptObstructed !PictureObstruction + | PictureCommandWriteFailed !FilePath !String + +main :: IO () +main = do + arguments <- getArgs + outcome <- runExceptT (runPictureCommand arguments) + either (die . renderPictureCommandFailure) pure outcome + +runPictureCommand :: [String] -> ExceptT PictureCommandFailure IO () +runPictureCommand = \case + [inputCsv, outputDirectory] -> do + source <- + ExceptT + ( first + (PictureCommandReadFailed inputCsv . displayException) + <$> try @IOException (readFile' inputCsv) + ) + receipt <- except (first PictureCommandReceiptObstructed (parseBenchmarkReceipt source)) + let pictures = + ( \sizeBand -> + (pictureFileName sizeBand, renderComparisonPicture sizeBand receipt) + ) + <$> allSizeBands + ExceptT + ( first + (PictureCommandCreateDirectoryFailed outputDirectory . displayException) + <$> try @IOException (createDirectoryIfMissing True outputDirectory) + ) + traverse_ (writePicture outputDirectory) pictures + _ -> except (Left PictureCommandUsage) + +writePicture :: FilePath -> (FilePath, String) -> ExceptT PictureCommandFailure IO () +writePicture outputDirectory (fileName, svgDocument) = + let outputPath = outputDirectory fileName + in ExceptT + ( first + (PictureCommandWriteFailed outputPath . displayException) + <$> try @IOException (writeFile outputPath svgDocument) + ) + +renderPictureCommandFailure :: PictureCommandFailure -> String +renderPictureCommandFailure = \case + PictureCommandUsage -> + "usage: moonlight-triangulation-delaunay-pictures INPUT.csv OUTPUT_DIRECTORY" + PictureCommandReadFailed path details -> + "could not read benchmark CSV " <> path <> ": " <> details + PictureCommandCreateDirectoryFailed path details -> + "could not create picture directory " <> path <> ": " <> details + PictureCommandReceiptObstructed obstruction -> + renderPictureObstruction obstruction + PictureCommandWriteFailed path details -> + "could not write comparison picture " <> path <> ": " <> details diff --git a/bench/delaunay-compare/README.md b/bench/delaunay-compare/README.md new file mode 100644 --- /dev/null +++ b/bench/delaunay-compare/README.md @@ -0,0 +1,183 @@ +# Moonlight Delaunay Compare + +`moonlight-triangulation-delaunay-compare` is Moonlight's package-owned port of Spade's +[`delaunay_compare`](https://github.com/Stoeoef/spade/tree/c8befc96bbbc1898a89cb19f9f3104a848936374/delaunay_compare) +construction suite. It retains the upstream case matrix and appends +`moonlight-triangulation` to the implementation list: + +1. `spade 2` +2. `spade 2 hierarchy` +3. `cdt` +4. `delaunator` +5. `moonlight-triangulation` + +Haskell owns fixture selection, grouping, compatibility descent, timing, and +reporting. The Rust library under `rust/src/lib.rs` is only a typed foreign +boundary to the four Rust implementations and to the exact upstream `rand` +fixture stream; it contains no benchmark policy. + +This executable is the construction slice, not the package's overall +comparison. The [package benchmark overview](../../README.md#overall-moonlightspade-comparison) +also exposes insertion, removal, nearest-neighbour search, CDT recovery, +refinement, natural-neighbour interpolation, Voronoi, DCEL, and segment +traversal lanes. + +## Pictures + +Both pictures are derived from the single retained board. + +![Small-point Delaunay construction comparison](results/moonlight-delaunay-compare-small.svg) + +![Big-point Delaunay construction comparison](results/moonlight-delaunay-compare-big.svg) + +These retain Spade's plain GNUPLOT idiom: white field, Helvetica, dashed grey +grid, jewel-coloured point series, and the same small/big split. Moonlight is +the heavier orange star. The faint triangulation mesh is the sole bit of +levity; benchmark charts need not resemble tax forms. + +## Result + +- timed cases: `120` +- fixture summaries agreeing across all five implementations: `24 / 24` +- Moonlight mean below plain Spade: `12 / 24` +- Moonlight mean below Spade hierarchy: `17 / 24` +- Moonlight below plain Spade with non-overlapping reported 2σ: `0 / 24` +- Moonlight below Spade hierarchy with non-overlapping reported 2σ: `1 / 24` +- lowest fixture mean: `delaunator` `23 / 24`; `cdt` `1 / 24` +- median reported 2σ / mean: Moonlight `7.86%`; plain Spade `6.74%` + +Selected means are in milliseconds. Δ is +`100 × (Moonlight / competitor − 1)`. + +| fixture | points | Moonlight | plain Spade | Δ | Spade hierarchy | Δ | +|---|---:|---:|---:|---:|---:|---:| +| local insertion | 4,000 | 0.663 | 0.748 | −11.3% | 0.784 | −15.4% | +| local insertion | 6,000 | 1.121 | 1.245 | −10.0% | 1.320 | −15.1% | +| local insertion | 8,000 | 1.552 | 1.736 | −10.6% | 1.824 | −14.9% | +| local insertion | 250,000 | 68.017 | 71.675 | −5.1% | 76.208 | −10.7% | +| uniform | 4,000 | 0.676 | 0.693 | −2.4% | 0.729 | −7.3% | +| uniform | 14,000 | 3.591 | 2.959 | +21.4% | 3.171 | +13.3% | +| uniform | 250,000 | 73.329 | 72.076 | +1.7% | 76.447 | −4.1% | + +The measured Moonlight path is the canonical circle-sweep bulk loader. Its +local descent carries an already-read hull angle through candidate search, +rejects incompatible closure sections before paying for exact orientation, +and compiles the exact predicate and repair kernels at their LLVM `-O3` +boundary. + +Receipt identity: + +- command completed: `2026-08-17T10:39:30Z`, 297.39 s over 120 cases +- host: Apple M4 Pro, arm64, macOS 26.5.2, GHC 9.14.1, rustc 1.92.0 +- Haskell build: Cabal `-O1` package profile, comparison executable `-O2`, hot + predicate, sweep, and repair modules LLVM `-O3` +- checkout HEAD: `6da6feb1a6`, with seven modified files in the tree, none of + them on the measured path +- CSV: [`moonlight-delaunay-compare-2026-08-17.csv`](results/moonlight-delaunay-compare-2026-08-17.csv), SHA-256 + `eba77eb960790f2e1cbe3f82c112e8690721de4e5aa3c69961925670e0822162` +- benchmark runtime-source hashes: + [`moonlight-delaunay-compare-2026-08-17.source-sha256`](results/moonlight-delaunay-compare-2026-08-17.source-sha256) + +The Haskell projection in +`Moonlight.Triangulation.Bench.DelaunayCompare.Picture` parses the tasty-bench +CSV against the exact closed 120-case registry and reports typed obstructions +for malformed, unknown, duplicated, or missing observations before gluing +either picture. + +## Run + +From the repository root, list the complete benchmark tree: + +```console +scripts/safe-cabal.sh run \ + moonlight-triangulation:exe:moonlight-triangulation-delaunay-compare \ + -- --list-tests +``` + +Run the comparison on one uncontended thread with wall-clock timing: + +```console +scripts/safe-cabal.sh run \ + moonlight-triangulation:exe:moonlight-triangulation-delaunay-compare \ + -- --time-mode wall -j1 +``` + +The Haskell executable builds the pinned Rust library through Cargo before it +loads the library. Cargo's incremental no-op is cheap after the first run. Set +`MOONLIGHT_DELAUNAY_COMPARE_RUST_MANIFEST` only when invoking an installed executable +outside this repository layout. + +## Reproduce a board + +Every candidate run uses one CPU-time worker, a 30-second per-case timeout, and +tasty-bench's `--stdev 5` calibration target. Name the candidate by the date it +completed; after validation, it replaces the retained CSV and source manifest +rather than accumulating a benchmark diary. + +```console +caffeinate -i scripts/safe-cabal.sh run \ + moonlight-triangulation:exe:moonlight-triangulation-delaunay-compare -- \ + --stdev 5 --timeout 30s --time-mode cpu -j1 \ + --csv foundation/moonlight-triangulation/bench/delaunay-compare/results/moonlight-delaunay-compare-YYYY-MM-DD.csv \ + --color never --hide-progress --min-duration-to-report 1h +``` + +Both pictures are then regenerated from the candidate CSV, which is the only +CSV they may be derived from: + +```console +scripts/safe-cabal.sh run \ + moonlight-triangulation:exe:moonlight-triangulation-delaunay-pictures -- \ + foundation/moonlight-triangulation/bench/delaunay-compare/results/moonlight-delaunay-compare-YYYY-MM-DD.csv \ + foundation/moonlight-triangulation/bench/delaunay-compare/results +``` + +The runtime-source manifest beside the CSV is the list of files that entered +timed actions, hashed at run time; picture sources and package-only metadata +are excluded because they do not. The receipt and SVGs stay package-owned +beside the benchmark but are not Cabal package inputs, because taking a +measurement must not rebuild the triangulation library. + +## Upstream-compatible fixtures + +Both distributions use the 32-byte `StdRng` seed from upstream, including its +embedded newline byte. Rust unit tests pin the first three points of both +streams by their exact binary64 bit patterns. + +- `local insertion` starts at `(0, 1)` and adds independent inclusive steps + from `[-1, 1]`. +- `uniform` draws each coordinate independently and inclusively from + `[-1e9, 1e9]`. +- `small` contains 2,000 through 14,000 points in increments of 2,000. +- `big` contains 50,000 through 250,000 points in increments of 50,000. + +Native input conversion happens once during suite preparation, outside every +timed action, exactly as upstream's `DelaunayCrate.init` separates conversion +from `run_creation`. Spade still clones its owned vertex vector inside each +construction call because that is what its bulk-load API and upstream adapter +require; `cdt`, `delaunator`, and Moonlight consume their prepared vectors by +reference. + +## Compatibility gate + +Before `tasty-bench` runs, every one of the 24 fixtures descends across all five +implementations. The sections glue only when vertex and inner-triangle counts +agree. A generator, preparation, construction, foreign-boundary, or summary +failure is a typed obstruction and terminates the command before timing. + +This count gate is deliberately not a second topology authority. The stronger +Moonlight-versus-Spade canonical-edge and operation agreement owner is the +[`spade-compare` operation suite](../spade-compare/README.md); use it when making semantic parity claims. This command answers +the narrower upstream question: bulk construction time over the upstream point +distributions and sizes. + +The upstream `examples/real_data_benchmark.rs` CDT/shapefile program is a +separate executable and is not folded into this creation suite. No 45 MB dataset +or network fetch is concealed in benchmark startup. + +## Harness difference + +Upstream uses Rust Criterion. This port uses Haskell `tasty-bench`, so it does +not pretend Criterion's warm-up seconds or sample-count knobs map one-to-one to +another calibrator. The inputs, sizes, implementation calls, and timed/setup +boundary are preserved; calibration and reporting are honestly Haskell. diff --git a/bench/delaunay-compare/rust/Cargo.lock b/bench/delaunay-compare/rust/Cargo.lock new file mode 100644 --- /dev/null +++ b/bench/delaunay-compare/rust/Cargo.lock @@ -0,0 +1,264 @@ +# This file is automatically @generated by Cargo. +# It is not intended for manual editing. +version = 4 + +[[package]] +name = "allocator-api2" +version = "0.2.21" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "683d7910e743518b0e34f1186f92494becacb047c7b6bf616c96772180fef923" + +[[package]] +name = "autocfg" +version = "1.5.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "f2032f911046de80f0a198e0901378627c33f59ea0ac00e363d481118bd70a53" + +[[package]] +name = "cdt" +version = "0.1.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "b91b872294f63ef586b32aa94141561681aa35ca2d703960cca4f661f4e18184" +dependencies = [ + "geometry-predicates", + "thiserror", +] + +[[package]] +name = "cfg-if" +version = "1.0.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "9330f8b2ff13f34540b44e946ef35111825727b38d33286ef986142615121801" + +[[package]] +name = "delaunator" +version = "1.1.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "3e1ee323c1275374f7e612d3724d12707079fb6a2117349fe144def656f5a880" +dependencies = [ + "robust", +] + +[[package]] +name = "equivalent" +version = "1.0.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "877a4ace8713b0bcf2a4e7eec82529c029f1d0619886d18145fea96c3ffe5c0f" + +[[package]] +name = "foldhash" +version = "0.2.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "77ce24cb58228fbb8aa041425bb1050850ac19177686ea6e0f41a70416f56fdb" + +[[package]] +name = "geometry-predicates" +version = "0.3.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "8dba84198cf199c11b83f1cb9243eaeb70dc50b719d2835ebf34bf2481bca010" + +[[package]] +name = "getrandom" +version = "0.3.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "899def5c37c4fd7b2664648c28120ecec138e4d395b459e5ca34f9cce2dd77fd" +dependencies = [ + "cfg-if", + "libc", + "r-efi", + "wasip2", +] + +[[package]] +name = "hashbrown" +version = "0.16.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "841d1cc9bed7f9236f321df977030373f4a4163ae1a7dbfe1a51a2c1a51d9100" +dependencies = [ + "allocator-api2", + "equivalent", + "foldhash", +] + +[[package]] +name = "libc" +version = "0.2.189" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "3eaf3ede3fee6db1a4c2ee091bf8a8b4dccdc6d17f656fb07896ee72867612f2" + +[[package]] +name = "moonlight-delaunay-compare-referents" +version = "0.1.0" +dependencies = [ + "cdt", + "delaunator", + "rand", + "spade", +] + +[[package]] +name = "num-traits" +version = "0.2.19" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "071dfc062690e90b734c0b2273ce72ad0ffa95f0c74596bc250dcfd960262841" +dependencies = [ + "autocfg", +] + +[[package]] +name = "ppv-lite86" +version = "0.2.21" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "85eae3c4ed2f50dcfe72643da4befc30deadb458a9b590d720cde2f2b1e97da9" +dependencies = [ + "zerocopy", +] + +[[package]] +name = "proc-macro2" +version = "1.0.107" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "985e7ec9bb745e6ce6535b544d84d6cd6f7ad8bd711c398938ae983b91a766d9" +dependencies = [ + "unicode-ident", +] + +[[package]] +name = "quote" +version = "1.0.47" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "1fbf4db142a473a8d80c26bbf18454ed458bf8d26c8219c331daecfdbd079001" +dependencies = [ + "proc-macro2", +] + +[[package]] +name = "r-efi" +version = "5.3.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "69cdb34c158ceb288df11e18b4bd39de994f6657d83847bdffdbd7f346754b0f" + +[[package]] +name = "rand" +version = "0.9.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "b9ef1d0d795eb7d84685bca4f72f3649f064e6641543d3a8c415898726a57b41" +dependencies = [ + "rand_chacha", + "rand_core", +] + +[[package]] +name = "rand_chacha" +version = "0.9.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "d3022b5f1df60f26e1ffddd6c66e8aa15de382ae63b3a0c1bfc0e4d3e3f325cb" +dependencies = [ + "ppv-lite86", + "rand_core", +] + +[[package]] +name = "rand_core" +version = "0.9.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "76afc826de14238e6e8c374ddcc1fa19e374fd8dd986b0d2af0d02377261d83c" +dependencies = [ + "getrandom", +] + +[[package]] +name = "robust" +version = "1.2.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "4e27ee8bb91ca0adcf0ecb116293afa12d393f9c2b9b9cd54d33e8078fe19839" + +[[package]] +name = "smallvec" +version = "1.15.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "8ed6a63f02c8539c91a8685a86f4099661ba3da017932f6ebbea6de3f0fa7c90" + +[[package]] +name = "spade" +version = "2.15.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "9699399fd9349b00b184f5635b074f9ec93afffef30c853f8c875b32c0f8c7fa" +dependencies = [ + "hashbrown", + "num-traits", + "robust", + "smallvec", +] + +[[package]] +name = "syn" +version = "2.0.119" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "872831b642d1a07999a962a351ed35b955ea2cfc8f3862091e2a240a84f17297" +dependencies = [ + "proc-macro2", + "quote", + "unicode-ident", +] + +[[package]] +name = "thiserror" +version = "1.0.69" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "b6aaf5339b578ea85b50e080feb250a3e8ae8cfcdff9a461c9ec2904bc923f52" +dependencies = [ + "thiserror-impl", +] + +[[package]] +name = "thiserror-impl" +version = "1.0.69" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "4fee6c4efc90059e10f81e6d42c60a18f76588c3d74cb83a0b242a2b6c7504c1" +dependencies = [ + "proc-macro2", + "quote", + "syn", +] + +[[package]] +name = "unicode-ident" +version = "1.0.24" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "e6e4313cd5fcd3dad5cafa179702e2b244f760991f45397d14d4ebf38247da75" + +[[package]] +name = "wasip2" +version = "1.0.4+wasi-0.2.12" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "b67efb37e106e55ce722a510d6b5f9c17f083e5fc79afc2badeb12cc313d9487" +dependencies = [ + "wit-bindgen", +] + +[[package]] +name = "wit-bindgen" +version = "0.57.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "1ebf944e87a7c253233ad6766e082e3cd714b5d03812acc24c318f549614536e" + +[[package]] +name = "zerocopy" +version = "0.8.56" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "556764e583adb45a9f8d413c2a147fa7e8d821e48e12b14fd560b607998b75eb" +dependencies = [ + "zerocopy-derive", +] + +[[package]] +name = "zerocopy-derive" +version = "0.8.56" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "f2ab42fc20575779bd240faa45f94a74256f755c0fa9e89f0ede20d91d0cdfc1" +dependencies = [ + "proc-macro2", + "quote", + "syn", +] diff --git a/bench/delaunay-compare/rust/Cargo.toml b/bench/delaunay-compare/rust/Cargo.toml new file mode 100644 --- /dev/null +++ b/bench/delaunay-compare/rust/Cargo.toml @@ -0,0 +1,20 @@ +[workspace] + +[package] +name = "moonlight-delaunay-compare-referents" +version = "0.1.0" +edition = "2021" + +[lib] +name = "moonlight_delaunay_compare_referents" +crate-type = ["cdylib"] + +[dependencies] +cdt = "0.1" +delaunator = "1.0.1" +rand = "0.9.1" +spade = "2.15" + +[profile.release] +opt-level = 3 +lto = "thin" diff --git a/bench/delaunay-compare/rust/src/lib.rs b/bench/delaunay-compare/rust/src/lib.rs new file mode 100644 --- /dev/null +++ b/bench/delaunay-compare/rust/src/lib.rs @@ -0,0 +1,397 @@ +//! Rust referent boundary for Moonlight's Delaunay construction comparison. +//! +//! Fixture choice, benchmark grouping, agreement, timing, and reporting belong +//! to Haskell. This library retains only the operations that cannot move there: +//! Spade's exact seeded generator and direct calls into the Rust crates under +//! comparison. + +use core::ffi::c_void; +use core::hint::black_box; +use core::ptr; +use rand::distr::{Distribution, Uniform}; +use rand::rngs::StdRng; +use rand::SeedableRng; +use spade::{HierarchyHintGenerator, Point2, Triangulation}; +use std::panic::{catch_unwind, AssertUnwindSafe}; + +const UPSTREAM_SEED: [u8; 32] = [ + 0xfb, 0xdc, 0x4e, 0xa0, 0x30, 0xde, 0x82, 0xba, 0x69, 0x97, 0x3c, 0x52, 0x49, 0x4d, 0x00, 0xca, + 0x0a, 0x5c, 0x21, 0xa3, 0x8d, 0x5c, 0xf2, 0x34, 0x4e, 0x58, 0x7d, 0x80, 0x16, 0x66, 0x23, 0x30, +]; + +const UNIFORM_RANGE: f64 = 1.0e9; +const LOCAL_STEP_RANGE: f64 = 1.0; + +type PlainSpade = spade::DelaunayTriangulation>; +type HierarchySpade = + spade::DelaunayTriangulation, (), (), (), HierarchyHintGenerator>; + +#[repr(i32)] +#[derive(Clone, Copy, Debug)] +enum BoundaryStatus { + Success = 0, + NullPointer = 1, + UnknownTag = 2, + CoordinateCountMismatch = 3, + DistributionConstructionFailed = 4, + TriangulationFailed = 5, + Panicked = 6, +} + +impl BoundaryStatus { + const fn code(self) -> i32 { + self as i32 + } +} + +#[derive(Clone, Copy)] +enum PointDistribution { + LocalInsertion, + Uniform, +} + +impl TryFrom for PointDistribution { + type Error = BoundaryStatus; + + fn try_from(tag: i32) -> Result { + match tag { + 0 => Ok(Self::LocalInsertion), + 1 => Ok(Self::Uniform), + _ => Err(BoundaryStatus::UnknownTag), + } + } +} + +#[derive(Clone, Copy)] +enum NativeImplementation { + Spade, + SpadeHierarchy, + Cdt, + Delaunator, +} + +impl TryFrom for NativeImplementation { + type Error = BoundaryStatus; + + fn try_from(tag: i32) -> Result { + match tag { + 0 => Ok(Self::Spade), + 1 => Ok(Self::SpadeHierarchy), + 2 => Ok(Self::Cdt), + 3 => Ok(Self::Delaunator), + _ => Err(BoundaryStatus::UnknownTag), + } + } +} + +enum PreparedImplementation { + Spade(Vec>), + SpadeHierarchy(Vec>), + Cdt(Vec<(f64, f64)>), + Delaunator(Vec), +} + +#[derive(Clone, Copy)] +struct ConstructionSummary { + vertices: usize, + triangles: usize, +} + +impl PreparedImplementation { + fn from_coordinates(implementation: NativeImplementation, coordinates: &[[f64; 2]]) -> Self { + match implementation { + NativeImplementation::Spade => { + Self::Spade(coordinates.iter().copied().map(Point2::from).collect()) + } + NativeImplementation::SpadeHierarchy => { + Self::SpadeHierarchy(coordinates.iter().copied().map(Point2::from).collect()) + } + NativeImplementation::Cdt => { + Self::Cdt(coordinates.iter().map(|[x, y]| (*x, *y)).collect()) + } + NativeImplementation::Delaunator => Self::Delaunator( + coordinates + .iter() + .map(|[x, y]| delaunator::Point { x: *x, y: *y }) + .collect(), + ), + } + } + + fn run(&self) -> Result { + match self { + Self::Spade(vertices) => { + let triangulation = PlainSpade::bulk_load(vertices.clone()) + .map_err(|_| BoundaryStatus::TriangulationFailed)?; + let summary = ConstructionSummary { + vertices: triangulation.num_vertices(), + triangles: triangulation.num_inner_faces(), + }; + black_box(triangulation); + Ok(summary) + } + Self::SpadeHierarchy(vertices) => { + let triangulation = HierarchySpade::bulk_load(vertices.clone()) + .map_err(|_| BoundaryStatus::TriangulationFailed)?; + let summary = ConstructionSummary { + vertices: triangulation.num_vertices(), + triangles: triangulation.num_inner_faces(), + }; + black_box(triangulation); + Ok(summary) + } + Self::Cdt(vertices) => { + let triangles = cdt::triangulate_points(vertices) + .map_err(|_| BoundaryStatus::TriangulationFailed)?; + let summary = ConstructionSummary { + vertices: vertices.len(), + triangles: triangles.len(), + }; + black_box(triangles); + Ok(summary) + } + Self::Delaunator(vertices) => { + let triangulation = delaunator::triangulate(vertices); + let summary = ConstructionSummary { + vertices: vertices.len(), + triangles: triangulation.triangles.len() / 3, + }; + black_box(triangulation); + Ok(summary) + } + } + } +} + +fn boundary_status(action: impl FnOnce() -> Result<(), BoundaryStatus>) -> i32 { + match catch_unwind(AssertUnwindSafe(action)) { + Ok(Ok(())) => BoundaryStatus::Success.code(), + Ok(Err(status)) => status.code(), + Err(_) => BoundaryStatus::Panicked.code(), + } +} + +fn coordinate_count(point_count: usize) -> Result { + point_count + .checked_mul(2) + .ok_or(BoundaryStatus::CoordinateCountMismatch) +} + +fn uniform_samples(point_count: usize) -> Result, BoundaryStatus> { + let distribution = Uniform::new_inclusive(-UNIFORM_RANGE, UNIFORM_RANGE) + .map_err(|_| BoundaryStatus::DistributionConstructionFailed)?; + let mut generator = StdRng::from_seed(UPSTREAM_SEED); + Ok(core::iter::from_fn(move || { + Some([ + distribution.sample(&mut generator), + distribution.sample(&mut generator), + ]) + }) + .take(point_count)) +} + +fn local_insertion_samples( + point_count: usize, +) -> Result, BoundaryStatus> { + let distribution = Uniform::new_inclusive(-LOCAL_STEP_RANGE, LOCAL_STEP_RANGE) + .map_err(|_| BoundaryStatus::DistributionConstructionFailed)?; + let mut generator = StdRng::from_seed(UPSTREAM_SEED); + let mut previous = [0.0, 1.0]; + Ok(core::iter::from_fn(move || { + previous = [ + previous[0] + distribution.sample(&mut generator), + previous[1] + distribution.sample(&mut generator), + ]; + Some(previous) + }) + .take(point_count)) +} + +fn write_coordinates( + distribution: PointDistribution, + point_count: usize, + output: &mut [f64], +) -> Result<(), BoundaryStatus> { + let expected_count = coordinate_count(point_count)?; + if output.len() != expected_count { + return Err(BoundaryStatus::CoordinateCountMismatch); + } + + let samples: Box> = match distribution { + PointDistribution::LocalInsertion => Box::new(local_insertion_samples(point_count)?), + PointDistribution::Uniform => Box::new(uniform_samples(point_count)?), + }; + + output + .chunks_exact_mut(2) + .zip(samples) + .for_each(|(coordinate_pair, [x, y])| { + coordinate_pair.copy_from_slice(&[x, y]); + }); + Ok(()) +} + +/// Fill `coordinates` with Spade's exact seeded benchmark distribution. +/// +/// # Safety +/// +/// A non-null `coordinates` pointer must be writable for `coordinate_count` +/// consecutive `f64` values. +#[no_mangle] +pub unsafe extern "C" fn delaunay_compare_generate( + distribution_tag: i32, + point_count: usize, + coordinates: *mut f64, + supplied_coordinate_count: usize, +) -> i32 { + boundary_status(|| { + let distribution = PointDistribution::try_from(distribution_tag)?; + let expected_count = coordinate_count(point_count)?; + if supplied_coordinate_count != expected_count { + return Err(BoundaryStatus::CoordinateCountMismatch); + } + if coordinates.is_null() && supplied_coordinate_count != 0 { + return Err(BoundaryStatus::NullPointer); + } + let output = if supplied_coordinate_count == 0 { + &mut [] + } else { + // SAFETY: the caller contract and checks above establish a non-null + // writable region of exactly `supplied_coordinate_count` values. + unsafe { core::slice::from_raw_parts_mut(coordinates, supplied_coordinate_count) } + }; + write_coordinates(distribution, point_count, output) + }) +} + +/// Prepare the implementation-specific native input outside the timed region. +/// +/// # Safety +/// +/// A non-null `coordinates` pointer must be readable for `2 * point_count` +/// consecutive `f64` values. `prepared_output` must be writable for one pointer. +#[no_mangle] +pub unsafe extern "C" fn delaunay_compare_prepare( + implementation_tag: i32, + coordinates: *const f64, + point_count: usize, + prepared_output: *mut *mut c_void, +) -> i32 { + boundary_status(|| { + let implementation = NativeImplementation::try_from(implementation_tag)?; + if prepared_output.is_null() { + return Err(BoundaryStatus::NullPointer); + } + let supplied_coordinate_count = coordinate_count(point_count)?; + if coordinates.is_null() && supplied_coordinate_count != 0 { + return Err(BoundaryStatus::NullPointer); + } + let flat_coordinates = if supplied_coordinate_count == 0 { + &[] + } else { + // SAFETY: the caller contract and checks above establish a non-null + // readable region of exactly `supplied_coordinate_count` values. + unsafe { core::slice::from_raw_parts(coordinates, supplied_coordinate_count) } + }; + let coordinate_pairs = flat_coordinates.as_chunks::<2>().0; + let prepared = PreparedImplementation::from_coordinates(implementation, coordinate_pairs); + // SAFETY: `prepared_output` was checked non-null and points to writable + // storage for one opaque pointer by the caller contract. + unsafe { + ptr::write(prepared_output, Box::into_raw(Box::new(prepared)).cast()); + } + Ok(()) + }) +} + +/// Construct one triangulation from a prepared native input. +/// +/// # Safety +/// +/// `prepared` must be a live pointer returned by `delaunay_compare_prepare`. +/// Both output pointers must be writable for one `usize`. +#[no_mangle] +pub unsafe extern "C" fn delaunay_compare_run( + prepared: *const c_void, + vertex_count_output: *mut usize, + triangle_count_output: *mut usize, +) -> i32 { + boundary_status(|| { + if prepared.is_null() || vertex_count_output.is_null() || triangle_count_output.is_null() { + return Err(BoundaryStatus::NullPointer); + } + // SAFETY: the caller contract requires a live pointer produced by the + // matching prepare function and keeps it alive for this call. + let prepared_implementation = unsafe { &*prepared.cast::() }; + let summary = prepared_implementation.run()?; + // SAFETY: both output pointers were checked non-null and the caller + // contract gives writable storage for one value at each address. + unsafe { + ptr::write(vertex_count_output, summary.vertices); + ptr::write(triangle_count_output, summary.triangles); + } + Ok(()) + }) +} + +/// Release one prepared native input. A null pointer is a no-op. +/// +/// # Safety +/// +/// A non-null pointer must have been returned by `delaunay_compare_prepare` +/// and must not have been released before. +#[no_mangle] +pub unsafe extern "C" fn delaunay_compare_release(prepared: *mut c_void) { + if !prepared.is_null() { + // SAFETY: the caller contract transfers the one remaining ownership of + // the allocation produced by `Box::into_raw` in the prepare function. + unsafe { + drop(Box::from_raw(prepared.cast::())); + } + } +} + +#[cfg(test)] +mod tests { + use super::{local_insertion_samples, uniform_samples}; + + #[test] + fn local_insertion_prefix_matches_upstream_fixture_bits() { + let observed = local_insertion_samples(3) + .expect("the fixed local-insertion distribution is valid") + .flatten() + .map(f64::to_bits) + .collect::>(); + assert_eq!( + observed, + [ + 0xbfe28b04856ac6db, + 0x3ff8c718b563a19a, + 0x3fc014ab09d22a14, + 0x4003a1ee45dc4712, + 0xbfd097c41d82adc4, + 0x4008d420538d5c3d, + ] + ); + } + + #[test] + fn uniform_prefix_matches_upstream_fixture_bits() { + let observed = uniform_samples(3) + .expect("the fixed uniform distribution is valid") + .flatten() + .map(f64::to_bits) + .collect::>(); + assert_eq!( + observed, + [ + 0xc1c1450134a5bd5a, + 0x41c0598b1e249a72, + 0x41c5037dbf1c0b38, + 0x41cafc1cf53845c8, + 0xc1b6f1036f0b1386, + 0x41c35b5d4df8b356, + ] + ); + } +} diff --git a/bench/support/BenchSupport.hs b/bench/support/BenchSupport.hs --- a/bench/support/BenchSupport.hs +++ b/bench/support/BenchSupport.hs @@ -18,8 +18,9 @@ import Data.Word (Word64) import qualified Data.Vector as V import GHC.Clock (getMonotonicTimeNSec) +import GHC.Conc.Sync (getAllocationCounter) import GHC.Stats - ( RTSStats (allocated_bytes, max_live_bytes) + ( RTSStats (max_live_bytes) , getRTSStats , getRTSStatsEnabled ) @@ -40,24 +41,33 @@ -- on one capability the two agree, and where they diverge the ratio is the -- parallelism actually obtained. Reporting CPU alone, as this did, would let a -- change that halves elapsed time and doubles total work read as a regression. +-- Allocation comes from the per-thread counter, not from @RTSStats@. The RTS +-- field is only refreshed at a collection, so a lane whose whole allocation +-- fits between two GCs reports a delta of exactly zero — the instrument +-- saturates at the bottom and reads as a perfect result. The thread counter is +-- block-granular and monotone, so a lane that allocates less says so. +-- +-- @max_live_bytes@ is left as the RTS reports it and is a whole-process running +-- maximum sampled at major collections, never this lane's residency. Read it +-- as the watermark up to here, and only against a run with the same GC +-- schedule; @-G1@ is what makes two schedules comparable. timedValue :: NFData value => String -> IO value -> IO value timedValue label action = do statsEnabled <- getRTSStatsEnabled - before <- if statsEnabled then Just <$> getRTSStats else pure Nothing + allocationStart <- getAllocationCounter wallStart <- getMonotonicTimeNSec cpuStart <- getCPUTime value <- action >>= evaluate . force cpuEnd <- getCPUTime wallEnd <- getMonotonicTimeNSec + allocationEnd <- getAllocationCounter after <- if statsEnabled then Just <$> getRTSStats else pure Nothing putStrLn (label <> "-elapsed: " <> show (fromIntegral (wallEnd - wallStart) / 1.0e9 :: Double) <> "s") putStrLn (label <> "-cpu: " <> show (fromIntegral (cpuEnd - cpuStart) / 1.0e12 :: Double) <> "s") - case (before, after) of - (Just left, Just right) -> - do - putStrLn (label <> "-allocated-bytes: " <> show (allocated_bytes right - allocated_bytes left)) - putStrLn (label <> "-max-live-bytes: " <> show (max_live_bytes right)) - _ -> pure () + putStrLn (label <> "-allocated-bytes: " <> show (allocationStart - allocationEnd)) + case after of + Just right -> putStrLn (label <> "-process-max-live-bytes: " <> show (max_live_bytes right)) + Nothing -> pure () pure value requireRight :: Show error => Either error value -> IO value diff --git a/bindings/README.md b/bindings/README.md --- a/bindings/README.md +++ b/bindings/README.md @@ -1,55 +1,91 @@ # Foreign bindings -`moonlight-triangulation.cabal` owns a private Haskell `ffi` sublibrary and the +`moonlight-triangulation.cabal` owns the private Haskell `ffi` sublibrary and `moonlight-triangulation-c` foreign library. Python, TypeScript, and Rust are -leaf bindings over that sole C ABI; none restates the engine or mesh. +thin lifecycle and bulk-layout leaves over that sole ABI; none implements +triangulation, overlay, publication, valuation, or morphology. From `compiler`, build and locate the shared library: ```bash -cabal build moonlight-triangulation:flib:moonlight-triangulation-c --enable-shared --project-file=cabal.project.triangulation-dev -cabal list-bin moonlight-triangulation:flib:moonlight-triangulation-c --enable-shared --project-file=cabal.project.triangulation-dev +../scripts/safe-cabal.sh build \ + moonlight-triangulation:flib:moonlight-triangulation-c \ + --project-file=cabal.project.triangulation-dev --enable-shared -j1 +cabal list-bin moonlight-triangulation:flib:moonlight-triangulation-c \ + --project-file=cabal.project.triangulation-dev --enable-shared ``` Set `MOONLIGHT_TRIANGULATION_LIBRARY` to that `.dylib`, `.so`, or `.dll`; Rust linking also reads its directory from `MOONLIGHT_TRIANGULATION_LIB_DIR`. -The ABI accepts interleaved binary64 coordinates and publishes opaque immutable -mesh handles. Set operations and batch insertion return new handles, leaving -inputs valid until freed. Dense vertices and triangles follow vertex-handle and -bounded-face-handle order. Every status-returning call accepts an optional -`ml_obstruction` distinguishing API misuse, capacity refusal, geometric -obstruction, and runtime failure, with retained index, value, coordinate, and -message witnesses. `UINT64_MAX` means no input index applies. +## ABI version 2 -Batch related edits into one `insert_many` call; each call publishes a new mesh, -so repeated singleton calls pay repeated publication costs. +Three opaque immutable carriers cross the boundary: -`ml_runtime_initialize` is idempotent and process-lifetime. There is no shutdown -call because GHC cannot reliably restart after its outermost `hs_exit`. +- `ml_mesh` retains a binary64 Delaunay mesh. Its `ml_mesh_site_*` algebra + combines sites, not polygon interiors. +- `ml_region` retains the authoritative exact rational `PlanarRegion`. + `ml_region_create_f64` admits every input coordinate exactly as its binary64 + dyadic value in one call, using point counts per loop and loop counts per + component. The inverse bulk projection returns component/loop offsets and + binary64 rendering points; it does not replace the exact retained geometry. +- `ml_structuring_element` retains one admitted origin-containing convex + polygon for repeated offset, inset, opening, and closing calls. +Region union, intersection, difference, and symmetric difference call the one +Haskell overlay and grouped-publication path. Point location is exact. A single +valuation call returns Euler characteristic, exact reduced area as +`numerator/denominator`, and certified conventional-perimeter bounds. Morphology +returns a new region plus the existing operation/work receipt. + +Every status-returning call accepts an optional `ml_obstruction` distinguishing +pointer/count/buffer failures from region layout, validation, overlay, +publication, valuation, projection, morphology, and runtime failures. Handles +remain valid until explicitly freed; every operation publishes a fresh output +handle. `ml_runtime_initialize` is idempotent and process-lifetime. + +Batch related mesh edits into one `insert_many` call. Author a whole region with +one component list; there is deliberately no mutable builder or per-vertex FFI +surface. + ## Python ```python -from moonlight_triangulation import Moonlight -mesh = Moonlight().delaunay([(0, 0), (1, 0), (0, 1)]) -print(mesh.vertices, mesh.triangles) -mesh.close() +from fractions import Fraction +from moonlight_triangulation import Moonlight, PolygonComponent + +moonlight = Moonlight() +left = moonlight.region([ + PolygonComponent(((0, 0), (2, 0), (2, 2), (0, 2))) +]) +right = moonlight.region([ + PolygonComponent(((1, 0), (3, 0), (3, 2), (1, 2))) +]) +intersection = left.intersection(right) +assert intersection.valuations.area == Fraction(2, 1) ``` ## TypeScript ```typescript -import { Moonlight } from "@moonlight/triangulation"; -const mesh = new Moonlight().delaunay([[0, 0], [1, 0], [0, 1]]); -console.log(mesh.vertices(), mesh.triangles()); -mesh.close(); +import { Moonlight, RegionLocation } from "@moonlight/triangulation"; + +const moonlight = new Moonlight(); +const region = moonlight.region([ + { outer: [[0, 0], [2, 0], [2, 2], [0, 2]] }, +]); +console.log(region.valuations().area, region.locate([1, 1]) === RegionLocation.Interior); ``` ## Rust ```rust -use moonlight_triangulation::Moonlight; -let mesh = Moonlight::initialize()?.delaunay(&[[0.0, 0.0], [1.0, 0.0], [0.0, 1.0]])?; -println!("{:?} {:?}", mesh.vertices()?, mesh.triangles()?); +use moonlight_triangulation::{Moonlight, PolygonComponent}; + +let moonlight = Moonlight::initialize()?; +let region = moonlight.region(&[PolygonComponent { + outer: vec![[0.0, 0.0], [2.0, 0.0], [2.0, 2.0], [0.0, 2.0]], + holes: vec![], +}])?; +println!("{:?}", region.valuations()?.area); ``` diff --git a/bindings/python/pyproject.toml b/bindings/python/pyproject.toml --- a/bindings/python/pyproject.toml +++ b/bindings/python/pyproject.toml @@ -4,8 +4,8 @@ [project] name = "moonlight-triangulation" -version = "1.0.0" -description = "Python bindings for Moonlight's immutable Delaunay mesh algebra." +version = "2.0.0" +description = "Python bindings for Moonlight exact regions and immutable Delaunay meshes." requires-python = ">=3.11" license = { text = "MIT" } diff --git a/bindings/python/src/moonlight_triangulation/__init__.py b/bindings/python/src/moonlight_triangulation/__init__.py --- a/bindings/python/src/moonlight_triangulation/__init__.py +++ b/bindings/python/src/moonlight_triangulation/__init__.py @@ -3,9 +3,13 @@ import ctypes import os import weakref -from collections.abc import Callable, Sequence +from array import array +from collections.abc import Callable, Iterable, Sequence +from dataclasses import dataclass +from enum import IntEnum +from fractions import Fraction from pathlib import Path -from typing import Final +from typing import Final, Self class _Obstruction(ctypes.Structure): @@ -23,6 +27,21 @@ ] +class _NativeMinkowskiReceipt(ctypes.Structure): + _fields_ = [ + ("operation", ctypes.c_uint32), + ("reserved", ctypes.c_uint32), + ("input_components", ctypes.c_uint64), + ("convex_pieces", ctypes.c_uint64), + ("generated_pieces", ctypes.c_uint64), + ("generated_convolution_edges", ctypes.c_uint64), + ("overlay_passes", ctypes.c_uint64), + ("exact_crossings", ctypes.c_uint64), + ("output_cells", ctypes.c_uint64), + ("exact_coordinate_bit_growth", ctypes.c_uint64), + ] + + class MoonlightError(RuntimeError): def __init__(self, status: int, obstruction: _Obstruction) -> None: self.status = status @@ -40,32 +59,94 @@ class _NativeApi: _OK: Final = 0 + _ABI_VERSION: Final = 2 def __init__(self, library_path: Path) -> None: library = ctypes.CDLL(str(library_path)) - mesh = ctypes.c_void_p - mesh_output = ctypes.POINTER(mesh) + handle = ctypes.c_void_p + handle_output = ctypes.POINTER(handle) obstruction = ctypes.POINTER(_Obstruction) count_output = ctypes.POINTER(ctypes.c_size_t) + receipt_output = ctypes.POINTER(_NativeMinkowskiReceipt) + binary_operation = (handle, handle, handle_output, obstruction) + morphology_operation = (handle, handle, handle_output, receipt_output, obstruction) + _configure(library, "ml_abi_version", ()) _configure(library, "ml_runtime_initialize", ()) - _configure(library, "ml_delaunay_f64", (ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, mesh_output, obstruction)) - _configure(library, "ml_mesh_insert_many_f64", (mesh, ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, mesh_output, obstruction)) - _configure(library, "ml_mesh_union", (mesh, mesh, mesh_output, obstruction)) - _configure(library, "ml_mesh_intersection", (mesh, mesh, mesh_output, obstruction)) - _configure(library, "ml_mesh_difference", (mesh, mesh, mesh_output, obstruction)) - _configure(library, "ml_mesh_symmetric_difference", (mesh, mesh, mesh_output, obstruction)) - _configure(library, "ml_mesh_vertex_count", (mesh, count_output, obstruction)) - _configure(library, "ml_mesh_triangle_count", (mesh, count_output, obstruction)) - _configure(library, "ml_mesh_copy_vertices_f64", (mesh, ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, count_output, obstruction)) - _configure(library, "ml_mesh_copy_triangles_u32", (mesh, ctypes.POINTER(ctypes.c_uint32), ctypes.c_size_t, count_output, obstruction)) - _configure(library, "ml_mesh_free", (mesh,), None) + _configure(library, "ml_delaunay_f64", (ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, handle_output, obstruction)) + _configure(library, "ml_mesh_insert_many_f64", (handle, ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, handle_output, obstruction)) + _configure(library, "ml_mesh_site_union", binary_operation) + _configure(library, "ml_mesh_site_intersection", binary_operation) + _configure(library, "ml_mesh_site_difference", binary_operation) + _configure(library, "ml_mesh_site_symmetric_difference", binary_operation) + _configure(library, "ml_mesh_vertex_count", (handle, count_output, obstruction)) + _configure(library, "ml_mesh_triangle_count", (handle, count_output, obstruction)) + _configure(library, "ml_mesh_copy_vertices_f64", (handle, ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, count_output, obstruction)) + _configure(library, "ml_mesh_copy_triangles_u32", (handle, ctypes.POINTER(ctypes.c_uint32), ctypes.c_size_t, count_output, obstruction)) + _configure(library, "ml_mesh_free", (handle,), None) + _configure( + library, + "ml_region_create_f64", + ( + ctypes.POINTER(ctypes.c_double), + ctypes.c_size_t, + ctypes.POINTER(ctypes.c_size_t), + ctypes.c_size_t, + ctypes.POINTER(ctypes.c_size_t), + ctypes.c_size_t, + handle_output, + obstruction, + ), + ) + _configure(library, "ml_region_counts", (handle, count_output, count_output, count_output, obstruction)) + _configure( + library, + "ml_region_copy_f64", + ( + handle, + ctypes.POINTER(ctypes.c_double), + ctypes.c_size_t, + ctypes.POINTER(ctypes.c_size_t), + ctypes.c_size_t, + ctypes.POINTER(ctypes.c_size_t), + ctypes.c_size_t, + obstruction, + ), + ) + _configure(library, "ml_region_union", binary_operation) + _configure(library, "ml_region_intersection", binary_operation) + _configure(library, "ml_region_difference", binary_operation) + _configure(library, "ml_region_symmetric_difference", binary_operation) + _configure(library, "ml_region_locate_point_f64", (handle, ctypes.c_double, ctypes.c_double, ctypes.POINTER(ctypes.c_uint32), obstruction)) + _configure( + library, + "ml_region_measure", + ( + handle, + ctypes.POINTER(ctypes.c_int64), + ctypes.POINTER(ctypes.c_char), + ctypes.c_size_t, + count_output, + ctypes.POINTER(ctypes.c_double), + ctypes.POINTER(ctypes.c_double), + obstruction, + ), + ) + _configure(library, "ml_region_free", (handle,), None) + _configure(library, "ml_structuring_element_create_f64", (ctypes.POINTER(ctypes.c_double), ctypes.c_size_t, handle_output, obstruction)) + _configure(library, "ml_structuring_element_free", (handle,), None) + _configure(library, "ml_region_minkowski_sum", morphology_operation) + _configure(library, "ml_region_offset", morphology_operation) + _configure(library, "ml_region_inset", morphology_operation) + _configure(library, "ml_region_open", morphology_operation) + _configure(library, "ml_region_close", morphology_operation) + status = int(library.ml_runtime_initialize()) if status != self._OK: raise RuntimeError(f"Moonlight runtime initialization failed with status {status}") abi_version = int(library.ml_abi_version()) - if abi_version != 1: + if abi_version != self._ABI_VERSION: raise RuntimeError(f"unsupported Moonlight ABI version {abi_version}") self.library = library @@ -77,8 +158,48 @@ Point = tuple[float, float] Triangle = tuple[int, int, int] _BinaryNativeOperation = Callable[[ctypes.c_void_p, ctypes.c_void_p, object, object], int] +_MorphologyNativeOperation = Callable[[ctypes.c_void_p, ctypes.c_void_p, object, object, object], int] +@dataclass(frozen=True) +class PolygonComponent: + outer: tuple[Point, ...] + holes: tuple[tuple[Point, ...], ...] = () + + +class RegionLocation(IntEnum): + EXTERIOR = 0 + BOUNDARY = 1 + INTERIOR = 2 + + +class MinkowskiOperation(IntEnum): + ADDITION = 0 + EROSION = 1 + OPENING = 2 + CLOSING = 3 + + +@dataclass(frozen=True) +class RegionValuations: + euler_characteristic: int + area: Fraction + perimeter_bounds: tuple[float, float] + + +@dataclass(frozen=True) +class MinkowskiReceipt: + operation: MinkowskiOperation + input_components: int + convex_pieces: int + generated_pieces: int + generated_convolution_edges: int + overlay_passes: int + exact_crossings: int + output_cells: int + exact_coordinate_bit_growth: int + + class Moonlight: def __init__(self, library_path: str | os.PathLike[str] | None = None) -> None: configured_path = library_path or os.environ.get("MOONLIGHT_TRIANGULATION_LIBRARY") @@ -88,38 +209,82 @@ def delaunay(self, points: Sequence[Point]) -> Mesh: coordinates, pointer = _coordinate_buffer(points) - output = ctypes.c_void_p() - obstruction = _Obstruction() - status = int( - self._native.library.ml_delaunay_f64( - pointer, - len(points), - ctypes.byref(output), - ctypes.byref(obstruction), - ) + handle = _produce_handle( + self._native, + lambda output, obstruction: self._native.library.ml_delaunay_f64( + pointer, len(points), output, obstruction + ), ) - self._native.check(status, obstruction) - return Mesh(self._native, _required_handle(output)) + return Mesh(self._native, handle) + def region(self, components: Sequence[PolygonComponent]) -> Region: + loops, loop_counts, component_counts = _component_layout(components) + coordinates, coordinate_pointer = _coordinate_buffer( + point for loop in loops for point in loop + ) + loop_buffer = _size_buffer(loop_counts) + component_buffer = _size_buffer(component_counts) + handle = _produce_handle( + self._native, + lambda output, obstruction: self._native.library.ml_region_create_f64( + coordinate_pointer, + sum(loop_counts), + loop_buffer, + len(loop_counts), + component_buffer, + len(component_counts), + output, + obstruction, + ), + ) + return Region(self._native, handle) -class Mesh: - __slots__ = ("_native", "_handle", "_finalizer", "__weakref__") + def structuring_element(self, points: Sequence[Point]) -> StructuringElement: + coordinates, pointer = _coordinate_buffer(points) + handle = _produce_handle( + self._native, + lambda output, obstruction: self._native.library.ml_structuring_element_create_f64( + pointer, len(points), output, obstruction + ), + ) + return StructuringElement(self._native, handle) - def __init__(self, native: _NativeApi, handle: ctypes.c_void_p) -> None: + +class _OwnedHandle: + __slots__ = ("_native", "_handle", "_finalizer", "_kind", "__weakref__") + + def __init__(self, native: _NativeApi, handle: ctypes.c_void_p, free: Callable[[ctypes.c_void_p], None], kind: str) -> None: self._native = native self._handle = handle - self._finalizer = weakref.finalize(self, native.library.ml_mesh_free, handle) + self._kind = kind + self._finalizer = weakref.finalize(self, free, handle) def close(self) -> None: self._finalizer() self._handle = ctypes.c_void_p() - def __enter__(self) -> Mesh: + def __enter__(self) -> Self: return self def __exit__(self, _type: object, _value: object, _traceback: object) -> None: self.close() + def _live_handle(self) -> ctypes.c_void_p: + if not self._finalizer.alive: + raise RuntimeError(f"{self._kind} is closed") + return self._handle + + def _require_same_runtime(self, other: _OwnedHandle) -> None: + if self._native is not other._native: + raise ValueError("both values must belong to the same Moonlight runtime") + + +class Mesh(_OwnedHandle): + __slots__ = () + + def __init__(self, native: _NativeApi, handle: ctypes.c_void_p) -> None: + super().__init__(native, handle, native.library.ml_mesh_free, "mesh") + @property def vertex_count(self) -> int: return self._count(self._native.library.ml_mesh_vertex_count) @@ -136,11 +301,7 @@ obstruction = _Obstruction() status = int( self._native.library.ml_mesh_copy_vertices_f64( - self._live_handle(), - output, - count, - ctypes.byref(written), - ctypes.byref(obstruction), + self._live_handle(), output, count, ctypes.byref(written), ctypes.byref(obstruction) ) ) self._native.check(status, obstruction) @@ -154,11 +315,7 @@ obstruction = _Obstruction() status = int( self._native.library.ml_mesh_copy_triangles_u32( - self._live_handle(), - output, - count, - ctypes.byref(written), - ctypes.byref(obstruction), + self._live_handle(), output, count, ctypes.byref(written), ctypes.byref(obstruction) ) ) self._native.check(status, obstruction) @@ -169,72 +326,279 @@ def insert_many(self, points: Sequence[Point]) -> Mesh: coordinates, pointer = _coordinate_buffer(points) - output = ctypes.c_void_p() + handle = _produce_handle( + self._native, + lambda output, obstruction: self._native.library.ml_mesh_insert_many_f64( + self._live_handle(), pointer, len(points), output, obstruction + ), + ) + return Mesh(self._native, handle) + + def site_union(self, other: Mesh) -> Mesh: + return self._binary(other, self._native.library.ml_mesh_site_union) + + def site_intersection(self, other: Mesh) -> Mesh: + return self._binary(other, self._native.library.ml_mesh_site_intersection) + + def site_difference(self, other: Mesh) -> Mesh: + return self._binary(other, self._native.library.ml_mesh_site_difference) + + def site_symmetric_difference(self, other: Mesh) -> Mesh: + return self._binary(other, self._native.library.ml_mesh_site_symmetric_difference) + + def _binary(self, other: Mesh, operation: _BinaryNativeOperation) -> Mesh: + self._require_same_runtime(other) + handle = _produce_handle( + self._native, + lambda output, obstruction: operation( + self._live_handle(), other._live_handle(), output, obstruction + ), + ) + return Mesh(self._native, handle) + + def _count(self, operation: Callable[[ctypes.c_void_p, object, object], int]) -> int: + output = ctypes.c_size_t() obstruction = _Obstruction() + status = int(operation(self._live_handle(), ctypes.byref(output), ctypes.byref(obstruction))) + self._native.check(status, obstruction) + return int(output.value) + + +class Region(_OwnedHandle): + __slots__ = () + + def __init__(self, native: _NativeApi, handle: ctypes.c_void_p) -> None: + super().__init__(native, handle, native.library.ml_region_free, "region") + + @property + def components(self) -> tuple[PolygonComponent, ...]: + component_count, loop_count, point_count = self._counts() + coordinates = (ctypes.c_double * (point_count * 2))() + loop_offsets = (ctypes.c_size_t * (loop_count + 1))() + component_offsets = (ctypes.c_size_t * (component_count + 1))() + obstruction = _Obstruction() status = int( - self._native.library.ml_mesh_insert_many_f64( + self._native.library.ml_region_copy_f64( self._live_handle(), - pointer, - len(points), - ctypes.byref(output), + coordinates, + point_count, + loop_offsets, + loop_count + 1, + component_offsets, + component_count + 1, ctypes.byref(obstruction), ) ) self._native.check(status, obstruction) - return Mesh(self._native, _required_handle(output)) + points = tuple((float(coordinates[index * 2]), float(coordinates[index * 2 + 1])) for index in range(point_count)) + loops = tuple( + points[int(loop_offsets[index]) : int(loop_offsets[index + 1])] + for index in range(loop_count) + ) + component_ranges = tuple( + (int(component_offsets[index]), int(component_offsets[index + 1])) + for index in range(component_count) + ) + if any(start >= end for start, end in component_ranges): + raise RuntimeError("Moonlight returned a component without an outer loop") + return tuple( + PolygonComponent(loops[start], loops[start + 1 : end]) + for start, end in component_ranges + ) - def union(self, other: Mesh) -> Mesh: - return self._binary(other, self._native.library.ml_mesh_union) + @property + def valuations(self) -> RegionValuations: + return self._measure_with_capacity(128) - def intersection(self, other: Mesh) -> Mesh: - return self._binary(other, self._native.library.ml_mesh_intersection) + def locate(self, point: Point) -> RegionLocation: + output = ctypes.c_uint32() + obstruction = _Obstruction() + status = int( + self._native.library.ml_region_locate_point_f64( + self._live_handle(), point[0], point[1], ctypes.byref(output), ctypes.byref(obstruction) + ) + ) + self._native.check(status, obstruction) + return RegionLocation(output.value) - def difference(self, other: Mesh) -> Mesh: - return self._binary(other, self._native.library.ml_mesh_difference) + def union(self, other: Region) -> Region: + return self._binary(other, self._native.library.ml_region_union) - def symmetric_difference(self, other: Mesh) -> Mesh: - return self._binary(other, self._native.library.ml_mesh_symmetric_difference) + def intersection(self, other: Region) -> Region: + return self._binary(other, self._native.library.ml_region_intersection) - def _binary(self, other: Mesh, operation: _BinaryNativeOperation) -> Mesh: - if self._native is not other._native: - raise ValueError("both meshes must belong to the same Moonlight runtime") - output = ctypes.c_void_p() + def difference(self, other: Region) -> Region: + return self._binary(other, self._native.library.ml_region_difference) + + def symmetric_difference(self, other: Region) -> Region: + return self._binary(other, self._native.library.ml_region_symmetric_difference) + + def minkowski_sum(self, other: Region) -> tuple[Region, MinkowskiReceipt]: + self._require_same_runtime(other) + return self._morph( + lambda output, receipt, obstruction: self._native.library.ml_region_minkowski_sum( + self._live_handle(), other._live_handle(), output, receipt, obstruction + ) + ) + + def offset(self, element: StructuringElement) -> tuple[Region, MinkowskiReceipt]: + return self._with_element(element, self._native.library.ml_region_offset) + + def inset(self, element: StructuringElement) -> tuple[Region, MinkowskiReceipt]: + return self._with_element(element, self._native.library.ml_region_inset) + + def open(self, element: StructuringElement) -> tuple[Region, MinkowskiReceipt]: + return self._with_element(element, self._native.library.ml_region_open) + + def close_with(self, element: StructuringElement) -> tuple[Region, MinkowskiReceipt]: + return self._with_element(element, self._native.library.ml_region_close) + + def _binary(self, other: Region, operation: _BinaryNativeOperation) -> Region: + self._require_same_runtime(other) + handle = _produce_handle( + self._native, + lambda output, obstruction: operation( + self._live_handle(), other._live_handle(), output, obstruction + ), + ) + return Region(self._native, handle) + + def _with_element( + self, element: StructuringElement, operation: _MorphologyNativeOperation + ) -> tuple[Region, MinkowskiReceipt]: + self._require_same_runtime(element) + return self._morph( + lambda output, receipt, obstruction: operation( + element._live_handle(), self._live_handle(), output, receipt, obstruction + ) + ) + + def _morph( + self, + operation: Callable[[object, object, object], int], + ) -> tuple[Region, MinkowskiReceipt]: + handle, native_receipt = _produce_morphology(self._native, operation) + return Region(self._native, handle), _receipt(native_receipt) + + def _counts(self) -> tuple[int, int, int]: + component_count = ctypes.c_size_t() + loop_count = ctypes.c_size_t() + point_count = ctypes.c_size_t() obstruction = _Obstruction() status = int( - operation( + self._native.library.ml_region_counts( self._live_handle(), - other._live_handle(), - ctypes.byref(output), + ctypes.byref(component_count), + ctypes.byref(loop_count), + ctypes.byref(point_count), ctypes.byref(obstruction), ) ) self._native.check(status, obstruction) - return Mesh(self._native, _required_handle(output)) + return int(component_count.value), int(loop_count.value), int(point_count.value) - def _count(self, operation: Callable[[ctypes.c_void_p, object, object], int]) -> int: - output = ctypes.c_size_t() + def _measure_with_capacity(self, capacity: int) -> RegionValuations: + euler = ctypes.c_int64() + area = ctypes.create_string_buffer(capacity) + area_bytes = ctypes.c_size_t() + lower = ctypes.c_double() + upper = ctypes.c_double() obstruction = _Obstruction() - status = int(operation(self._live_handle(), ctypes.byref(output), ctypes.byref(obstruction))) + status = int( + self._native.library.ml_region_measure( + self._live_handle(), + ctypes.byref(euler), + area, + capacity, + ctypes.byref(area_bytes), + ctypes.byref(lower), + ctypes.byref(upper), + ctypes.byref(obstruction), + ) + ) + if status == 3 and obstruction.code == 102: + return self._measure_with_capacity(int(area_bytes.value) + 1) self._native.check(status, obstruction) - return int(output.value) + numerator, separator, denominator = area.value.decode("ascii").partition("/") + if separator != "/": + raise RuntimeError("Moonlight returned a malformed exact-area ratio") + return RegionValuations(int(euler.value), Fraction(int(numerator), int(denominator)), (lower.value, upper.value)) - def _live_handle(self) -> ctypes.c_void_p: - if not self._finalizer.alive: - raise RuntimeError("mesh is closed") - return self._handle +class StructuringElement(_OwnedHandle): + __slots__ = () -def _coordinate_buffer(points: Sequence[Point]) -> tuple[object, object]: - values = tuple(component for x, y in points for component in (x, y)) - if not values: - return (), None - coordinates = (ctypes.c_double * len(values))(*values) - return coordinates, coordinates + def __init__(self, native: _NativeApi, handle: ctypes.c_void_p) -> None: + super().__init__(native, handle, native.library.ml_structuring_element_free, "structuring element") +def _component_layout( + components: Sequence[PolygonComponent], +) -> tuple[tuple[Sequence[Point], ...], tuple[int, ...], tuple[int, ...]]: + loops = tuple( + loop + for component in components + for loop in (component.outer, *component.holes) + ) + loop_counts = tuple(len(loop) for loop in loops) + component_counts = tuple(len(component.holes) + 1 for component in components) + return loops, loop_counts, component_counts + + +def _coordinate_buffer(points: Iterable[Point]) -> tuple[array, object]: + coordinates = array("d", (component for x, y in points for component in (x, y))) + if coordinates.itemsize != ctypes.sizeof(ctypes.c_double): + raise RuntimeError("Python's native double width does not match the Moonlight ABI") + if not coordinates: + return coordinates, None + pointer = (ctypes.c_double * len(coordinates)).from_buffer(coordinates) + return coordinates, pointer + + +def _size_buffer(values: Sequence[int]) -> object: + return (ctypes.c_size_t * len(values))(*values) + + +def _produce_handle( + native: _NativeApi, + operation: Callable[[object, object], int], +) -> ctypes.c_void_p: + output = ctypes.c_void_p() + obstruction = _Obstruction() + status = int(operation(ctypes.byref(output), ctypes.byref(obstruction))) + native.check(status, obstruction) + return _required_handle(output) + + +def _produce_morphology( + native: _NativeApi, + operation: Callable[[object, object, object], int], +) -> tuple[ctypes.c_void_p, _NativeMinkowskiReceipt]: + output = ctypes.c_void_p() + receipt = _NativeMinkowskiReceipt() + obstruction = _Obstruction() + status = int(operation(ctypes.byref(output), ctypes.byref(receipt), ctypes.byref(obstruction))) + native.check(status, obstruction) + return _required_handle(output), receipt + + +def _receipt(native: _NativeMinkowskiReceipt) -> MinkowskiReceipt: + return MinkowskiReceipt( + MinkowskiOperation(native.operation), + int(native.input_components), + int(native.convex_pieces), + int(native.generated_pieces), + int(native.generated_convolution_edges), + int(native.overlay_passes), + int(native.exact_crossings), + int(native.output_cells), + int(native.exact_coordinate_bit_growth), + ) + + def _required_handle(handle: ctypes.c_void_p) -> ctypes.c_void_p: if not handle.value: - raise RuntimeError("Moonlight returned success without a mesh handle") + raise RuntimeError("Moonlight returned success without a handle") return handle @@ -244,4 +608,17 @@ setattr(function, "restype", result) -__all__ = ["Mesh", "Moonlight", "MoonlightError", "Point", "Triangle"] +__all__ = [ + "Mesh", + "MinkowskiOperation", + "MinkowskiReceipt", + "Moonlight", + "MoonlightError", + "Point", + "PolygonComponent", + "Region", + "RegionLocation", + "RegionValuations", + "StructuringElement", + "Triangle", +] diff --git a/bindings/python/tests/test_binding.py b/bindings/python/tests/test_binding.py --- a/bindings/python/tests/test_binding.py +++ b/bindings/python/tests/test_binding.py @@ -3,9 +3,16 @@ import math import os import unittest +from fractions import Fraction from typing import ClassVar -from moonlight_triangulation import Moonlight, MoonlightError +from moonlight_triangulation import ( + MinkowskiOperation, + Moonlight, + MoonlightError, + PolygonComponent, + RegionLocation, +) class MoonlightBindingTest(unittest.TestCase): @@ -15,13 +22,13 @@ def setUpClass(cls) -> None: cls.engine = Moonlight(os.environ["MOONLIGHT_TRIANGULATION_LIBRARY"]) - def test_immutable_mesh_algebra_and_dense_projection(self) -> None: + def test_immutable_site_set_algebra_and_dense_projection(self) -> None: left = self.engine.delaunay([(0, 0), (2, 0), (0, 2), (2, 2)]) right = self.engine.delaunay([(2, 0), (4, 0), (2, 2), (4, 2)]) - union = left.union(right) - intersection = left.intersection(right) - difference = left.difference(right) - symmetric = left.symmetric_difference(right) + union = left.site_union(right) + intersection = left.site_intersection(right) + difference = left.site_difference(right) + symmetric = left.site_symmetric_difference(right) extended = left.insert_many([(1, 1), (3, 1)]) self.addCleanup(left.close) self.addCleanup(right.close) @@ -40,6 +47,34 @@ self.assertEqual(len(left.vertices), left.vertex_count) self.assertEqual(len(left.triangles), left.triangle_count) self.assertTrue(all(max(triangle) < left.vertex_count for triangle in left.triangles)) + + def test_exact_region_boolean_valuation_and_morphology(self) -> None: + left = self.engine.region([PolygonComponent(((0, 0), (2, 0), (2, 2), (0, 2)))]) + right = self.engine.region([PolygonComponent(((1, 0), (3, 0), (3, 2), (1, 2)))]) + intersection = left.intersection(right) + difference = left.difference(right) + symmetric = left.symmetric_difference(right) + kernel = self.engine.structuring_element(((-0.5, -0.5), (0.5, -0.5), (0.5, 0.5), (-0.5, 0.5))) + offset, receipt = left.offset(kernel) + self.addCleanup(left.close) + self.addCleanup(right.close) + self.addCleanup(intersection.close) + self.addCleanup(difference.close) + self.addCleanup(symmetric.close) + self.addCleanup(kernel.close) + self.addCleanup(offset.close) + + self.assertEqual(len(left.components), 1) + self.assertEqual(len(left.components[0].outer), 4) + self.assertEqual(intersection.valuations.area, Fraction(2, 1)) + self.assertEqual(difference.valuations.euler_characteristic, 1) + self.assertEqual(symmetric.valuations.euler_characteristic, 2) + self.assertEqual(left.locate((1, 1)), RegionLocation.INTERIOR) + self.assertEqual(left.locate((0, 1)), RegionLocation.BOUNDARY) + self.assertEqual(left.locate((3, 1)), RegionLocation.EXTERIOR) + self.assertEqual(offset.valuations.area, Fraction(9, 1)) + self.assertEqual(receipt.operation, MinkowskiOperation.ADDITION) + self.assertGreaterEqual(receipt.generated_pieces, 1) def test_invalid_coordinate_preserves_typed_witness(self) -> None: with self.assertRaises(MoonlightError) as raised: diff --git a/bindings/rust/Cargo.toml b/bindings/rust/Cargo.toml --- a/bindings/rust/Cargo.toml +++ b/bindings/rust/Cargo.toml @@ -1,9 +1,9 @@ [package] name = "moonlight-triangulation" -version = "1.0.0" +version = "2.0.0" edition = "2024" license = "MIT" -description = "Rust bindings for Moonlight's immutable Delaunay mesh algebra." +description = "Rust bindings for Moonlight exact regions and immutable Delaunay meshes." repository = "https://github.com/PaleRoses/moonlight.git" build = "build.rs" links = "moonlight-triangulation-c" diff --git a/bindings/rust/src/lib.rs b/bindings/rust/src/lib.rs --- a/bindings/rust/src/lib.rs +++ b/bindings/rust/src/lib.rs @@ -6,7 +6,8 @@ use std::rc::Rc; const STATUS_OK: u32 = 0; -const ABI_VERSION: u32 = 1; +const STATUS_BUFFER_TOO_SMALL: u32 = 3; +const ABI_VERSION: u32 = 2; #[repr(C)] struct NativeMesh { @@ -14,6 +15,16 @@ } #[repr(C)] +struct NativeRegion { + _private: [u8; 0], +} + +#[repr(C)] +struct NativeStructuringElement { + _private: [u8; 0], +} + +#[repr(C)] struct NativeObstruction { code: u32, coordinate_error: u32, @@ -44,6 +55,21 @@ } } +#[repr(C)] +#[derive(Default)] +struct NativeMinkowskiReceipt { + operation: u32, + reserved: u32, + input_components: u64, + convex_pieces: u64, + generated_pieces: u64, + generated_convolution_edges: u64, + overlay_passes: u64, + exact_crossings: u64, + output_cells: u64, + exact_coordinate_bit_growth: u64, +} + #[link(name = "moonlight-triangulation-c")] unsafe extern "C" { fn ml_abi_version() -> c_uint; @@ -61,25 +87,25 @@ result: *mut *mut NativeMesh, obstruction: *mut NativeObstruction, ) -> c_uint; - fn ml_mesh_union( + fn ml_mesh_site_union( left: *const NativeMesh, right: *const NativeMesh, result: *mut *mut NativeMesh, obstruction: *mut NativeObstruction, ) -> c_uint; - fn ml_mesh_intersection( + fn ml_mesh_site_intersection( left: *const NativeMesh, right: *const NativeMesh, result: *mut *mut NativeMesh, obstruction: *mut NativeObstruction, ) -> c_uint; - fn ml_mesh_difference( + fn ml_mesh_site_difference( left: *const NativeMesh, right: *const NativeMesh, result: *mut *mut NativeMesh, obstruction: *mut NativeObstruction, ) -> c_uint; - fn ml_mesh_symmetric_difference( + fn ml_mesh_site_symmetric_difference( left: *const NativeMesh, right: *const NativeMesh, result: *mut *mut NativeMesh, @@ -110,6 +136,119 @@ obstruction: *mut NativeObstruction, ) -> c_uint; fn ml_mesh_free(mesh: *mut NativeMesh); + + fn ml_region_create_f64( + coordinates: *const c_double, + point_count: usize, + loop_point_counts: *const usize, + loop_count: usize, + component_loop_counts: *const usize, + component_count: usize, + result: *mut *mut NativeRegion, + obstruction: *mut NativeObstruction, + ) -> c_uint; + fn ml_region_counts( + region: *const NativeRegion, + component_count: *mut usize, + loop_count: *mut usize, + point_count: *mut usize, + obstruction: *mut NativeObstruction, + ) -> c_uint; + fn ml_region_copy_f64( + region: *const NativeRegion, + coordinates: *mut c_double, + point_capacity: usize, + loop_point_offsets: *mut usize, + loop_offset_capacity: usize, + component_loop_offsets: *mut usize, + component_offset_capacity: usize, + obstruction: *mut NativeObstruction, + ) -> c_uint; + fn ml_region_union( + left: *const NativeRegion, + right: *const NativeRegion, + result: *mut *mut NativeRegion, + obstruction: *mut NativeObstruction, + ) -> c_uint; + fn ml_region_intersection( + left: *const NativeRegion, + right: *const NativeRegion, + result: *mut *mut NativeRegion, + obstruction: *mut NativeObstruction, + ) -> c_uint; + fn ml_region_difference( + left: *const NativeRegion, + right: *const NativeRegion, + result: *mut *mut NativeRegion, + obstruction: *mut NativeObstruction, + ) -> c_uint; + fn ml_region_symmetric_difference( + left: *const NativeRegion, + right: *const NativeRegion, + result: *mut *mut NativeRegion, + obstruction: *mut NativeObstruction, + ) -> c_uint; + fn ml_region_locate_point_f64( + region: *const NativeRegion, + x: c_double, + y: c_double, + location: *mut u32, + obstruction: *mut NativeObstruction, + ) -> c_uint; + fn ml_region_measure( + region: *const NativeRegion, + euler_characteristic: *mut i64, + area_ratio_utf8: *mut c_char, + area_capacity: usize, + area_bytes_written: *mut usize, + perimeter_lower: *mut c_double, + perimeter_upper: *mut c_double, + obstruction: *mut NativeObstruction, + ) -> c_uint; + fn ml_region_free(region: *mut NativeRegion); + + fn ml_structuring_element_create_f64( + coordinates: *const c_double, + point_count: usize, + result: *mut *mut NativeStructuringElement, + obstruction: *mut NativeObstruction, + ) -> c_uint; + fn ml_structuring_element_free(element: *mut NativeStructuringElement); + fn ml_region_minkowski_sum( + left: *const NativeRegion, + right: *const NativeRegion, + result: *mut *mut NativeRegion, + receipt: *mut NativeMinkowskiReceipt, + obstruction: *mut NativeObstruction, + ) -> c_uint; + fn ml_region_offset( + element: *const NativeStructuringElement, + region: *const NativeRegion, + result: *mut *mut NativeRegion, + receipt: *mut NativeMinkowskiReceipt, + obstruction: *mut NativeObstruction, + ) -> c_uint; + fn ml_region_inset( + element: *const NativeStructuringElement, + region: *const NativeRegion, + result: *mut *mut NativeRegion, + receipt: *mut NativeMinkowskiReceipt, + obstruction: *mut NativeObstruction, + ) -> c_uint; + fn ml_region_open( + element: *const NativeStructuringElement, + region: *const NativeRegion, + result: *mut *mut NativeRegion, + receipt: *mut NativeMinkowskiReceipt, + obstruction: *mut NativeObstruction, + ) -> c_uint; + fn ml_region_close( + element: *const NativeStructuringElement, + region: *const NativeRegion, + result: *mut *mut NativeRegion, + receipt: *mut NativeMinkowskiReceipt, + obstruction: *mut NativeObstruction, + ) -> c_uint; } type BinaryMeshOperation = unsafe extern "C" fn( @@ -119,6 +258,21 @@ *mut NativeObstruction, ) -> c_uint; +type BinaryRegionOperation = unsafe extern "C" fn( + *const NativeRegion, + *const NativeRegion, + *mut *mut NativeRegion, + *mut NativeObstruction, +) -> c_uint; + +type ElementRegionOperation = unsafe extern "C" fn( + *const NativeStructuringElement, + *const NativeRegion, + *mut *mut NativeRegion, + *mut NativeMinkowskiReceipt, + *mut NativeObstruction, +) -> c_uint; + #[derive(Debug, Clone, PartialEq)] pub struct MoonlightError { pub status: u32, @@ -141,6 +295,53 @@ impl Error for MoonlightError {} +#[derive(Debug, Clone, PartialEq)] +pub struct PolygonComponent { + pub outer: Vec<[f64; 2]>, + pub holes: Vec>, +} + +#[derive(Debug, Clone, Copy, PartialEq, Eq)] +pub enum RegionLocation { + Exterior, + Boundary, + Interior, +} + +#[derive(Debug, Clone, PartialEq, Eq)] +pub struct ExactRational { + pub numerator: String, + pub denominator: String, +} + +#[derive(Debug, Clone, PartialEq)] +pub struct RegionValuations { + pub euler_characteristic: i64, + pub area: ExactRational, + pub perimeter_bounds: [f64; 2], +} + +#[derive(Debug, Clone, Copy, PartialEq, Eq)] +pub enum MinkowskiOperation { + Addition, + Erosion, + Opening, + Closing, +} + +#[derive(Debug, Clone, PartialEq, Eq)] +pub struct MinkowskiReceipt { + pub operation: MinkowskiOperation, + pub input_components: u64, + pub convex_pieces: u64, + pub generated_pieces: u64, + pub generated_convolution_edges: u64, + pub overlay_passes: u64, + pub exact_crossings: u64, + pub output_cells: u64, + pub exact_coordinate_bit_growth: u64, +} + pub struct Moonlight; impl Moonlight { @@ -168,10 +369,58 @@ pub fn delaunay(&self, points: &[[f64; 2]]) -> Result { let coordinates = flatten_points(points); - create_mesh(|output, obstruction| unsafe { + create_handle(|output, obstruction| unsafe { ml_delaunay_f64(coordinates.as_ptr(), points.len(), output, obstruction) }) + .map(Mesh::from_handle) } + + pub fn region(&self, components: &[PolygonComponent]) -> Result { + let loop_point_counts = components + .iter() + .flat_map(|component| std::iter::once(&component.outer).chain(component.holes.iter())) + .map(Vec::len) + .collect::>(); + let component_loop_counts = components + .iter() + .map(|component| component.holes.len() + 1) + .collect::>(); + let coordinates = components + .iter() + .flat_map(|component| std::iter::once(&component.outer).chain(component.holes.iter())) + .flat_map(|loop_points| loop_points.iter()) + .flat_map(|[x, y]| [*x, *y]) + .collect::>(); + create_handle(|output, obstruction| unsafe { + ml_region_create_f64( + coordinates.as_ptr(), + coordinates.len() / 2, + loop_point_counts.as_ptr(), + loop_point_counts.len(), + component_loop_counts.as_ptr(), + components.len(), + output, + obstruction, + ) + }) + .map(Region::from_handle) + } + + pub fn structuring_element( + &self, + points: &[[f64; 2]], + ) -> Result { + let coordinates = flatten_points(points); + create_handle(|output, obstruction| unsafe { + ml_structuring_element_create_f64( + coordinates.as_ptr(), + points.len(), + output, + obstruction, + ) + }) + .map(StructuringElement::from_handle) + } } pub struct Mesh { @@ -180,6 +429,13 @@ } impl Mesh { + fn from_handle(handle: NonNull) -> Self { + Self { + handle, + _thread_affinity: PhantomData, + } + } + pub fn vertex_count(&self) -> Result { self.count(ml_mesh_vertex_count) } @@ -204,10 +460,7 @@ }; status_result(status, obstruction)?; coordinates.truncate(written * 2); - Ok(coordinates - .chunks_exact(2) - .map(|point| [point[0], point[1]]) - .collect()) + coordinate_pairs(&coordinates) } pub fn triangles(&self) -> Result, MoonlightError> { @@ -226,15 +479,21 @@ }; status_result(status, obstruction)?; triangles.truncate(written * 3); - Ok(triangles + triangles .chunks_exact(3) - .map(|triangle| [triangle[0], triangle[1], triangle[2]]) - .collect()) + .map(|triangle| { + Ok([ + *triangle.first().ok_or_else(projection_shape_error)?, + *triangle.get(1).ok_or_else(projection_shape_error)?, + *triangle.get(2).ok_or_else(projection_shape_error)?, + ]) + }) + .collect() } pub fn insert_many(&self, points: &[[f64; 2]]) -> Result { let coordinates = flatten_points(points); - create_mesh(|output, obstruction| unsafe { + create_handle(|output, obstruction| unsafe { ml_mesh_insert_many_f64( self.handle.as_ptr(), coordinates.as_ptr(), @@ -243,26 +502,27 @@ obstruction, ) }) + .map(Self::from_handle) } - pub fn union(&self, other: &Self) -> Result { - self.binary(other, ml_mesh_union) + pub fn site_union(&self, other: &Self) -> Result { + self.binary(other, ml_mesh_site_union) } - pub fn intersection(&self, other: &Self) -> Result { - self.binary(other, ml_mesh_intersection) + pub fn site_intersection(&self, other: &Self) -> Result { + self.binary(other, ml_mesh_site_intersection) } - pub fn difference(&self, other: &Self) -> Result { - self.binary(other, ml_mesh_difference) + pub fn site_difference(&self, other: &Self) -> Result { + self.binary(other, ml_mesh_site_difference) } - pub fn symmetric_difference(&self, other: &Self) -> Result { - self.binary(other, ml_mesh_symmetric_difference) + pub fn site_symmetric_difference(&self, other: &Self) -> Result { + self.binary(other, ml_mesh_site_symmetric_difference) } fn binary(&self, other: &Self, operation: BinaryMeshOperation) -> Result { - create_mesh(|output, obstruction| unsafe { + create_handle(|output, obstruction| unsafe { operation( self.handle.as_ptr(), other.handle.as_ptr(), @@ -270,6 +530,7 @@ obstruction, ) }) + .map(Self::from_handle) } fn count( @@ -294,26 +555,351 @@ } } +pub struct Region { + handle: NonNull, + _thread_affinity: PhantomData>, +} + +impl Region { + fn from_handle(handle: NonNull) -> Self { + Self { + handle, + _thread_affinity: PhantomData, + } + } + + pub fn components(&self) -> Result, MoonlightError> { + let (component_count, loop_count, point_count) = self.counts()?; + let mut coordinates = vec![0.0; point_count * 2]; + let mut loop_point_offsets = vec![0; loop_count + 1]; + let mut component_loop_offsets = vec![0; component_count + 1]; + let mut obstruction = NativeObstruction::default(); + let status = unsafe { + ml_region_copy_f64( + self.handle.as_ptr(), + coordinates.as_mut_ptr(), + point_count, + loop_point_offsets.as_mut_ptr(), + loop_point_offsets.len(), + component_loop_offsets.as_mut_ptr(), + component_loop_offsets.len(), + &mut obstruction, + ) + }; + status_result(status, obstruction)?; + let points = coordinate_pairs(&coordinates)?; + component_loop_offsets + .windows(2) + .map(|window| { + let (start, end) = offset_window(window)?; + if start >= end { + return Err(projection_shape_error()); + } + let outer = projected_loop(&points, &loop_point_offsets, start)?; + let holes = (start + 1..end) + .map(|index| projected_loop(&points, &loop_point_offsets, index)) + .collect::, _>>()?; + Ok(PolygonComponent { outer, holes }) + }) + .collect() + } + + pub fn valuations(&self) -> Result { + self.measure_with_capacity(128) + } + + pub fn locate(&self, [x, y]: [f64; 2]) -> Result { + let mut location = 0; + let mut obstruction = NativeObstruction::default(); + let status = unsafe { + ml_region_locate_point_f64(self.handle.as_ptr(), x, y, &mut location, &mut obstruction) + }; + status_result(status, obstruction)?; + region_location(location) + } + + pub fn union(&self, other: &Self) -> Result { + self.binary(other, ml_region_union) + } + + pub fn intersection(&self, other: &Self) -> Result { + self.binary(other, ml_region_intersection) + } + + pub fn difference(&self, other: &Self) -> Result { + self.binary(other, ml_region_difference) + } + + pub fn symmetric_difference(&self, other: &Self) -> Result { + self.binary(other, ml_region_symmetric_difference) + } + + pub fn minkowski_sum(&self, other: &Self) -> Result<(Self, MinkowskiReceipt), MoonlightError> { + produce_morphology(|output, receipt, obstruction| unsafe { + ml_region_minkowski_sum( + self.handle.as_ptr(), + other.handle.as_ptr(), + output, + receipt, + obstruction, + ) + }) + } + + pub fn offset( + &self, + element: &StructuringElement, + ) -> Result<(Self, MinkowskiReceipt), MoonlightError> { + self.with_element(element, ml_region_offset) + } + + pub fn inset( + &self, + element: &StructuringElement, + ) -> Result<(Self, MinkowskiReceipt), MoonlightError> { + self.with_element(element, ml_region_inset) + } + + pub fn open( + &self, + element: &StructuringElement, + ) -> Result<(Self, MinkowskiReceipt), MoonlightError> { + self.with_element(element, ml_region_open) + } + + pub fn close_with( + &self, + element: &StructuringElement, + ) -> Result<(Self, MinkowskiReceipt), MoonlightError> { + self.with_element(element, ml_region_close) + } + + fn binary( + &self, + other: &Self, + operation: BinaryRegionOperation, + ) -> Result { + create_handle(|output, obstruction| unsafe { + operation( + self.handle.as_ptr(), + other.handle.as_ptr(), + output, + obstruction, + ) + }) + .map(Self::from_handle) + } + + fn with_element( + &self, + element: &StructuringElement, + operation: ElementRegionOperation, + ) -> Result<(Self, MinkowskiReceipt), MoonlightError> { + produce_morphology(|output, receipt, obstruction| unsafe { + operation( + element.handle.as_ptr(), + self.handle.as_ptr(), + output, + receipt, + obstruction, + ) + }) + } + + fn counts(&self) -> Result<(usize, usize, usize), MoonlightError> { + let mut component_count = 0; + let mut loop_count = 0; + let mut point_count = 0; + let mut obstruction = NativeObstruction::default(); + let status = unsafe { + ml_region_counts( + self.handle.as_ptr(), + &mut component_count, + &mut loop_count, + &mut point_count, + &mut obstruction, + ) + }; + status_result(status, obstruction)?; + Ok((component_count, loop_count, point_count)) + } + + fn measure_with_capacity(&self, capacity: usize) -> Result { + let mut euler_characteristic = 0; + let mut area_ratio = vec![0; capacity]; + let mut area_bytes_written = 0; + let mut perimeter_lower = 0.0; + let mut perimeter_upper = 0.0; + let mut obstruction = NativeObstruction::default(); + let status = unsafe { + ml_region_measure( + self.handle.as_ptr(), + &mut euler_characteristic, + area_ratio.as_mut_ptr(), + capacity, + &mut area_bytes_written, + &mut perimeter_lower, + &mut perimeter_upper, + &mut obstruction, + ) + }; + if status == STATUS_BUFFER_TOO_SMALL && obstruction.code == 102 { + return self.measure_with_capacity(area_bytes_written + 1); + } + status_result(status, obstruction)?; + let area_bytes = area_ratio + .get(..area_bytes_written) + .ok_or_else(projection_shape_error)? + .iter() + .map(|byte| *byte as u8) + .collect::>(); + let area_text = String::from_utf8(area_bytes) + .map_err(|failure| synthetic_error(5, failure.to_string(), 0, 0))?; + let (numerator, denominator) = area_text + .split_once('/') + .ok_or_else(|| synthetic_error(5, "malformed exact-area ratio", 0, 0))?; + Ok(RegionValuations { + euler_characteristic, + area: ExactRational { + numerator: numerator.to_owned(), + denominator: denominator.to_owned(), + }, + perimeter_bounds: [perimeter_lower, perimeter_upper], + }) + } +} + +impl Drop for Region { + fn drop(&mut self) { + unsafe { ml_region_free(self.handle.as_ptr()) } + } +} + +pub struct StructuringElement { + handle: NonNull, + _thread_affinity: PhantomData>, +} + +impl StructuringElement { + fn from_handle(handle: NonNull) -> Self { + Self { + handle, + _thread_affinity: PhantomData, + } + } +} + +impl Drop for StructuringElement { + fn drop(&mut self) { + unsafe { ml_structuring_element_free(self.handle.as_ptr()) } + } +} + fn flatten_points(points: &[[f64; 2]]) -> Vec { points.iter().flat_map(|[x, y]| [*x, *y]).collect() } -#[inline] -fn create_mesh( - operation: impl FnOnce(*mut *mut NativeMesh, *mut NativeObstruction) -> u32, -) -> Result { +fn coordinate_pairs(coordinates: &[f64]) -> Result, MoonlightError> { + coordinates + .chunks_exact(2) + .map(|point| { + Ok([ + *point.first().ok_or_else(projection_shape_error)?, + *point.get(1).ok_or_else(projection_shape_error)?, + ]) + }) + .collect() +} + +fn offset_window(window: &[usize]) -> Result<(usize, usize), MoonlightError> { + Ok(( + *window.first().ok_or_else(projection_shape_error)?, + *window.get(1).ok_or_else(projection_shape_error)?, + )) +} + +fn projected_loop( + points: &[[f64; 2]], + offsets: &[usize], + index: usize, +) -> Result, MoonlightError> { + let start = *offsets.get(index).ok_or_else(projection_shape_error)?; + let end = *offsets.get(index + 1).ok_or_else(projection_shape_error)?; + points + .get(start..end) + .map(<[_]>::to_vec) + .ok_or_else(projection_shape_error) +} + +fn create_handle( + operation: impl FnOnce(*mut *mut Native, *mut NativeObstruction) -> u32, +) -> Result, MoonlightError> { let mut output = std::ptr::null_mut(); let mut obstruction = NativeObstruction::default(); let status = operation(&mut output, &mut obstruction); status_result(status, obstruction)?; - NonNull::new(output) - .map(|handle| Mesh { - handle, - _thread_affinity: PhantomData, - }) - .ok_or_else(success_without_handle_error) + NonNull::new(output).ok_or_else(success_without_handle_error) } +fn produce_morphology( + operation: impl FnOnce( + *mut *mut NativeRegion, + *mut NativeMinkowskiReceipt, + *mut NativeObstruction, + ) -> u32, +) -> Result<(Region, MinkowskiReceipt), MoonlightError> { + let mut output = std::ptr::null_mut(); + let mut receipt = NativeMinkowskiReceipt::default(); + let mut obstruction = NativeObstruction::default(); + let status = operation(&mut output, &mut receipt, &mut obstruction); + status_result(status, obstruction)?; + let handle = NonNull::new(output).ok_or_else(success_without_handle_error)?; + Ok((Region::from_handle(handle), minkowski_receipt(receipt)?)) +} + +fn minkowski_receipt(receipt: NativeMinkowskiReceipt) -> Result { + Ok(MinkowskiReceipt { + operation: minkowski_operation(receipt.operation)?, + input_components: receipt.input_components, + convex_pieces: receipt.convex_pieces, + generated_pieces: receipt.generated_pieces, + generated_convolution_edges: receipt.generated_convolution_edges, + overlay_passes: receipt.overlay_passes, + exact_crossings: receipt.exact_crossings, + output_cells: receipt.output_cells, + exact_coordinate_bit_growth: receipt.exact_coordinate_bit_growth, + }) +} + +fn minkowski_operation(code: u32) -> Result { + match code { + 0 => Ok(MinkowskiOperation::Addition), + 1 => Ok(MinkowskiOperation::Erosion), + 2 => Ok(MinkowskiOperation::Opening), + 3 => Ok(MinkowskiOperation::Closing), + _ => Err(synthetic_error( + 5, + format!("unknown morphology operation {code}"), + u64::from(code), + 0, + )), + } +} + +fn region_location(code: u32) -> Result { + match code { + 0 => Ok(RegionLocation::Exterior), + 1 => Ok(RegionLocation::Boundary), + 2 => Ok(RegionLocation::Interior), + _ => Err(synthetic_error( + 5, + format!("unknown region location {code}"), + u64::from(code), + 0, + )), + } +} + fn status_result(status: u32, obstruction: NativeObstruction) -> Result<(), MoonlightError> { if status == STATUS_OK { Ok(()) @@ -329,7 +915,10 @@ .iter() .position(|character| *character == 0) .unwrap_or(obstruction.message.len()); - let message_bytes = obstruction.message[..message_end] + let message_bytes = obstruction + .message + .get(..message_end) + .unwrap_or_default() .iter() .map(|character| *character as u8) .collect::>(); @@ -348,8 +937,12 @@ } } +fn projection_shape_error() -> MoonlightError { + synthetic_error(5, "Moonlight returned a malformed bulk projection", 0, 0) +} + fn success_without_handle_error() -> MoonlightError { - synthetic_error(5, "Moonlight returned success without a mesh handle", 0, 0) + synthetic_error(5, "Moonlight returned success without a handle", 0, 0) } fn synthetic_error( diff --git a/bindings/rust/tests/binding.rs b/bindings/rust/tests/binding.rs --- a/bindings/rust/tests/binding.rs +++ b/bindings/rust/tests/binding.rs @@ -1,7 +1,9 @@ -use moonlight_triangulation::Moonlight; +use moonlight_triangulation::{ + ExactRational, MinkowskiOperation, Moonlight, PolygonComponent, RegionLocation, +}; #[test] -fn immutable_mesh_algebra_and_dense_projection() { +fn immutable_site_set_algebra_and_dense_projection() { let engine = Moonlight::initialize().expect("runtime"); let left = engine .delaunay(&[[0.0, 0.0], [2.0, 0.0], [0.0, 2.0], [2.0, 2.0]]) @@ -9,12 +11,12 @@ let right = engine .delaunay(&[[2.0, 0.0], [4.0, 0.0], [2.0, 2.0], [4.0, 2.0]]) .expect("right mesh"); - let union = left.union(&right).expect("union"); - let intersection = left.intersection(&right).expect("intersection"); - let difference = left.difference(&right).expect("difference"); + let union = left.site_union(&right).expect("site union"); + let intersection = left.site_intersection(&right).expect("site intersection"); + let difference = left.site_difference(&right).expect("site difference"); let symmetric = left - .symmetric_difference(&right) - .expect("symmetric difference"); + .site_symmetric_difference(&right) + .expect("site symmetric difference"); let extended = left .insert_many(&[[1.0, 1.0], [3.0, 1.0]]) .expect("batch insertion"); @@ -33,6 +35,71 @@ left.triangles().expect("triangles").len(), left.triangle_count().expect("triangle count") ); +} + +#[test] +fn exact_region_boolean_valuation_and_morphology() { + let engine = Moonlight::initialize().expect("runtime"); + let left = engine + .region(&[PolygonComponent { + outer: vec![[0.0, 0.0], [2.0, 0.0], [2.0, 2.0], [0.0, 2.0]], + holes: vec![], + }]) + .expect("left region"); + let right = engine + .region(&[PolygonComponent { + outer: vec![[1.0, 0.0], [3.0, 0.0], [3.0, 2.0], [1.0, 2.0]], + holes: vec![], + }]) + .expect("right region"); + let intersection = left.intersection(&right).expect("intersection"); + let symmetric = left + .symmetric_difference(&right) + .expect("symmetric difference"); + let kernel = engine + .structuring_element(&[[-0.5, -0.5], [0.5, -0.5], [0.5, 0.5], [-0.5, 0.5]]) + .expect("structuring element"); + let (offset, receipt) = left.offset(&kernel).expect("offset"); + + assert_eq!(left.components().expect("components").len(), 1); + assert_eq!( + intersection + .valuations() + .expect("intersection valuation") + .area, + ExactRational { + numerator: "2".to_owned(), + denominator: "1".to_owned(), + } + ); + assert_eq!( + symmetric + .valuations() + .expect("symmetric valuation") + .euler_characteristic, + 2 + ); + assert_eq!( + left.locate([1.0, 1.0]).expect("interior"), + RegionLocation::Interior + ); + assert_eq!( + left.locate([0.0, 1.0]).expect("boundary"), + RegionLocation::Boundary + ); + assert_eq!( + left.locate([3.0, 1.0]).expect("exterior"), + RegionLocation::Exterior + ); + assert_eq!( + offset.valuations().expect("offset valuation").area, + ExactRational { + numerator: "9".to_owned(), + denominator: "1".to_owned(), + } + ); + assert_eq!(receipt.operation, MinkowskiOperation::Addition); + assert!(receipt.generated_pieces >= 1); } #[test] diff --git a/bindings/typescript/package.json b/bindings/typescript/package.json --- a/bindings/typescript/package.json +++ b/bindings/typescript/package.json @@ -1,7 +1,7 @@ { "name": "@moonlight/triangulation", - "version": "1.0.0", - "description": "TypeScript bindings for Moonlight's immutable Delaunay mesh algebra.", + "version": "2.0.0", + "description": "TypeScript bindings for Moonlight exact regions and immutable Delaunay meshes.", "type": "module", "main": "./dist/src/index.js", "types": "./dist/src/index.d.ts", diff --git a/bindings/typescript/src/index.ts b/bindings/typescript/src/index.ts --- a/bindings/typescript/src/index.ts +++ b/bindings/typescript/src/index.ts @@ -1,13 +1,56 @@ import koffi from "koffi"; const STATUS_OK = 0; -const ABI_VERSION = 1; +const STATUS_BUFFER_TOO_SMALL = 3; +const ABI_VERSION = 2; export type Point = readonly [x: number, y: number]; export type Triangle = readonly [first: number, second: number, third: number]; -type MeshHandle = object; +export interface PolygonComponent { + readonly outer: readonly Point[]; + readonly holes?: readonly (readonly Point[])[]; +} + +export enum RegionLocation { + Exterior = 0, + Boundary = 1, + Interior = 2, +} + +export interface ExactRational { + readonly numerator: bigint; + readonly denominator: bigint; +} + +export interface RegionValuations { + readonly eulerCharacteristic: bigint; + readonly area: ExactRational; + readonly perimeterBounds: readonly [lower: number, upper: number]; +} + +export enum MinkowskiOperation { + Addition = 0, + Erosion = 1, + Opening = 2, + Closing = 3, +} + +export interface MinkowskiReceipt { + readonly operation: MinkowskiOperation; + readonly inputComponents: bigint; + readonly convexPieces: bigint; + readonly generatedPieces: bigint; + readonly generatedConvolutionEdges: bigint; + readonly overlayPasses: bigint; + readonly exactCrossings: bigint; + readonly outputCells: bigint; + readonly exactCoordinateBitGrowth: bigint; +} + +type NativeHandle = object; type NativeInteger = number | bigint; +type HandleOutput = Array; interface NativeObstruction { code?: number; @@ -22,33 +65,103 @@ message?: string | readonly number[]; } -type BuildOperation = (coordinates: Float64Array, pointCount: number, output: Array, obstruction: NativeObstruction) => number; -type InsertOperation = (mesh: MeshHandle, coordinates: Float64Array, pointCount: number, output: Array, obstruction: NativeObstruction) => number; -type BinaryOperation = (left: MeshHandle, right: MeshHandle, output: Array, obstruction: NativeObstruction) => number; -type CountOperation = (mesh: MeshHandle, output: number[], obstruction: NativeObstruction) => number; +interface NativeMinkowskiReceipt { + operation?: number; + reserved?: number; + input_components?: NativeInteger; + convex_pieces?: NativeInteger; + generated_pieces?: NativeInteger; + generated_convolution_edges?: NativeInteger; + overlay_passes?: NativeInteger; + exact_crossings?: NativeInteger; + output_cells?: NativeInteger; + exact_coordinate_bit_growth?: NativeInteger; +} +type BuildOperation = (coordinates: Float64Array, pointCount: number, output: HandleOutput, obstruction: NativeObstruction) => number; +type InsertOperation = (mesh: NativeHandle, coordinates: Float64Array, pointCount: number, output: HandleOutput, obstruction: NativeObstruction) => number; +type BinaryOperation = (left: NativeHandle, right: NativeHandle, output: HandleOutput, obstruction: NativeObstruction) => number; +type CountOperation = (handle: NativeHandle, output: NativeInteger[], obstruction: NativeObstruction) => number; +type MorphologyOperation = ( + first: NativeHandle, + second: NativeHandle, + output: HandleOutput, + receipt: NativeMinkowskiReceipt, + obstruction: NativeObstruction, +) => number; + interface NativeApi { readonly abiVersion: () => number; readonly runtimeInitialize: () => number; readonly delaunay: BuildOperation; readonly insertMany: InsertOperation; - readonly union: BinaryOperation; - readonly intersection: BinaryOperation; - readonly difference: BinaryOperation; - readonly symmetricDifference: BinaryOperation; + readonly meshSiteUnion: BinaryOperation; + readonly meshSiteIntersection: BinaryOperation; + readonly meshSiteDifference: BinaryOperation; + readonly meshSiteSymmetricDifference: BinaryOperation; readonly vertexCount: CountOperation; readonly triangleCount: CountOperation; - readonly copyVertices: (mesh: MeshHandle, coordinates: Float64Array, capacity: number, written: number[], obstruction: NativeObstruction) => number; - readonly copyTriangles: (mesh: MeshHandle, triangles: Uint32Array, capacity: number, written: number[], obstruction: NativeObstruction) => number; - readonly free: (mesh: MeshHandle) => void; + readonly copyVertices: (mesh: NativeHandle, coordinates: Float64Array, capacity: number, written: NativeInteger[], obstruction: NativeObstruction) => number; + readonly copyTriangles: (mesh: NativeHandle, triangles: Uint32Array, capacity: number, written: NativeInteger[], obstruction: NativeObstruction) => number; + readonly meshFree: (mesh: NativeHandle) => void; + readonly regionCreate: ( + coordinates: Float64Array, + pointCount: number, + loopPointCounts: BigUint64Array, + loopCount: number, + componentLoopCounts: BigUint64Array, + componentCount: number, + output: HandleOutput, + obstruction: NativeObstruction, + ) => number; + readonly regionCounts: ( + region: NativeHandle, + componentCount: NativeInteger[], + loopCount: NativeInteger[], + pointCount: NativeInteger[], + obstruction: NativeObstruction, + ) => number; + readonly regionCopy: ( + region: NativeHandle, + coordinates: Float64Array, + pointCapacity: number, + loopPointOffsets: BigUint64Array, + loopOffsetCapacity: number, + componentLoopOffsets: BigUint64Array, + componentOffsetCapacity: number, + obstruction: NativeObstruction, + ) => number; + readonly regionUnion: BinaryOperation; + readonly regionIntersection: BinaryOperation; + readonly regionDifference: BinaryOperation; + readonly regionSymmetricDifference: BinaryOperation; + readonly regionLocate: (region: NativeHandle, x: number, y: number, location: number[], obstruction: NativeObstruction) => number; + readonly regionMeasure: ( + region: NativeHandle, + euler: NativeInteger[], + areaRatio: Buffer, + areaCapacity: number, + areaBytes: NativeInteger[], + perimeterLower: number[], + perimeterUpper: number[], + obstruction: NativeObstruction, + ) => number; + readonly regionFree: (region: NativeHandle) => void; + readonly structuringElementCreate: BuildOperation; + readonly structuringElementFree: (element: NativeHandle) => void; + readonly regionMinkowskiSum: MorphologyOperation; + readonly regionOffset: MorphologyOperation; + readonly regionInset: MorphologyOperation; + readonly regionOpen: MorphologyOperation; + readonly regionClose: MorphologyOperation; } interface FinalizerState { - readonly free: (mesh: MeshHandle) => void; - readonly handle: MeshHandle; + readonly free: (handle: NativeHandle) => void; + readonly handle: NativeHandle; } -const meshFinalizer = new FinalizationRegistry(({ free, handle }) => free(handle)); +const handleFinalizer = new FinalizationRegistry(({ free, handle }) => free(handle)); export class MoonlightError extends Error { readonly status: number; @@ -96,49 +209,117 @@ } delaunay(points: readonly Point[]): Mesh { - const output: Array = [null]; - const obstruction: NativeObstruction = {}; - const status = this.#native.delaunay(flattenPoints(points), points.length, output, obstruction); - checkStatus(status, obstruction); - return new Mesh(this.#native, requiredHandle(output[0])); + const coordinates = flattenPoints(points); + return new Mesh( + this.#native, + produceHandle((output, obstruction) => + this.#native.delaunay(coordinates, points.length, output, obstruction), + ), + ); } + + region(components: readonly PolygonComponent[]): Region { + const loops = components.flatMap(({ outer, holes = [] }) => [outer, ...holes]); + const loopPointCounts = BigUint64Array.from(loops.map((loop) => BigInt(loop.length))); + const componentLoopCounts = BigUint64Array.from( + components.map(({ holes = [] }) => BigInt(holes.length + 1)), + ); + const coordinates = flattenLoops(loops); + return new Region( + this.#native, + produceHandle((output, obstruction) => + this.#native.regionCreate( + coordinates, + coordinates.length / 2, + loopPointCounts, + loops.length, + componentLoopCounts, + components.length, + output, + obstruction, + ), + ), + ); + } + + structuringElement(points: readonly Point[]): StructuringElement { + const coordinates = flattenPoints(points); + return new StructuringElement( + this.#native, + produceHandle((output, obstruction) => + this.#native.structuringElementCreate(coordinates, points.length, output, obstruction), + ), + ); + } } -export class Mesh { +abstract class OwnedHandle { readonly #native: NativeApi; - #handle: MeshHandle | null; + readonly #free: (handle: NativeHandle) => void; + readonly #kind: string; + #handle: NativeHandle | null; - constructor(native: NativeApi, handle: MeshHandle) { + protected constructor( + native: NativeApi, + handle: NativeHandle, + free: (handle: NativeHandle) => void, + kind: string, + ) { this.#native = native; + this.#free = free; + this.#kind = kind; this.#handle = handle; - meshFinalizer.register(this, { free: native.free, handle }, this); + handleFinalizer.register(this, { free, handle }, this); } close(): void { const handle = this.#handle; if (handle !== null) { - meshFinalizer.unregister(this); - this.#native.free(handle); + handleFinalizer.unregister(this); + this.#free(handle); this.#handle = null; } } + native(): NativeApi { + return this.#native; + } + + nativeHandle(): NativeHandle { + if (this.#handle === null) { + throw new Error(`${this.#kind} is closed`); + } + return this.#handle; + } + + requireSameRuntime(other: OwnedHandle): void { + if (this.#native !== other.#native) { + throw new Error("both values must belong to the same Moonlight runtime"); + } + } +} + +export class Mesh extends OwnedHandle { + constructor(native: NativeApi, handle: NativeHandle) { + super(native, handle, native.meshFree, "mesh"); + } + vertexCount(): number { - return this.#count(this.#native.vertexCount); + return this.count(this.native().vertexCount); } triangleCount(): number { - return this.#count(this.#native.triangleCount); + return this.count(this.native().triangleCount); } vertices(): readonly Point[] { const count = this.vertexCount(); const coordinates = new Float64Array(count * 2); - const written = [0]; + const written: NativeInteger[] = [0]; const obstruction: NativeObstruction = {}; - const status = this.#native.copyVertices(this.#liveHandle(), coordinates, count, written, obstruction); + const status = this.native().copyVertices(this.nativeHandle(), coordinates, count, written, obstruction); checkStatus(status, obstruction); - return Array.from({ length: written[0] ?? 0 }, (_unused, index): Point => [ + return Array.from({ length: toSafeNumber(written[0]) }, (_unused, index): Point => [ coordinates[index * 2] ?? 0, coordinates[index * 2 + 1] ?? 0, ]); @@ -147,11 +328,11 @@ triangles(): readonly Triangle[] { const count = this.triangleCount(); const triangles = new Uint32Array(count * 3); - const written = [0]; + const written: NativeInteger[] = [0]; const obstruction: NativeObstruction = {}; - const status = this.#native.copyTriangles(this.#liveHandle(), triangles, count, written, obstruction); + const status = this.native().copyTriangles(this.nativeHandle(), triangles, count, written, obstruction); checkStatus(status, obstruction); - return Array.from({ length: written[0] ?? 0 }, (_unused, index): Triangle => [ + return Array.from({ length: toSafeNumber(written[0]) }, (_unused, index): Triangle => [ triangles[index * 3] ?? 0, triangles[index * 3 + 1] ?? 0, triangles[index * 3 + 2] ?? 0, @@ -159,61 +340,235 @@ } insertMany(points: readonly Point[]): Mesh { - const output: Array = [null]; + const coordinates = flattenPoints(points); + return new Mesh( + this.native(), + produceHandle((output, obstruction) => + this.native().insertMany(this.nativeHandle(), coordinates, points.length, output, obstruction), + ), + ); + } + + siteUnion(other: Mesh): Mesh { + return this.binary(other, this.native().meshSiteUnion); + } + + siteIntersection(other: Mesh): Mesh { + return this.binary(other, this.native().meshSiteIntersection); + } + + siteDifference(other: Mesh): Mesh { + return this.binary(other, this.native().meshSiteDifference); + } + + siteSymmetricDifference(other: Mesh): Mesh { + return this.binary(other, this.native().meshSiteSymmetricDifference); + } + + private binary(other: Mesh, operation: BinaryOperation): Mesh { + this.requireSameRuntime(other); + return new Mesh( + this.native(), + produceHandle((output, obstruction) => + operation(this.nativeHandle(), other.nativeHandle(), output, obstruction), + ), + ); + } + + private count(operation: CountOperation): number { + const output: NativeInteger[] = [0]; const obstruction: NativeObstruction = {}; - const status = this.#native.insertMany(this.#liveHandle(), flattenPoints(points), points.length, output, obstruction); + const status = operation(this.nativeHandle(), output, obstruction); checkStatus(status, obstruction); - return new Mesh(this.#native, requiredHandle(output[0])); + return toSafeNumber(output[0]); } +} - union(other: Mesh): Mesh { - return this.#binary(other, this.#native.union); +export class Region extends OwnedHandle { + constructor(native: NativeApi, handle: NativeHandle) { + super(native, handle, native.regionFree, "region"); } - intersection(other: Mesh): Mesh { - return this.#binary(other, this.#native.intersection); + components(): readonly PolygonComponent[] { + const [componentCount, loopCount, pointCount] = this.counts(); + const coordinates = new Float64Array(pointCount * 2); + const loopPointOffsets = new BigUint64Array(loopCount + 1); + const componentLoopOffsets = new BigUint64Array(componentCount + 1); + const obstruction: NativeObstruction = {}; + const status = this.native().regionCopy( + this.nativeHandle(), + coordinates, + pointCount, + loopPointOffsets, + loopCount + 1, + componentLoopOffsets, + componentCount + 1, + obstruction, + ); + checkStatus(status, obstruction); + const points = Array.from({ length: pointCount }, (_unused, index): Point => [ + coordinates[index * 2] ?? 0, + coordinates[index * 2 + 1] ?? 0, + ]); + const loops = Array.from({ length: loopCount }, (_unused, index) => + points.slice(toSafeNumber(loopPointOffsets[index]), toSafeNumber(loopPointOffsets[index + 1])), + ); + return Array.from({ length: componentCount }, (_unused, index): PolygonComponent => { + const start = toSafeNumber(componentLoopOffsets[index]); + const end = toSafeNumber(componentLoopOffsets[index + 1]); + const outer = loops[start]; + if (outer === undefined || start >= end) { + throw new Error("Moonlight returned a component without an outer loop"); + } + return { outer, holes: loops.slice(start + 1, end) }; + }); } - difference(other: Mesh): Mesh { - return this.#binary(other, this.#native.difference); + valuations(): RegionValuations { + return this.measureWithCapacity(128); } - symmetricDifference(other: Mesh): Mesh { - return this.#binary(other, this.#native.symmetricDifference); + locate([x, y]: Point): RegionLocation { + const location = [0]; + const obstruction: NativeObstruction = {}; + const status = this.native().regionLocate(this.nativeHandle(), x, y, location, obstruction); + checkStatus(status, obstruction); + return locationCode(location[0]); } - #binary(other: Mesh, operation: BinaryOperation): Mesh { - if (this.#native !== other.#native) { - throw new Error("both meshes must belong to the same Moonlight runtime"); - } - const output: Array = [null]; + union(other: Region): Region { + return this.binary(other, this.native().regionUnion); + } + + intersection(other: Region): Region { + return this.binary(other, this.native().regionIntersection); + } + + difference(other: Region): Region { + return this.binary(other, this.native().regionDifference); + } + + symmetricDifference(other: Region): Region { + return this.binary(other, this.native().regionSymmetricDifference); + } + + minkowskiSum(other: Region): readonly [Region, MinkowskiReceipt] { + this.requireSameRuntime(other); + return this.morph(this.native().regionMinkowskiSum, this.nativeHandle(), other.nativeHandle()); + } + + offset(element: StructuringElement): readonly [Region, MinkowskiReceipt] { + return this.withElement(element, this.native().regionOffset); + } + + inset(element: StructuringElement): readonly [Region, MinkowskiReceipt] { + return this.withElement(element, this.native().regionInset); + } + + open(element: StructuringElement): readonly [Region, MinkowskiReceipt] { + return this.withElement(element, this.native().regionOpen); + } + + closeWith(element: StructuringElement): readonly [Region, MinkowskiReceipt] { + return this.withElement(element, this.native().regionClose); + } + + private binary(other: Region, operation: BinaryOperation): Region { + this.requireSameRuntime(other); + return new Region( + this.native(), + produceHandle((output, obstruction) => + operation(this.nativeHandle(), other.nativeHandle(), output, obstruction), + ), + ); + } + + private withElement( + element: StructuringElement, + operation: MorphologyOperation, + ): readonly [Region, MinkowskiReceipt] { + this.requireSameRuntime(element); + return this.morph(operation, element.nativeHandle(), this.nativeHandle()); + } + + private morph( + operation: MorphologyOperation, + first: NativeHandle, + second: NativeHandle, + ): readonly [Region, MinkowskiReceipt] { + const [handle, receipt] = produceMorphology((output, nativeReceipt, obstruction) => + operation(first, second, output, nativeReceipt, obstruction), + ); + return [new Region(this.native(), handle), receipt]; + } + + private counts(): readonly [number, number, number] { + const componentCount: NativeInteger[] = [0]; + const loopCount: NativeInteger[] = [0]; + const pointCount: NativeInteger[] = [0]; const obstruction: NativeObstruction = {}; - const status = operation(this.#liveHandle(), other.#liveHandle(), output, obstruction); + const status = this.native().regionCounts( + this.nativeHandle(), + componentCount, + loopCount, + pointCount, + obstruction, + ); checkStatus(status, obstruction); - return new Mesh(this.#native, requiredHandle(output[0])); + return [toSafeNumber(componentCount[0]), toSafeNumber(loopCount[0]), toSafeNumber(pointCount[0])]; } - #count(operation: CountOperation): number { - const output = [0]; + private measureWithCapacity(capacity: number): RegionValuations { + const euler: NativeInteger[] = [0]; + const areaRatio = Buffer.alloc(capacity); + const areaBytes: NativeInteger[] = [0]; + const perimeterLower = [0]; + const perimeterUpper = [0]; const obstruction: NativeObstruction = {}; - const status = operation(this.#liveHandle(), output, obstruction); + const status = this.native().regionMeasure( + this.nativeHandle(), + euler, + areaRatio, + capacity, + areaBytes, + perimeterLower, + perimeterUpper, + obstruction, + ); + if (status === STATUS_BUFFER_TOO_SMALL && obstruction.code === 102) { + return this.measureWithCapacity(toSafeNumber(areaBytes[0]) + 1); + } checkStatus(status, obstruction); - return output[0] ?? 0; + const ratio = areaRatio.subarray(0, toSafeNumber(areaBytes[0])).toString("ascii"); + const [numerator, denominator, remainder] = ratio.split("/"); + if (numerator === undefined || denominator === undefined || remainder !== undefined) { + throw new Error("Moonlight returned a malformed exact-area ratio"); + } + return { + eulerCharacteristic: toBigInt(euler[0]), + area: { numerator: BigInt(numerator), denominator: BigInt(denominator) }, + perimeterBounds: [perimeterLower[0] ?? 0, perimeterUpper[0] ?? 0], + }; } +} - #liveHandle(): MeshHandle { - if (this.#handle === null) { - throw new Error("mesh is closed"); - } - return this.#handle; +export class StructuringElement extends OwnedHandle { + constructor(native: NativeApi, handle: NativeHandle) { + super(native, handle, native.structuringElementFree, "structuring element"); } } function createNativeApi(libraryPath: string): NativeApi { const library = koffi.load(libraryPath); const mesh = koffi.opaque(); + const region = koffi.opaque(); + const structuringElement = koffi.opaque(); const meshPointer = koffi.pointer(mesh); + const regionPointer = koffi.pointer(region); + const structuringElementPointer = koffi.pointer(structuringElement); const meshOutput = koffi.out(koffi.pointer(mesh, 2)); + const regionOutput = koffi.out(koffi.pointer(region, 2)); + const structuringElementOutput = koffi.out(koffi.pointer(structuringElement, 2)); const obstruction = koffi.struct({ code: "uint32_t", coordinate_error: "uint32_t", @@ -226,22 +581,56 @@ point_y: "double", message: koffi.array("char", 256), }); + const receipt = koffi.struct({ + operation: "uint32_t", + reserved: "uint32_t", + input_components: "uint64_t", + convex_pieces: "uint64_t", + generated_pieces: "uint64_t", + generated_convolution_edges: "uint64_t", + overlay_passes: "uint64_t", + exact_crossings: "uint64_t", + output_cells: "uint64_t", + exact_coordinate_bit_growth: "uint64_t", + }); const obstructionOutput = koffi.out(koffi.pointer(obstruction)); - const meshCountOutput = koffi.out(koffi.pointer("size_t")); + const receiptOutput = koffi.out(koffi.pointer(receipt)); + const sizeOutput = koffi.out(koffi.pointer("size_t")); + const uint32Output = koffi.out(koffi.pointer("uint32_t")); + const int64Output = koffi.out(koffi.pointer("int64_t")); + const doubleOutput = koffi.out(koffi.pointer("double")); + const sizeArray = koffi.pointer("size_t"); return { abiVersion: library.func("ml_abi_version", "uint32_t", []), runtimeInitialize: library.func("ml_runtime_initialize", "uint32_t", []), delaunay: library.func("ml_delaunay_f64", "uint32_t", [koffi.pointer("double"), "size_t", meshOutput, obstructionOutput]), insertMany: library.func("ml_mesh_insert_many_f64", "uint32_t", [meshPointer, koffi.pointer("double"), "size_t", meshOutput, obstructionOutput]), - union: library.func("ml_mesh_union", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]), - intersection: library.func("ml_mesh_intersection", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]), - difference: library.func("ml_mesh_difference", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]), - symmetricDifference: library.func("ml_mesh_symmetric_difference", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]), - vertexCount: library.func("ml_mesh_vertex_count", "uint32_t", [meshPointer, meshCountOutput, obstructionOutput]), - triangleCount: library.func("ml_mesh_triangle_count", "uint32_t", [meshPointer, meshCountOutput, obstructionOutput]), - copyVertices: library.func("ml_mesh_copy_vertices_f64", "uint32_t", [meshPointer, koffi.out(koffi.pointer("double")), "size_t", meshCountOutput, obstructionOutput]), - copyTriangles: library.func("ml_mesh_copy_triangles_u32", "uint32_t", [meshPointer, koffi.out(koffi.pointer("uint32_t")), "size_t", meshCountOutput, obstructionOutput]), - free: library.func("ml_mesh_free", "void", [meshPointer]), + meshSiteUnion: library.func("ml_mesh_site_union", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]), + meshSiteIntersection: library.func("ml_mesh_site_intersection", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]), + meshSiteDifference: library.func("ml_mesh_site_difference", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]), + meshSiteSymmetricDifference: library.func("ml_mesh_site_symmetric_difference", "uint32_t", [meshPointer, meshPointer, meshOutput, obstructionOutput]), + vertexCount: library.func("ml_mesh_vertex_count", "uint32_t", [meshPointer, sizeOutput, obstructionOutput]), + triangleCount: library.func("ml_mesh_triangle_count", "uint32_t", [meshPointer, sizeOutput, obstructionOutput]), + copyVertices: library.func("ml_mesh_copy_vertices_f64", "uint32_t", [meshPointer, koffi.out(koffi.pointer("double")), "size_t", sizeOutput, obstructionOutput]), + copyTriangles: library.func("ml_mesh_copy_triangles_u32", "uint32_t", [meshPointer, koffi.out(koffi.pointer("uint32_t")), "size_t", sizeOutput, obstructionOutput]), + meshFree: library.func("ml_mesh_free", "void", [meshPointer]), + regionCreate: library.func("ml_region_create_f64", "uint32_t", [koffi.pointer("double"), "size_t", sizeArray, "size_t", sizeArray, "size_t", regionOutput, obstructionOutput]), + regionCounts: library.func("ml_region_counts", "uint32_t", [regionPointer, sizeOutput, sizeOutput, sizeOutput, obstructionOutput]), + regionCopy: library.func("ml_region_copy_f64", "uint32_t", [regionPointer, koffi.out(koffi.pointer("double")), "size_t", koffi.out(sizeArray), "size_t", koffi.out(sizeArray), "size_t", obstructionOutput]), + regionUnion: library.func("ml_region_union", "uint32_t", [regionPointer, regionPointer, regionOutput, obstructionOutput]), + regionIntersection: library.func("ml_region_intersection", "uint32_t", [regionPointer, regionPointer, regionOutput, obstructionOutput]), + regionDifference: library.func("ml_region_difference", "uint32_t", [regionPointer, regionPointer, regionOutput, obstructionOutput]), + regionSymmetricDifference: library.func("ml_region_symmetric_difference", "uint32_t", [regionPointer, regionPointer, regionOutput, obstructionOutput]), + regionLocate: library.func("ml_region_locate_point_f64", "uint32_t", [regionPointer, "double", "double", uint32Output, obstructionOutput]), + regionMeasure: library.func("ml_region_measure", "uint32_t", [regionPointer, int64Output, koffi.out(koffi.pointer("char")), "size_t", sizeOutput, doubleOutput, doubleOutput, obstructionOutput]), + regionFree: library.func("ml_region_free", "void", [regionPointer]), + structuringElementCreate: library.func("ml_structuring_element_create_f64", "uint32_t", [koffi.pointer("double"), "size_t", structuringElementOutput, obstructionOutput]), + structuringElementFree: library.func("ml_structuring_element_free", "void", [structuringElementPointer]), + regionMinkowskiSum: library.func("ml_region_minkowski_sum", "uint32_t", [regionPointer, regionPointer, regionOutput, receiptOutput, obstructionOutput]), + regionOffset: library.func("ml_region_offset", "uint32_t", [structuringElementPointer, regionPointer, regionOutput, receiptOutput, obstructionOutput]), + regionInset: library.func("ml_region_inset", "uint32_t", [structuringElementPointer, regionPointer, regionOutput, receiptOutput, obstructionOutput]), + regionOpen: library.func("ml_region_open", "uint32_t", [structuringElementPointer, regionPointer, regionOutput, receiptOutput, obstructionOutput]), + regionClose: library.func("ml_region_close", "uint32_t", [structuringElementPointer, regionPointer, regionOutput, receiptOutput, obstructionOutput]), }; } @@ -249,21 +638,85 @@ return Float64Array.from(points.flatMap(([x, y]) => [x, y])); } +function flattenLoops(loops: readonly (readonly Point[])[]): Float64Array { + return Float64Array.from(loops.flatMap((loop) => loop.flatMap(([x, y]) => [x, y]))); +} + +function produceHandle( + operation: (output: HandleOutput, obstruction: NativeObstruction) => number, +): NativeHandle { + const output: HandleOutput = [null]; + const obstruction: NativeObstruction = {}; + checkStatus(operation(output, obstruction), obstruction); + return requiredHandle(output[0]); +} + +function produceMorphology( + operation: ( + output: HandleOutput, + receipt: NativeMinkowskiReceipt, + obstruction: NativeObstruction, + ) => number, +): readonly [NativeHandle, MinkowskiReceipt] { + const output: HandleOutput = [null]; + const receipt: NativeMinkowskiReceipt = {}; + const obstruction: NativeObstruction = {}; + checkStatus(operation(output, receipt, obstruction), obstruction); + return [requiredHandle(output[0]), morphologyReceipt(receipt)]; +} + +function morphologyReceipt(receipt: NativeMinkowskiReceipt): MinkowskiReceipt { + return { + operation: operationCode(receipt.operation), + inputComponents: toBigInt(receipt.input_components), + convexPieces: toBigInt(receipt.convex_pieces), + generatedPieces: toBigInt(receipt.generated_pieces), + generatedConvolutionEdges: toBigInt(receipt.generated_convolution_edges), + overlayPasses: toBigInt(receipt.overlay_passes), + exactCrossings: toBigInt(receipt.exact_crossings), + outputCells: toBigInt(receipt.output_cells), + exactCoordinateBitGrowth: toBigInt(receipt.exact_coordinate_bit_growth), + }; +} + +function operationCode(value: number | undefined): MinkowskiOperation { + if (value === undefined || value < MinkowskiOperation.Addition || value > MinkowskiOperation.Closing) { + throw new Error(`Moonlight returned an unknown morphology operation ${value ?? "missing"}`); + } + return value; +} + +function locationCode(value: number | undefined): RegionLocation { + if (value === undefined || value < RegionLocation.Exterior || value > RegionLocation.Interior) { + throw new Error(`Moonlight returned an unknown region location ${value ?? "missing"}`); + } + return value; +} + function checkStatus(status: number, obstruction: NativeObstruction): void { if (status !== STATUS_OK) { throw new MoonlightError(status, obstruction); } } -function requiredHandle(handle: MeshHandle | null | undefined): MeshHandle { +function requiredHandle(handle: NativeHandle | null | undefined): NativeHandle { if (handle === null || handle === undefined) { - throw new Error("Moonlight returned success without a mesh handle"); + throw new Error("Moonlight returned success without a handle"); } return handle; } function toBigInt(value: NativeInteger | undefined): bigint { return value === undefined ? 0n : BigInt(value); +} + +function toSafeNumber(value: NativeInteger | undefined): number { + const exact = toBigInt(value); + const projected = Number(exact); + if (!Number.isSafeInteger(projected)) { + throw new Error(`Moonlight count ${exact} exceeds JavaScript's safe integer range`); + } + return projected; } function obstructionMessage(obstruction: NativeObstruction): string { diff --git a/bindings/typescript/test/binding.test.ts b/bindings/typescript/test/binding.test.ts --- a/bindings/typescript/test/binding.test.ts +++ b/bindings/typescript/test/binding.test.ts @@ -1,31 +1,67 @@ import assert from "node:assert/strict"; import test from "node:test"; -import { Moonlight, MoonlightError } from "../src/index.js"; +import { + MinkowskiOperation, + Moonlight, + MoonlightError, + RegionLocation, +} from "../src/index.js"; -test("immutable mesh algebra and dense projection", () => { +test("immutable site-set algebra and dense projection", () => { const engine = new Moonlight(); const left = engine.delaunay([[0, 0], [2, 0], [0, 2], [2, 2]]); const right = engine.delaunay([[2, 0], [4, 0], [2, 2], [4, 2]]); - const meshes = [ - left, - right, - left.union(right), - left.intersection(right), - left.difference(right), - left.symmetricDifference(right), - left.insertMany([[1, 1], [3, 1]]), - ]; - const [original, _right, union, intersection, difference, symmetric, extended] = meshes; - assert.equal(original?.vertexCount(), 4); - assert.equal(union?.vertexCount(), 6); - assert.equal(intersection?.vertexCount(), 2); - assert.equal(difference?.vertexCount(), 2); - assert.equal(symmetric?.vertexCount(), 4); - assert.equal(extended?.vertexCount(), 6); - assert.equal(original?.vertices().length, original?.vertexCount()); - assert.equal(original?.triangles().length, original?.triangleCount()); - meshes.forEach((mesh) => mesh.close()); + const union = left.siteUnion(right); + const intersection = left.siteIntersection(right); + const difference = left.siteDifference(right); + const symmetric = left.siteSymmetricDifference(right); + const extended = left.insertMany([[1, 1], [3, 1]]); + + assert.equal(left.vertexCount(), 4); + assert.equal(union.vertexCount(), 6); + assert.equal(intersection.vertexCount(), 2); + assert.equal(difference.vertexCount(), 2); + assert.equal(symmetric.vertexCount(), 4); + assert.equal(extended.vertexCount(), 6); + assert.equal(left.vertices().length, left.vertexCount()); + assert.equal(left.triangles().length, left.triangleCount()); + + left.close(); + right.close(); + union.close(); + intersection.close(); + difference.close(); + symmetric.close(); + extended.close(); +}); + +test("exact region Boolean, valuation, and morphology", () => { + const engine = new Moonlight(); + const left = engine.region([{ outer: [[0, 0], [2, 0], [2, 2], [0, 2]] }]); + const right = engine.region([{ outer: [[1, 0], [3, 0], [3, 2], [1, 2]] }]); + const intersection = left.intersection(right); + const symmetric = left.symmetricDifference(right); + const kernel = engine.structuringElement([[-0.5, -0.5], [0.5, -0.5], [0.5, 0.5], [-0.5, 0.5]]); + const [offset, receipt] = left.offset(kernel); + + assert.equal(left.components().length, 1); + assert.equal(left.components()[0]?.outer.length, 4); + assert.deepEqual(intersection.valuations().area, { numerator: 2n, denominator: 1n }); + assert.equal(symmetric.valuations().eulerCharacteristic, 2n); + assert.equal(left.locate([1, 1]), RegionLocation.Interior); + assert.equal(left.locate([0, 1]), RegionLocation.Boundary); + assert.equal(left.locate([3, 1]), RegionLocation.Exterior); + assert.deepEqual(offset.valuations().area, { numerator: 9n, denominator: 1n }); + assert.equal(receipt.operation, MinkowskiOperation.Addition); + assert(receipt.generatedPieces >= 1n); + + left.close(); + right.close(); + intersection.close(); + symmetric.close(); + kernel.close(); + offset.close(); }); test("invalid coordinate preserves typed witness", () => { diff --git a/cbits/moonlight-triangulation.def b/cbits/moonlight-triangulation.def --- a/cbits/moonlight-triangulation.def +++ b/cbits/moonlight-triangulation.def @@ -4,12 +4,29 @@ ml_runtime_initialize ml_delaunay_f64 ml_mesh_insert_many_f64 - ml_mesh_union - ml_mesh_intersection - ml_mesh_difference - ml_mesh_symmetric_difference + ml_mesh_site_union + ml_mesh_site_intersection + ml_mesh_site_difference + ml_mesh_site_symmetric_difference ml_mesh_vertex_count ml_mesh_triangle_count ml_mesh_copy_vertices_f64 ml_mesh_copy_triangles_u32 ml_mesh_free + ml_region_create_f64 + ml_region_counts + ml_region_copy_f64 + ml_region_union + ml_region_intersection + ml_region_difference + ml_region_symmetric_difference + ml_region_locate_point_f64 + ml_region_measure + ml_region_free + ml_structuring_element_create_f64 + ml_structuring_element_free + ml_region_minkowski_sum + ml_region_offset + ml_region_inset + ml_region_open + ml_region_close diff --git a/cbits/moonlight_runtime.c b/cbits/moonlight_runtime.c --- a/cbits/moonlight_runtime.c +++ b/cbits/moonlight_runtime.c @@ -44,5 +44,5 @@ #endif ML_API uint32_t ml_abi_version(void) { - return 1; + return 2; } diff --git a/include/moonlight_triangulation.h b/include/moonlight_triangulation.h --- a/include/moonlight_triangulation.h +++ b/include/moonlight_triangulation.h @@ -15,16 +15,20 @@ #endif typedef struct ml_mesh ml_mesh; +typedef struct ml_region ml_region; +typedef struct ml_structuring_element ml_structuring_element; typedef uint32_t ml_status; typedef uint32_t ml_obstruction_code; typedef uint32_t ml_coordinate_error; +typedef uint32_t ml_region_location; +typedef uint32_t ml_minkowski_operation; enum { ML_STATUS_OK = 0, ML_STATUS_NULL_POINTER = 1, ML_STATUS_COUNT_OVERFLOW = 2, ML_STATUS_BUFFER_TOO_SMALL = 3, - ML_STATUS_BUILD_OBSTRUCTION = 4, + ML_STATUS_GEOMETRY_OBSTRUCTION = 4, ML_STATUS_RUNTIME_FAILURE = 5 }; @@ -84,10 +88,18 @@ ML_OBSTRUCTION_FACE_CAPACITY_EXCEEDED = 52, ML_OBSTRUCTION_PAYLOAD_STORAGE_FAILURE = 53, ML_OBSTRUCTION_COORDINATE_PAYLOAD_COUNT_MISMATCH = 54, + ML_OBSTRUCTION_CIRCLE_SWEEP_REQUIRES_DENSE_STORAGE = 55, ML_OBSTRUCTION_NULL_POINTER = 100, ML_OBSTRUCTION_COUNT_OVERFLOW = 101, ML_OBSTRUCTION_BUFFER_TOO_SMALL = 102, - ML_OBSTRUCTION_RUNTIME_FAILURE = 103 + ML_OBSTRUCTION_RUNTIME_FAILURE = 103, + ML_OBSTRUCTION_REGION_LAYOUT_INVALID = 200, + ML_OBSTRUCTION_REGION_VALIDATION_FAILED = 201, + ML_OBSTRUCTION_OVERLAY_FAILED = 202, + ML_OBSTRUCTION_REGION_PUBLICATION_FAILED = 203, + ML_OBSTRUCTION_VALUATION_FAILED = 204, + ML_OBSTRUCTION_MINKOWSKI_FAILED = 205, + ML_OBSTRUCTION_REGION_PROJECTION_FAILED = 206 }; enum { @@ -98,6 +110,19 @@ ML_COORDINATE_ERROR_TOO_LARGE = 4 }; +enum { + ML_REGION_EXTERIOR = 0, + ML_REGION_BOUNDARY = 1, + ML_REGION_INTERIOR = 2 +}; + +enum { + ML_MINKOWSKI_ADDITION = 0, + ML_MINKOWSKI_EROSION = 1, + ML_MINKOWSKI_OPENING = 2, + ML_MINKOWSKI_CLOSING = 3 +}; + typedef struct ml_obstruction { uint32_t code; uint32_t coordinate_error; @@ -111,19 +136,88 @@ char message[256]; } ml_obstruction; +typedef struct ml_minkowski_receipt { + uint32_t operation; + uint32_t reserved; + uint64_t input_components; + uint64_t convex_pieces; + uint64_t generated_pieces; + uint64_t generated_convolution_edges; + uint64_t overlay_passes; + uint64_t exact_crossings; + uint64_t output_cells; + uint64_t exact_coordinate_bit_growth; +} ml_minkowski_receipt; + ML_API uint32_t ml_abi_version(void); ML_API ml_status ml_runtime_initialize(void); + +/* Immutable Delaunay meshes; these operations combine site sets, not regions. */ ML_API ml_status ml_delaunay_f64(const double *coordinates, size_t point_count, ml_mesh **result, ml_obstruction *obstruction); ML_API ml_status ml_mesh_insert_many_f64(const ml_mesh *mesh, const double *coordinates, size_t point_count, ml_mesh **result, ml_obstruction *obstruction); -ML_API ml_status ml_mesh_union(const ml_mesh *left, const ml_mesh *right, ml_mesh **result, ml_obstruction *obstruction); -ML_API ml_status ml_mesh_intersection(const ml_mesh *left, const ml_mesh *right, ml_mesh **result, ml_obstruction *obstruction); -ML_API ml_status ml_mesh_difference(const ml_mesh *left, const ml_mesh *right, ml_mesh **result, ml_obstruction *obstruction); -ML_API ml_status ml_mesh_symmetric_difference(const ml_mesh *left, const ml_mesh *right, ml_mesh **result, ml_obstruction *obstruction); +ML_API ml_status ml_mesh_site_union(const ml_mesh *left, const ml_mesh *right, ml_mesh **result, ml_obstruction *obstruction); +ML_API ml_status ml_mesh_site_intersection(const ml_mesh *left, const ml_mesh *right, ml_mesh **result, ml_obstruction *obstruction); +ML_API ml_status ml_mesh_site_difference(const ml_mesh *left, const ml_mesh *right, ml_mesh **result, ml_obstruction *obstruction); +ML_API ml_status ml_mesh_site_symmetric_difference(const ml_mesh *left, const ml_mesh *right, ml_mesh **result, ml_obstruction *obstruction); ML_API ml_status ml_mesh_vertex_count(const ml_mesh *mesh, size_t *count, ml_obstruction *obstruction); ML_API ml_status ml_mesh_triangle_count(const ml_mesh *mesh, size_t *count, ml_obstruction *obstruction); ML_API ml_status ml_mesh_copy_vertices_f64(const ml_mesh *mesh, double *coordinates, size_t point_capacity, size_t *points_written, ml_obstruction *obstruction); ML_API ml_status ml_mesh_copy_triangles_u32(const ml_mesh *mesh, uint32_t *triangles, size_t triangle_capacity, size_t *triangles_written, ml_obstruction *obstruction); ML_API void ml_mesh_free(ml_mesh *mesh); + +/* + * Bulk exact-region authoring. loop_point_counts gives the number of points in + * each loop; component_loop_counts gives the number of loops in each component. + * Within each component, the first loop is a CCW outer loop and subsequent + * loops are CW holes. + */ +ML_API ml_status ml_region_create_f64( + const double *coordinates, + size_t point_count, + const size_t *loop_point_counts, + size_t loop_count, + const size_t *component_loop_counts, + size_t component_count, + ml_region **result, + ml_obstruction *obstruction +); +ML_API ml_status ml_region_counts(const ml_region *region, size_t *component_count, size_t *loop_count, size_t *point_count, ml_obstruction *obstruction); +/* Capacities count points or offset entries; copied coordinates are a derived binary64 rendering projection. */ +ML_API ml_status ml_region_copy_f64( + const ml_region *region, + double *coordinates, + size_t point_capacity, + size_t *loop_point_offsets, + size_t loop_offset_capacity, + size_t *component_loop_offsets, + size_t component_offset_capacity, + ml_obstruction *obstruction +); +ML_API ml_status ml_region_union(const ml_region *left, const ml_region *right, ml_region **result, ml_obstruction *obstruction); +ML_API ml_status ml_region_intersection(const ml_region *left, const ml_region *right, ml_region **result, ml_obstruction *obstruction); +ML_API ml_status ml_region_difference(const ml_region *left, const ml_region *right, ml_region **result, ml_obstruction *obstruction); +ML_API ml_status ml_region_symmetric_difference(const ml_region *left, const ml_region *right, ml_region **result, ml_obstruction *obstruction); +ML_API ml_status ml_region_locate_point_f64(const ml_region *region, double x, double y, ml_region_location *location, ml_obstruction *obstruction); +/* area_bytes_written excludes the trailing NUL; area_capacity includes it. */ +ML_API ml_status ml_region_measure( + const ml_region *region, + int64_t *euler_characteristic, + char *area_ratio_utf8, + size_t area_capacity, + size_t *area_bytes_written, + double *perimeter_lower, + double *perimeter_upper, + ml_obstruction *obstruction +); +ML_API void ml_region_free(ml_region *region); + +ML_API ml_status ml_structuring_element_create_f64(const double *coordinates, size_t point_count, ml_structuring_element **result, ml_obstruction *obstruction); +ML_API void ml_structuring_element_free(ml_structuring_element *element); +ML_API ml_status ml_region_minkowski_sum(const ml_region *left, const ml_region *right, ml_region **result, ml_minkowski_receipt *receipt, ml_obstruction *obstruction); +ML_API ml_status ml_region_offset(const ml_structuring_element *element, const ml_region *region, ml_region **result, ml_minkowski_receipt *receipt, ml_obstruction *obstruction); +ML_API ml_status ml_region_inset(const ml_structuring_element *element, const ml_region *region, ml_region **result, ml_minkowski_receipt *receipt, ml_obstruction *obstruction); +ML_API ml_status ml_region_open(const ml_structuring_element *element, const ml_region *region, ml_region **result, ml_minkowski_receipt *receipt, ml_obstruction *obstruction); +ML_API ml_status ml_region_close(const ml_structuring_element *element, const ml_region *region, ml_region **result, ml_minkowski_receipt *receipt, ml_obstruction *obstruction); #ifdef __cplusplus } 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.2.0.1 +version: 1.3.0.0 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 @@ -19,6 +19,8 @@ with natural-neighbour interpolation and Delaunay hierarchy hints; a bounded-concurrency interpreter for the join tournament; and a versioned binary serialization surface. + On GHC 9.14, a public cell-complex component interprets + admitted exact cell selections for Homology and Category. Failure is values: every refusal names its witness. license: MIT license-file: LICENSE @@ -38,6 +40,12 @@ CHANGELOG.md extra-source-files: weeder.toml + bench/delaunay-compare/README.md + -- Receipts and their SVG projections remain beside the benchmark, but are + -- not package inputs: taking a new measurement must not rebuild the library. + bench/delaunay-compare/rust/Cargo.lock + bench/delaunay-compare/rust/Cargo.toml + bench/delaunay-compare/rust/src/lib.rs include/moonlight_triangulation.h bindings/README.md bindings/python/pyproject.toml @@ -58,6 +66,12 @@ location: https://github.com/PaleRoses/moonlight.git subdir: moonlight-triangulation +source-repository this + type: git + location: https://github.com/PaleRoses/moonlight.git + tag: moonlight-triangulation-1.3.0.0 + subdir: moonlight-triangulation + flag warnings-as-errors description: Treat compiler warnings as errors in package validation. default: False @@ -78,11 +92,19 @@ -Wno-missing-import-lists if flag(warnings-as-errors) ghc-options: -Werror + -- The hot modules that request LLVM O3 replace GHC's default optimiser + -- recipe. GHC 9.8 therefore needs its supported legacy pass manager stated + -- explicitly; LLVM 15 otherwise combines the new manager with old TBAA + -- pass flags and refuses before code generation. + if impl(ghc < 9.10) + ghc-options: -optlo-enable-new-pm=0 -- ── the tower ──────────────────────────────────────────────────────────────── --- The main tower is core <- dcel <- build <- dual <- facade. Serialize branches +-- The main construction tower is core <- dcel <- build. Dual branches directly +-- from dcel; the apex owns only the genuine overlaps: planar algebra descends +-- through build, while hierarchy hints glue build and dual. Serialize branches -- from dcel and parallel branches from build, keeping their effect dependencies --- out of the tower. The graph is acyclic and uses no @.hs-boot@ files. +-- out of the tower. The graph is acyclic and uses no @.hs-boot@ files. library core import: shared-properties @@ -121,10 +143,8 @@ Moonlight.Triangulation.Dcel Moonlight.Triangulation.Payload Moonlight.Triangulation.JoinSemilattice - Moonlight.Triangulation.Handles Moonlight.Triangulation.Handles.HandleDefs Moonlight.Triangulation.Handles.Dynamic - Moonlight.Triangulation.Handles.Iterators Moonlight.Triangulation.Handles.Iterators.CircularIterator Moonlight.Triangulation.Handles.Iterators.DynamicIterators Moonlight.Triangulation.Handles.Iterators.FixedIterators @@ -146,7 +166,6 @@ Moonlight.Triangulation.Internal.Mutable Moonlight.Triangulation.Internal.OperationState Moonlight.Triangulation.Internal.Probe - Moonlight.Triangulation.Internal.DcelOperations Moonlight.Triangulation.Internal.DcelOperations.CandidateArena Moonlight.Triangulation.Internal.DcelOperations.Chain Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite @@ -169,27 +188,42 @@ , moonlight-triangulation:core ghc-options: -fexpose-all-unfoldings +-- An ExactCellSet already carries every handle and closure witness needed to +-- interpret it as a generic finite cell complex. This component is the +-- canonical owner of that interpretation and deliberately remains outside the +-- portable geometry tower because its Homology dependency requires GHC 9.14. +library cell-complex + import: shared-properties + visibility: public + hs-source-dirs: src-cell-complex + default-extensions: + TypeFamilies + exposed-modules: + Moonlight.Triangulation.CellComplex + if impl(ghc < 9.14) + buildable: False + build-depends: + base >= 4.22 && < 5 + , containers >= 0.6 && < 0.9 + , moonlight-algebra:abstract >= 0.1 && < 0.2 + , moonlight-homology:cell-complex >= 0.1 && < 0.2 + , moonlight-triangulation:dcel + library build import: shared-properties visibility: public - hs-source-dirs: - src-build - src-embedding + hs-source-dirs: src-build exposed-modules: Moonlight.Triangulation.BulkLoad Moonlight.Triangulation.Removal Moonlight.Triangulation.Session Moonlight.Triangulation.Cdt - Moonlight.Triangulation.Minkowski - Moonlight.Triangulation.Overlay Moonlight.Triangulation.Refinement Moonlight.Triangulation.SetAlgebra Moonlight.Triangulation.Internal.Cdt.Build Moonlight.Triangulation.Internal.Cdt.Query Moonlight.Triangulation.Internal.Cdt.Types Moonlight.Triangulation.Internal.Cdt.Union - Moonlight.Triangulation.Internal.Overlay.Arrangement - Moonlight.Triangulation.Internal.Overlay.Resident Moonlight.Triangulation.Internal.Join Moonlight.Triangulation.Internal.Join.Seam other-modules: @@ -213,10 +247,6 @@ Moonlight.Triangulation.Internal.Join.Plan Moonlight.Triangulation.Internal.Join.Rebuild Moonlight.Triangulation.Internal.Join.SiteSet - Moonlight.Triangulation.Internal.Overlay.Embedding - Moonlight.Triangulation.Internal.Overlay.Types - Moonlight.Triangulation.Internal.Minkowski.Convex - Moonlight.Triangulation.Internal.Minkowski.Types build-depends: base >= 4.19 && < 5 , containers >= 0.8 && < 0.9 @@ -240,7 +270,6 @@ base >= 4.19 && < 5 , async >= 2.2 && < 2.3 , deepseq >= 1.5 && < 1.6 - , moonlight-triangulation:core , moonlight-triangulation:build , moonlight-triangulation:dcel ghc-options: -fexpose-all-unfoldings @@ -277,7 +306,6 @@ Moonlight.Triangulation.Voronoi Moonlight.Triangulation.Voronoi.Handles Moonlight.Triangulation.Interpolation - Moonlight.Triangulation.HintGenerator other-modules: Moonlight.Triangulation.Internal.InterpolationWorkspace build-depends: @@ -287,16 +315,30 @@ , vector >= 0.13 && < 0.14 , moonlight-triangulation:core , moonlight-triangulation:dcel - , moonlight-triangulation:build ghc-options: -fexpose-all-unfoldings library import: shared-properties - hs-source-dirs: src-public + hs-source-dirs: + src-public + src-planar exposed-modules: Moonlight.Triangulation + Moonlight.Triangulation.HintGenerator + Moonlight.Triangulation.Minkowski + Moonlight.Triangulation.Overlay + Moonlight.Triangulation.Internal.Overlay.Arrangement + Moonlight.Triangulation.Internal.Overlay.Embedding + Moonlight.Triangulation.Internal.Overlay.Resident + other-modules: + Moonlight.Triangulation.Internal.Minkowski.Convex + Moonlight.Triangulation.Internal.Minkowski.Types + 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 , moonlight-triangulation:build @@ -311,6 +353,7 @@ Moonlight.Triangulation.Foreign.ABI build-depends: base >= 4.19 && < 5 + , containers >= 0.8 && < 0.9 , vector >= 0.13 && < 0.14 , moonlight-triangulation , moonlight-triangulation:build @@ -330,7 +373,7 @@ moonlight_triangulation.h build-depends: base >= 4.19 && < 5 - , moonlight-triangulation:ffi >= 1.2 && < 1.3 + , moonlight-triangulation:ffi >= 1.3 && < 1.4 ghc-options: -threaded if os(windows) options: standalone @@ -338,7 +381,7 @@ else extra-libraries: pthread if os(linux) - lib-version-info: 1:0:0 + lib-version-info: 2:0:0 -- ── test slices ────────────────────────────────────────────────────────────── @@ -350,28 +393,22 @@ common triangulation-test-properties import: shared-properties + ghc-options: -O0 build-depends: base >= 4.19 && < 5 - , deepseq >= 1.5 && < 1.6 , vector >= 0.13 && < 0.14 - , primitive >= 0.9 && < 0.10 , moonlight-triangulation common triangulation-test-support-slice other-modules: Support common triangulation-native-test-slice - -- The focused milestone spec reaches into the dedicated @src-embedding@ - -- root for exactly this one hidden certifier. Keeping that source root - -- singular prevents package modules from becoming duplicate test home modules. - hs-source-dirs: src-embedding other-modules: Moonlight.Triangulation.NativeSpec Moonlight.Triangulation.FilteredPredicateOptimizationSpec Moonlight.Triangulation.ExactEmbeddingSpec Moonlight.Triangulation.OverlaySpec Moonlight.Triangulation.RegionSpec - Moonlight.Triangulation.Internal.Overlay.Embedding -- The RTS options this module needs are named on the SUITES rather than -- here, which is the one place the slice-owns-its-requirements rule cannot -- hold. @-with-rtsopts@ is CONCATENATED by GHC across repetitions, so a @@ -382,6 +419,8 @@ ghc-options: -threaded -rtsopts build-depends: containers >= 0.8 && < 0.9 + , deepseq >= 1.5 && < 1.6 + , primitive >= 0.9 && < 0.10 , moonlight-triangulation:core , moonlight-triangulation:dcel , moonlight-triangulation:build @@ -392,6 +431,7 @@ build-depends: binary >= 0.8 && < 0.9 , bytestring >= 0.12 && < 0.13 + , deepseq >= 1.5 && < 1.6 , moonlight-triangulation:dcel , moonlight-triangulation:serialize @@ -420,14 +460,12 @@ containers >= 0.8 && < 0.9 , moonlight-triangulation:core , moonlight-triangulation:dcel - , moonlight-triangulation:build common triangulation-minkowski-law-slice other-modules: Moonlight.Triangulation.MinkowskiSpec build-depends: moonlight-triangulation:core , moonlight-triangulation:dcel - , moonlight-triangulation:build -- The agreement between the seam schedule and the reference rebuild. It names -- an internal schedule, so it reaches below the wall and travels with the @@ -441,6 +479,25 @@ ghc-options: -threaded -rtsopts build-depends: moonlight-triangulation:parallel +test-suite moonlight-triangulation-cell-complex-test + import: shared-properties + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/cell-complex + default-extensions: + TypeFamilies + if impl(ghc < 9.14) + buildable: False + build-depends: + base >= 4.22 && < 5 + , moonlight-homology:cell-complex >= 0.1 && < 0.2 + , moonlight-triangulation:build + , moonlight-triangulation:cell-complex + , moonlight-triangulation:dcel + , tasty >= 1.4 && < 1.6 + , tasty-hunit >= 0.10 && < 0.11 + , vector >= 0.13 && < 0.14 + -- The single statement of the RTS environment every suite runs under: -N so -- that the concurrent tournament has more than one capability to be scheduled -- onto, -T so that the filtered-predicate test can read allocation counters. @@ -570,6 +627,7 @@ primitive >= 0.9 && < 0.10 , moonlight-triangulation:dcel , moonlight-triangulation:build + , moonlight-triangulation:ffi common triangulation-dcel-benchmark-slice other-modules: Moonlight.Triangulation.DcelBench @@ -591,7 +649,74 @@ containers >= 0.8 && < 0.9 , moonlight-triangulation:core , moonlight-triangulation:dcel + +-- The package-owned external construction board deliberately uses tasty-bench: +-- unlike the native work-counter slices above, its only lawful common metric +-- across Haskell and four Rust referents is elapsed or CPU time. The Rust +-- crate is a foreign adapter; Moonlight owns the case algebra, agreement +-- descent, timing, receipt parser, and derived pictures here. +common triangulation-delaunay-compare-properties + import: shared-properties + ghc-options: -O2 + build-depends: + base >= 4.19 && < 5 + , deepseq >= 1.5 && < 1.6 , moonlight-triangulation:build + , moonlight-triangulation:dcel + +executable moonlight-triangulation-delaunay-compare + import: triangulation-delaunay-compare-properties + ghc-options: -threaded -rtsopts + main-is: Main.hs + hs-source-dirs: bench/delaunay-compare + other-modules: + Moonlight.Triangulation.Bench.DelaunayCompare.Domain + Moonlight.Triangulation.Bench.DelaunayCompare.Native + Moonlight.Triangulation.Bench.DelaunayCompare.Suite + build-depends: + directory >= 1.3 && < 1.4 + , filepath >= 1.4 && < 1.6 + , process >= 1.6 && < 1.7 + , tasty-bench >= 0.3 && < 0.6 + , transformers >= 0.5 && < 0.7 + , unix >= 2.8 && < 2.9 + , vector >= 0.13 && < 0.14 + +executable moonlight-triangulation-delaunay-pictures + import: triangulation-delaunay-compare-properties + main-is: PictureMain.hs + hs-source-dirs: bench/delaunay-compare + other-modules: + Moonlight.Triangulation.Bench.DelaunayCompare.Domain + Moonlight.Triangulation.Bench.DelaunayCompare.Picture + build-depends: + containers >= 0.8 && < 0.9 + , directory >= 1.3 && < 1.4 + , filepath >= 1.4 && < 1.6 + , transformers >= 0.5 && < 0.7 + +executable moonlight-triangulation-category-observatory-export + import: shared-properties + main-is: Main.hs + hs-source-dirs: app/category-observatory + ghc-options: -Wall -Wcompat + default-extensions: + TypeFamilies + if impl(ghc < 9.14) + buildable: False + build-depends: + aeson >= 2.2 && < 2.4 + , base >= 4.22 && < 5 + , bytestring >= 0.12 && < 0.13 + , containers >= 0.6 && < 0.9 + , moonlight-category >= 1.1.0.0 && < 1.2 + , moonlight-category:simplicial >= 1.1.0.0 && < 1.2 + , moonlight-homology:cell-category >= 0.1 && < 0.2 + , moonlight-homology:cell-complex >= 0.1 && < 0.2 + , moonlight-triangulation:build + , moonlight-triangulation:cell-complex + , moonlight-triangulation:dcel + , vector >= 0.13 && < 0.14 benchmark moonlight-triangulation-build-bench import: diff --git a/src-build/Moonlight/Triangulation/BulkLoad.hs b/src-build/Moonlight/Triangulation/BulkLoad.hs --- a/src-build/Moonlight/Triangulation/BulkLoad.hs +++ b/src-build/Moonlight/Triangulation/BulkLoad.hs @@ -627,61 +627,49 @@ -> Either BuildError (BuildResult mode vertex directed undirected face) insertMany triangulation input = do validateVertices input - ensureCapacity (numVertices triangulation + V.length input) - runST $ do - mutable <- - thawTriangulationDense - (numVertices triangulation + V.length input) - triangulation - operation <- newOperationState (halfEdgeCapacity mutable) - table <- newMutablePointIndex (numVertices triangulation + V.length input) - seeded <- seedPointTable mutable table - case seeded of - Left failure -> pure (Left failure) - Right () -> do - mapping <- newPrimArray (V.length input) - freshBuffer <- MUV.new (V.length input) - filled <- fill mutable operation table mapping freshBuffer 0 0 0 0 - case filled of - Left failure -> pure (Left failure) - Right (sumX, sumY, freshCount) -> do - let !existingCount = V.length input - freshCount - setCounter operation CounterInputPoints (V.length input) - setCounter operation CounterUniquePoints freshCount - setCounter operation CounterExistingPoints existingCount - setCounter operation CounterDuplicatePoints existingCount - inserted <- - if freshCount == 0 - then pure (Right 0) - else do - let !scale = recip (fromIntegral freshCount) - arena <- - fillRadialArena - mutable - (sumX * scale) - (sumY * scale) - (MUV.unsafeRead freshBuffer) - freshCount - orderedArena <- radiallyOrderArena arena - circleSweepInsert mutable operation orderedArena - case inserted of - Left failure -> pure (Left failure) - Right seedCount -> do - setCounter operation CounterSpatialSeedPoints seedCount - frozenOutcome <- freezeTriangulation mutable - case frozenOutcome of - Left failure -> pure (Left failure) - Right frozen -> do - mapped <- unsafeFreezePrimArray mapping - stats <- freezeBuildStats operation - pure - ( Right - BuildResult - { buildTriangulation = frozen - , buildInputVertices = mapped - , buildStats = stats - } - ) + (mapped, frozen, stats) <- + runTransaction id DenseTransaction triangulation (V.length input) $ \mutable operation -> do + table <- newMutablePointIndex (pointCapacity mutable) + seeded <- seedPointTable mutable table + case seeded of + Left failure -> pure (Left failure) + Right () -> do + mapping <- newPrimArray (V.length input) + freshBuffer <- MUV.new (V.length input) + filled <- fill mutable operation table mapping freshBuffer 0 0 0 0 + case filled of + Left failure -> pure (Left failure) + Right (sumX, sumY, freshCount) -> do + let !existingCount = V.length input - freshCount + setCounter operation CounterInputPoints (V.length input) + setCounter operation CounterUniquePoints freshCount + setCounter operation CounterExistingPoints existingCount + setCounter operation CounterDuplicatePoints existingCount + inserted <- + if freshCount == 0 + then pure (Right 0) + else do + let !scale = recip (fromIntegral freshCount) + arena <- + fillRadialArena + mutable + (sumX * scale) + (sumY * scale) + (MUV.unsafeRead freshBuffer) + freshCount + orderedArena <- radiallyOrderArena arena + circleSweepInsert mutable operation orderedArena + case inserted of + Left failure -> pure (Left failure) + Right seedCount -> do + setCounter operation CounterSpatialSeedPoints seedCount + Right <$> unsafeFreezePrimArray mapping + pure + BuildResult + { buildTriangulation = frozen + , buildInputVertices = mapped + , buildStats = stats + } where fill :: forall s diff --git a/src-build/Moonlight/Triangulation/Cdt.hs b/src-build/Moonlight/Triangulation/Cdt.hs --- a/src-build/Moonlight/Triangulation/Cdt.hs +++ b/src-build/Moonlight/Triangulation/Cdt.hs @@ -4,7 +4,8 @@ ( ConstrainedDelaunayTriangulation , CdtError (..) , CorridorObstruction (..) - , ConstraintResult (..) + , ConstraintRecoveryResult (..) + , ConstraintResult , ConstraintOutcome (..) , ConstraintBatchStats (..) , ConstraintBatchResult (..) @@ -28,7 +29,7 @@ , constrainedSeamRightConstraintEvidence , constrainedSeamConstraintStats , constrainedSeamBuildStats - , ConstraintSplitBatchResult (..) + , ConstraintSplitBatchResult , CdtBuildResult (..) , constrainedDelaunay , constrainedDelaunayMaximal @@ -104,8 +105,9 @@ , ConstrainedSeamSource (..) , ConstraintConflict (..) , ConstraintOutcome (..) - , ConstraintResult (..) - , ConstraintSplitBatchResult (..) + , ConstraintRecoveryResult (..) + , ConstraintResult + , ConstraintSplitBatchResult , CorridorObstruction (..) ) import Moonlight.Triangulation.Internal.Cdt.Union diff --git a/src-build/Moonlight/Triangulation/Insertion.hs b/src-build/Moonlight/Triangulation/Insertion.hs --- a/src-build/Moonlight/Triangulation/Insertion.hs +++ b/src-build/Moonlight/Triangulation/Insertion.hs @@ -14,7 +14,18 @@ import Control.Monad.ST (ST) import Moonlight.Triangulation.Handles.HandleDefs (VertexId (..)) -import Moonlight.Triangulation.Internal.DcelOperations +import Moonlight.Triangulation.Internal.DcelOperations.Chain + ( extendLine + , lineToArea + , setupFirstVertex + , setupSecondVertex + , splitLineEdge + ) +import Moonlight.Triangulation.Internal.DcelOperations.Hull (insertOutsideHull) +import Moonlight.Triangulation.Internal.DcelOperations.Subdivide + ( insertIntoFace + , insertOnEdge + ) import Moonlight.Triangulation.Internal.Location import Moonlight.Triangulation.Internal.Mutable import Moonlight.Triangulation.Internal.OperationState diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Batch.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Batch.hs --- a/src-build/Moonlight/Triangulation/Internal/Cdt/Batch.hs +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Batch.hs @@ -6,6 +6,7 @@ module Moonlight.Triangulation.Internal.Cdt.Batch ( recoverConstraints , recoverConstraintBatch + , finalizeConstraintBatch , initialConstraintBatchStats , interpretConstraintRequest , interpretConstraintRequests diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Build.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Build.hs --- a/src-build/Moonlight/Triangulation/Internal/Cdt/Build.hs +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Build.hs @@ -9,13 +9,13 @@ , constrainedDelaunayMaximal ) where +import Data.Bifunctor (first) import qualified Data.Vector as V import Data.Primitive.PrimArray (PrimArray, indexPrimArray, sizeofPrimArray) import Data.Word (Word32) import Moonlight.Triangulation.BulkLoad (delaunay) import Moonlight.Triangulation.Handles.HandleDefs import Moonlight.Triangulation.Internal.Cdt.Batch (recoverConstraints) -import Moonlight.Triangulation.Internal.Cdt.Combinators (mapLeft) import Moonlight.Triangulation.Internal.Cdt.Types import Moonlight.Triangulation.Internal.Representation import Moonlight.Triangulation.Internal.Types @@ -37,13 +37,7 @@ constrainedDelaunay defaults inputVertices constraints = do result <- constrainedDelaunayMaximal defaults inputVertices constraints if V.null (cdtRejectedConstraints result) - then - Right - BuildResult - { buildTriangulation = cdtBuildTriangulation result - , buildInputVertices = cdtBuildInputVertices result - , buildStats = cdtBuildStats result - } + then Right (cdtAcceptedBuild result) else Left (ConstraintInputConflicts (cdtRejectedConstraints result)) -- | Stable constrained bulk loading. Duplicate input vertices are rerouted to @@ -56,7 +50,7 @@ -> V.Vector (Int, Int) -> Either (CdtError) (CdtBuildResult vertex directed undirected face) constrainedDelaunayMaximal defaults inputVertices constraints = do - built <- mapLeft CdtBuildError (delaunay defaults inputVertices) + built <- first CdtBuildError (delaunay defaults inputVertices) let !mapping = buildInputVertices built !initial = fromDelaunay (buildTriangulation built) requests <- V.mapM (mapConstraintRequest mapping) constraints @@ -71,9 +65,12 @@ (V.zip constraints (constraintBatchOutcomes batch)) pure CdtBuildResult - { cdtBuildTriangulation = constraintBatchTriangulation batch - , cdtBuildInputVertices = mapping - , cdtBuildStats = buildStats built + { cdtAcceptedBuild = + BuildResult + { buildTriangulation = constraintBatchTriangulation batch + , buildInputVertices = mapping + , buildStats = buildStats built + } , cdtRejectedConstraints = rejected } where diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Combinators.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Combinators.hs --- a/src-build/Moonlight/Triangulation/Internal/Cdt/Combinators.hs +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Combinators.hs @@ -7,7 +7,6 @@ ( foldWhileM , bindMutable , asConstraintStep - , mapLeft , vertexInt , directedInt ) where @@ -57,11 +56,8 @@ -- | Relabel a step whose refusal is a build failure, so it composes with the -- constraint layer's own. asConstraintStep :: Functor f => f (Either BuildError a) -> f (Either (CdtError) a) -asConstraintStep = fmap (mapLeft CdtBuildError) +asConstraintStep = fmap (either (Left . CdtBuildError) Right) {-# INLINE asConstraintStep #-} - -mapLeft :: (left -> right) -> Either left value -> Either right value -mapLeft convert = either (Left . convert) Right vertexInt :: VertexId -> Int vertexInt (VertexId value) = fromIntegral value diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Recovery.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Recovery.hs --- a/src-build/Moonlight/Triangulation/Internal/Cdt/Recovery.hs +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Recovery.hs @@ -32,7 +32,9 @@ ) import Moonlight.Triangulation.Internal.Cdt.Query (findMutableEdge) import Moonlight.Triangulation.Internal.Cdt.Types -import Moonlight.Triangulation.Internal.DcelOperations +import Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite (flipEdge) +import Moonlight.Triangulation.Internal.DcelOperations.FlipRule (isFlippableEdge) +import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeEdges) import Moonlight.Triangulation.Internal.Growable (GrowableWord32) import Moonlight.Triangulation.Internal.Mutable import Moonlight.Triangulation.Internal.OperationState diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Segment.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Segment.hs --- a/src-build/Moonlight/Triangulation/Internal/Cdt/Segment.hs +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Segment.hs @@ -6,21 +6,17 @@ module Moonlight.Triangulation.Internal.Cdt.Segment ( addConstraintEdge , addConstraintEdges - , applyConstraintToExistingEndpoints - , applyAndPublishConstraint - , publishConstraintResult - , insertPolylineVertices , removeConstraintEdge , retireConstraintEdge ) where -import Control.Monad.ST (ST, runST) +import Control.Monad.ST (ST) +import Data.Bifunctor (first) import qualified Data.Vector as V import Data.Primitive.PrimArray (indexPrimArray, sizeofPrimArray) import Moonlight.Triangulation.BulkLoad (insertMany) import qualified Moonlight.Triangulation.Dcel as Dcel import Moonlight.Triangulation.Handles.HandleDefs -import Moonlight.Triangulation.Internal.Capacity (ensureCapacity) import Moonlight.Triangulation.Internal.Cdt.Admission ( ConstraintAdmission (..) , constraintAdmission @@ -29,7 +25,6 @@ import Moonlight.Triangulation.Internal.Cdt.Combinators ( asConstraintStep , bindMutable - , mapLeft ) import Moonlight.Triangulation.Internal.Cdt.Recovery (applyMutableConstraint) import Moonlight.Triangulation.Internal.Cdt.Site @@ -37,19 +32,16 @@ , placeConstraintEndpoint ) import Moonlight.Triangulation.Internal.Cdt.Types -import Moonlight.Triangulation.Internal.DcelOperations +import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeEdges) import Moonlight.Triangulation.Internal.Growable ( GrowableWord32 , newGrowableWord32 ) import Moonlight.Triangulation.Internal.Mutable -import Moonlight.Triangulation.Internal.OperationState - ( Counter (..) - , OperationState - , addCounter - , newOperationState - ) +import Moonlight.Triangulation.Internal.OperationState (OperationState) +import Moonlight.Triangulation.Internal.Paged (TransactionShape (LocalTransaction)) import Moonlight.Triangulation.Internal.Representation +import Moonlight.Triangulation.Internal.Transaction (runUnmeasuredTransaction) import Moonlight.Triangulation.Internal.Types import Moonlight.Triangulation.Math @@ -63,8 +55,8 @@ -> vertex -> Either (CdtError) (ConstraintResult vertex directed undirected face) addConstraintEdge triangulation fromVertex toVertex = do - _ <- mapLeft CdtBuildError (validatePoint Nothing fromPoint) - _ <- mapLeft CdtBuildError (validatePoint Nothing toPoint) + _ <- first CdtBuildError (validatePoint Nothing fromPoint) + _ <- first CdtBuildError (validatePoint Nothing toPoint) result <- case ( lookupExistingConstraintEndpoint triangulation fromPoint @@ -85,23 +77,21 @@ where !fromPoint = position fromVertex !toPoint = position toVertex - -- Both endpoints may be new; neither may be. The reservation is for the peak. - !capacity = Dcel.numVertices triangulation + 2 addConstraintWithEndpointPlacement = do - mapLeft CdtBuildError (ensureCapacity capacity) - runST $ do - mutable <- thawTriangulation capacity triangulation - operation <- newOperationState (halfEdgeCapacity mutable) - programWords <- newGrowableWord32 256 - asConstraintStep (placeConstraintEndpoint mutable operation Nothing fromPoint fromVertex) - `bindMutable` \from -> - asConstraintStep (placeConstraintEndpoint mutable operation Nothing toPoint toVertex) - `bindMutable` \to -> - applyAndPublishConstraint programWords mutable operation from to + (request, frozen) <- + runUnmeasuredTransaction CdtBuildError LocalTransaction triangulation 2 $ \mutable operation -> do + programWords <- newGrowableWord32 256 + asConstraintStep (placeConstraintEndpoint mutable operation Nothing fromPoint fromVertex) + `bindMutable` \from -> + asConstraintStep (placeConstraintEndpoint mutable operation Nothing toPoint toVertex) + `bindMutable` \to -> + recoverConstraintRequest programWords mutable operation from to + pure (publishConstraintResult frozen request) + -- | The common singleton case already owns both sites. Resolve them before --- opening topology, then retain the original payload and counter semantics in --- the transaction. The corridor worker is unchanged; only two redundant point +-- opening topology, then retain the original payload semantics in the +-- transaction. The corridor worker is unchanged; only two redundant point -- locations and two unused vertex-capacity reservations disappear. applyConstraintToExistingEndpoints :: Triangulation 'Constrained vertex directed undirected face @@ -111,55 +101,42 @@ -> vertex -> Either (CdtError) (ConstraintResult vertex directed undirected face) applyConstraintToExistingEndpoints triangulation from@(VertexId rawFrom) fromPayload to@(VertexId rawTo) toPayload = - runST $ do - mutable <- thawTriangulation (Dcel.numVertices triangulation) triangulation - operation <- newOperationState (halfEdgeCapacity mutable) - programWords <- newGrowableWord32 256 - addCounter operation CounterInputPoints 2 - addCounter operation CounterExistingPoints 2 - addCounter operation CounterDuplicatePoints 2 - writeVertexData mutable (fromIntegral rawFrom) fromPayload - writeVertexData mutable (fromIntegral rawTo) toPayload - applyAndPublishConstraint programWords mutable operation from to + do + (request, frozen) <- + runUnmeasuredTransaction CdtBuildError LocalTransaction triangulation 0 $ \mutable operation -> do + programWords <- newGrowableWord32 256 + writeVertexData mutable (fromIntegral rawFrom) fromPayload + writeVertexData mutable (fromIntegral rawTo) toPayload + recoverConstraintRequest programWords mutable operation from to + pure (publishConstraintResult frozen request) -applyAndPublishConstraint +recoverConstraintRequest :: GrowableWord32 s -> MutableDcel s vertex directed undirected face -> OperationState s -> VertexId -> VertexId - -> ST s (Either (CdtError) (ConstraintResult vertex directed undirected face)) -applyAndPublishConstraint programWords mutable operation from to = + -> ST s (Either CdtError ConstraintRequestAccumulator) +recoverConstraintRequest programWords mutable operation from to = applyMutableConstraint programWords mutable operation from to `bindMutable` \applied -> case applied of MutableConstraintRejected blocking -> pure (Left (ConstraintIntersection blocking)) - MutableConstraintAccepted request -> - publishConstraintResult - mutable - (accumulatedRequestPath request) - (accumulatedRequestAddedEdges request) -{-# INLINE applyAndPublishConstraint #-} + MutableConstraintAccepted request -> pure (Right request) +{-# INLINE recoverConstraintRequest #-} --- | Close the transaction on an accepted request. The accumulated path runs --- newest-first, so it is reversed exactly once, here. +-- | Attach one accepted local result to the mesh published by the transaction. publishConstraintResult - :: MutableDcel s vertex directed undirected face - -> [DirectedEdgeId] - -> Int - -> ST s (Either (CdtError) (ConstraintResult vertex directed undirected face)) -publishConstraintResult mutable reversedPath added = do - frozenOutcome <- freezeTriangulation mutable - pure $ case frozenOutcome of - Left obstruction -> Left (CdtBuildError obstruction) - Right frozen -> - Right - ConstraintResult - { constraintTriangulation = frozen - , constraintPath = V.fromList (reverse reversedPath) - , constraintAddedEdges = added - } + :: Triangulation 'Constrained vertex directed undirected face + -> ConstraintRequestAccumulator + -> ConstraintResult vertex directed undirected face +publishConstraintResult frozen request = + ConstraintRecoveryResult + { constraintRecoveryTriangulation = frozen + , constraintRecoveryPathReceipt = V.fromList (reverse (accumulatedRequestPath request)) + , constraintRecoveryAddedEdges = accumulatedRequestAddedEdges request + } -- | Insert a polyline's vertices and recover each adjacent segment as a -- constraint, optionally closing the final segment back to the first. @@ -199,7 +176,7 @@ -> V.Vector vertex -> Either (CdtError) (Triangulation 'Constrained vertex directed undirected face, V.Vector VertexId) insertPolylineVertices triangulation points = do - result <- mapLeft CdtBuildError (insertMany triangulation points) + result <- first CdtBuildError (insertMany triangulation points) let !mapping = buildInputVertices result pure (buildTriangulation result, V.generate (sizeofPrimArray mapping) (VertexId . indexPrimArray mapping)) @@ -214,11 +191,11 @@ -- An edge carrying no constraint has nothing to retire, and answering that -- without thawing is the difference between O(1) and a republished mesh. | not (Dcel.isConstraintEdge triangulation edge) = Right triangulation - | otherwise = runST $ do - mutable <- thawTriangulation (Dcel.numVertices triangulation) triangulation - operation <- newOperationState (halfEdgeCapacity mutable) - retireConstraintEdge mutable operation edge `bindMutable` \() -> - fmap (mapLeft CdtBuildError) (freezeTriangulation mutable) + | otherwise = do + (_, frozen) <- + runUnmeasuredTransaction CdtBuildError LocalTransaction triangulation 0 $ \mutable operation -> + retireConstraintEdge mutable operation edge + pure frozen where edgeCount = Dcel.numUndirectedEdges triangulation diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Split.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Split.hs --- a/src-build/Moonlight/Triangulation/Internal/Cdt/Split.hs +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Split.hs @@ -1,39 +1,24 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | The splitting program: corridors that divide every constraint they cross, -- driven across as few sealed transactions as the vertex reservation allows. module Moonlight.Triangulation.Internal.Cdt.Split - ( SplitChunkShape (..) - , SplitReceipt (..) - , SplitChunkOutcome (..) - , SplitRequest (..) - , SplitCursor (..) - , SplitStep (..) - , addConstraintAndSplit + ( addConstraintAndSplit , addConstraintsAndSplit - , splitCensus - , driveConstraintSplits - , runSplitChunk - , splitConstraintCorridor - , mutableEdgeWasSplit - , mutableConstraintBetween - , repairRoundedSplit - , lineIntersection ) where -import Control.Monad.ST (ST, runST) +import Control.Monad.ST (ST) import Data.Bits (xor) import qualified Data.List as List import qualified Data.Vector as V import qualified Moonlight.Triangulation.Dcel as Dcel import Moonlight.Triangulation.Handles.HandleDefs -import Moonlight.Triangulation.Internal.Capacity (ensureCapacity) import Moonlight.Triangulation.Internal.Cdt.Combinators ( asConstraintStep , bindMutable , directedInt - , mapLeft , vertexInt ) import Moonlight.Triangulation.Internal.Cdt.Corridor @@ -57,11 +42,12 @@ , newGrowableWord32 ) import Moonlight.Triangulation.Internal.Mutable -import Moonlight.Triangulation.Internal.OperationState - ( OperationState - , newOperationState +import Moonlight.Triangulation.Internal.OperationState (OperationState) +import Moonlight.Triangulation.Internal.Paged + ( TransactionShape (DenseTransaction, LocalTransaction) ) import Moonlight.Triangulation.Internal.Representation +import Moonlight.Triangulation.Internal.Transaction (runUnmeasuredTransaction) import Moonlight.Triangulation.Internal.Types import Moonlight.Triangulation.Math @@ -95,22 +81,12 @@ = SplitSettled !SplitCursor | SplitSuspended !SplitCursor --- | The singleton opens corridor-local copy-on-write pages; the batch pays one --- dense copy up front and writes flat. -data SplitChunkShape = SparseSplitChunk | DenseSplitChunk - -- | What one settled request leaves behind. data SplitReceipt = SplitReceipt { splitReceiptPath :: !(V.Vector DirectedEdgeId) , splitReceiptAdded :: {-# UNPACK #-} !Int } -data SplitChunkOutcome vertex directed undirected face = SplitChunkOutcome - { splitChunkTriangulation :: !(Triangulation 'Constrained vertex directed undirected face) - , splitChunkReceipts :: ![SplitReceipt] - , splitChunkSuspended :: !(Maybe SplitCursor) - } - -- | Glue the requested segment, dividing every constraint it crosses at the -- crossing point rather than refusing it. One transaction carries the whole -- corridor: a singleton is a batch of one under the shared driver. @@ -123,19 +99,19 @@ addConstraintAndSplit makeVertex triangulation from to = do validateEndpoints triangulation from to if from == to - then pure (ConstraintResult triangulation V.empty 0) + then pure (ConstraintRecoveryResult triangulation V.empty 0) else do (published, receipts) <- - driveConstraintSplits SparseSplitChunk makeVertex triangulation (V.singleton (from, to)) + driveConstraintSplits LocalTransaction makeVertex triangulation (V.singleton (from, to)) pure ( case receipts V.!? 0 of Just receipt -> - ConstraintResult - { constraintTriangulation = published - , constraintPath = splitReceiptPath receipt - , constraintAddedEdges = splitReceiptAdded receipt + ConstraintRecoveryResult + { constraintRecoveryTriangulation = published + , constraintRecoveryPathReceipt = splitReceiptPath receipt + , constraintRecoveryAddedEdges = splitReceiptAdded receipt } - Nothing -> ConstraintResult published V.empty 0 + Nothing -> ConstraintRecoveryResult published V.empty 0 ) -- | Divide every requested segment inside as few transactions as the vertex @@ -151,12 +127,12 @@ -> V.Vector (VertexId, VertexId) -> Either (CdtError) (ConstraintSplitBatchResult vertex directed undirected face) addConstraintsAndSplit makeVertex triangulation requests = do - (published, receipts) <- driveConstraintSplits DenseSplitChunk makeVertex triangulation requests + (published, receipts) <- driveConstraintSplits DenseTransaction makeVertex triangulation requests pure - ConstraintSplitBatchResult - { splitBatchTriangulation = published - , splitBatchPaths = V.map splitReceiptPath receipts - , splitBatchAddedEdges = V.sum (V.map splitReceiptAdded receipts) + ConstraintRecoveryResult + { constraintRecoveryTriangulation = published + , constraintRecoveryPathReceipt = V.map splitReceiptPath receipts + , constraintRecoveryAddedEdges = V.sum (V.map splitReceiptAdded receipts) } -- | The obstruction census for one request against a published mesh: how many @@ -191,7 +167,8 @@ -- that census ran against the very mesh the chunk thawed and is exact before -- any in-session rewrite. Termination follows. driveConstraintSplits - :: SplitChunkShape + :: forall vertex directed undirected face. + TransactionShape -> (Point -> vertex) -> Triangulation 'Constrained vertex directed undirected face -> V.Vector (VertexId, VertexId) @@ -204,6 +181,16 @@ V.mapM_ (uncurry (validateEndpoints base)) requests advance base 0 [] Nothing where + advance + :: Triangulation 'Constrained vertex directed undirected face + -> Int + -> [SplitReceipt] + -> Maybe SplitCursor + -> Either + CdtError + ( Triangulation 'Constrained vertex directed undirected face + , V.Vector SplitReceipt + ) advance triangulation start settled resumed | start >= V.length requests = Right (triangulation, V.fromList (reverse settled)) @@ -222,24 +209,32 @@ | firstRound = V.replicate (V.length remaining) (1, Nothing) | otherwise = V.map (splitCensus triangulation) remaining !reservedSites = V.sum (V.map fst censuses) - !capacity = Dcel.numVertices triangulation + 2 * reservedSites + 8 + !additionalCapacity = 2 * reservedSites + 8 -- The walk budget bounds divisions per request; constraints born -- inside the chunk are covered by the reservation term. !budget = 2 * (Dcel.numConstraints triangulation + 2 * reservedSites + V.length remaining) + Dcel.numUndirectedEdges triangulation + 8 - mapLeft CdtBuildError (ensureCapacity capacity) - outcome <- runST $ do - mutable <- case shape of - SparseSplitChunk -> thawTriangulation capacity triangulation - DenseSplitChunk -> thawTriangulationDense capacity triangulation - operation <- newOperationState (halfEdgeCapacity mutable) - programWords <- newGrowableWord32 32 - runSplitChunk makeVertex mutable operation programWords remaining censuses capacity budget resumed - case outcome of - SplitChunkOutcome published receipts suspended -> - advance published (start + length receipts) (receipts ++ settled) suspended + ((receipts, suspended), published) <- + runUnmeasuredTransaction + CdtBuildError + shape + triangulation + additionalCapacity + $ \mutable operation -> do + programWords <- newGrowableWord32 32 + runSplitChunk + makeVertex + mutable + operation + programWords + remaining + censuses + (pointCapacity mutable) + budget + resumed + advance published (start + length receipts) (receipts ++ settled) suspended -- | One sealed transaction over a prefix of the remaining requests. Receipts -- run newest-first; a suspension carries no receipt, so the settled count is @@ -254,12 +249,12 @@ -> Int -> Int -> Maybe SplitCursor - -> ST s (Either (CdtError) (SplitChunkOutcome vertex directed undirected face)) + -> ST s (Either CdtError ([SplitReceipt], Maybe SplitCursor)) runSplitChunk makeVertex mutable operation programWords requests censuses capacity budget resumed = go 0 [] resumed where go offset receipts pending - | offset >= V.length requests = seal receipts Nothing + | offset >= V.length requests = pure (Right (receipts, Nothing)) | otherwise = let (from, to) = requests V.! offset in case pending of @@ -285,19 +280,13 @@ SplitSettled settledCursor -> go (offset + 1) (receiptOf settledCursor : receipts) Nothing SplitSuspended suspendedCursor -> - seal receipts (Just suspendedCursor) + pure (Right (receipts, Just suspendedCursor)) receiptOf cursor = SplitReceipt { splitReceiptPath = V.fromList (reverse (splitCursorPath cursor)) , splitReceiptAdded = splitCursorAdded cursor } - - seal receipts suspended = do - frozenOutcome <- freezeTriangulation mutable - pure $ case frozenOutcome of - Left obstruction -> Left (CdtBuildError obstruction) - Right frozen -> Right (SplitChunkOutcome frozen receipts suspended) splitConstraintCorridor :: SplitRequest vertex diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Types.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Types.hs --- a/src-build/Moonlight/Triangulation/Internal/Cdt/Types.hs +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Types.hs @@ -16,12 +16,13 @@ , ConstrainedSeamConstraintEvidence (..) , ConstrainedSeamResult (..) , CorridorObstruction (..) - , ConstraintResult (..) + , ConstraintRecoveryResult (..) + , ConstraintResult , ConstraintOutcome (..) , ConstraintBatchStats (..) , ConstraintBatchResult (..) , ConstrainedExtensionResult (..) - , ConstraintSplitBatchResult (..) + , ConstraintSplitBatchResult , ConstraintBatchAccumulator (..) , ConstraintRequestAccumulator (..) , ConstraintWorkspace (..) @@ -37,8 +38,6 @@ import Control.DeepSeq (NFData) import Data.List.NonEmpty (NonEmpty) import qualified Data.Vector as V -import Data.Primitive.PrimArray (PrimArray) -import Data.Word (Word32) import Moonlight.Triangulation.Handles.HandleDefs ( DirectedEdgeId , FaceId @@ -46,7 +45,7 @@ , VertexId ) import Moonlight.Triangulation.Internal.Growable (GrowableWord32) -import Moonlight.Triangulation.Internal.Representation (Triangulation) +import Moonlight.Triangulation.Internal.Representation (BuildResult, Triangulation) import Moonlight.Triangulation.Internal.Types import Moonlight.Triangulation.IntersectionIterator (Intersection) import GHC.Generics (Generic) @@ -216,25 +215,31 @@ deriving stock (Eq, Show, Generic) deriving anyclass (NFData) --- | Atomic result of admitting one constraint segment. -data ConstraintResult vertex directed undirected face = ConstraintResult - { constraintTriangulation :: !(Triangulation 'Constrained vertex directed undirected face) +-- | One constrained publication and its path receipt. The path carrier names +-- whether the caller requested one recovered path or an ordered family; the +-- mesh and edge count have one representation in either case. +data ConstraintRecoveryResult pathReceipt vertex directed undirected face = ConstraintRecoveryResult + { constraintRecoveryTriangulation :: !(Triangulation 'Constrained vertex directed undirected face) -- ^ Published constrained triangulation. - , constraintPath :: !(V.Vector DirectedEdgeId) - -- ^ Directed-edge path representing the segment at publication time. - , constraintAddedEdges :: {-# UNPACK #-} !Int - -- ^ Edges created while recovering the path. + , constraintRecoveryPathReceipt :: !pathReceipt + -- ^ Recovered path evidence at the operation's requested multiplicity. + , constraintRecoveryAddedEdges :: {-# UNPACK #-} !Int + -- ^ Edges created while recovering the path evidence. } deriving stock (Generic) deriving anyclass (NFData) deriving stock instance - (Eq vertex, Eq directed, Eq undirected, Eq face) - => Eq (ConstraintResult vertex directed undirected face) + (Eq pathReceipt, Eq vertex, Eq directed, Eq undirected, Eq face) + => Eq (ConstraintRecoveryResult pathReceipt vertex directed undirected face) deriving stock instance - (Show vertex, Show directed, Show undirected, Show face) - => Show (ConstraintResult vertex directed undirected face) + (Show pathReceipt, Show vertex, Show directed, Show undirected, Show face) + => Show (ConstraintRecoveryResult pathReceipt vertex directed undirected face) +-- | Atomic result of admitting one constraint segment. +type ConstraintResult vertex directed undirected face = + ConstraintRecoveryResult (V.Vector DirectedEdgeId) vertex directed undirected face + -- | Per-request outcome in a constraint batch. data ConstraintOutcome = ConstraintAccepted @@ -288,12 +293,8 @@ -- interpreted. A later refinement is deliberately a separate operation over -- this immutable result, not a hidden continuation of this transaction. data ConstrainedExtensionResult vertex directed undirected face = ConstrainedExtensionResult - { constrainedExtensionTriangulation :: !(Triangulation 'Constrained vertex directed undirected face) - -- ^ Published extension. - , constrainedExtensionConstraintOutcomes :: !(V.Vector ConstraintOutcome) - -- ^ Outcomes for incoming constraints in request order. - , constrainedExtensionConstraintStats :: !ConstraintBatchStats - -- ^ Constraint work performed by the extension. + { constrainedExtensionConstraintBatch :: {-# UNPACK #-} !(ConstraintBatchResult vertex directed undirected face) + -- ^ Published extension and incoming-constraint receipts. , constrainedExtensionBuildStats :: !BuildStats -- ^ Topology work performed by the extension. } @@ -311,23 +312,8 @@ -- per-request receipts in traversal order; a later request may have rewritten -- topology an earlier path names, which is the same as-traversed reading the -- singleton path already carries. -data ConstraintSplitBatchResult vertex directed undirected face = ConstraintSplitBatchResult - { splitBatchTriangulation :: !(Triangulation 'Constrained vertex directed undirected face) - -- ^ Published constrained triangulation. - , splitBatchPaths :: !(V.Vector (V.Vector DirectedEdgeId)) - -- ^ Recovered paths in request order. - , splitBatchAddedEdges :: {-# UNPACK #-} !Int - -- ^ Edges created across all requested divisions. - } - deriving stock (Generic) - deriving anyclass (NFData) - -deriving stock instance - (Eq vertex, Eq directed, Eq undirected, Eq face) - => Eq (ConstraintSplitBatchResult vertex directed undirected face) -deriving stock instance - (Show vertex, Show directed, Show undirected, Show face) - => Show (ConstraintSplitBatchResult vertex directed undirected face) +type ConstraintSplitBatchResult vertex directed undirected face = + ConstraintRecoveryResult (V.Vector (V.Vector DirectedEdgeId)) vertex directed undirected face data ConstraintBatchAccumulator = ConstraintBatchAccumulator { accumulatedConstraintOutcomes :: ![ConstraintOutcome] @@ -386,21 +372,10 @@ -- | Result of maximal constrained construction, including rejected requests. data CdtBuildResult vertex directed undirected face = CdtBuildResult - { cdtBuildTriangulation :: !(Triangulation 'Constrained vertex directed undirected face) - -- ^ Published constrained triangulation. - , cdtBuildInputVertices :: !(PrimArray Word32) - -- ^ Input-to-vertex handle projection. - , cdtBuildStats :: !BuildStats - -- ^ Topology work performed by construction. + { cdtAcceptedBuild :: {-# UNPACK #-} !(BuildResult 'Constrained vertex directed undirected face) + -- ^ Canonical build result containing every admitted constraint. , cdtRejectedConstraints :: !(V.Vector (Int, Int)) -- ^ Input-index pairs that could not be admitted. } deriving stock (Generic) deriving anyclass (NFData) - -deriving stock instance - (Eq vertex, Eq directed, Eq undirected, Eq face) - => Eq (CdtBuildResult vertex directed undirected face) -deriving stock instance - (Show vertex, Show directed, Show undirected, Show face) - => Show (CdtBuildResult vertex directed undirected face) diff --git a/src-build/Moonlight/Triangulation/Internal/Cdt/Union.hs b/src-build/Moonlight/Triangulation/Internal/Cdt/Union.hs --- a/src-build/Moonlight/Triangulation/Internal/Cdt/Union.hs +++ b/src-build/Moonlight/Triangulation/Internal/Cdt/Union.hs @@ -21,6 +21,7 @@ import Control.Monad (foldM) import Control.Monad.ST (ST) +import qualified Data.Bifunctor as Bifunctor import Data.Either (isRight) import Data.List (sort) import qualified Data.List.NonEmpty as NonEmpty @@ -33,11 +34,12 @@ import Moonlight.Triangulation.Internal.Canonical (canonicalize) import Moonlight.Triangulation.Insertion (insertPointCombining) import Moonlight.Triangulation.Internal.Cdt.Batch - ( interpretConstraintRequests + ( finalizeConstraintBatch + , interpretConstraintRequests , recoverConstraints ) import Moonlight.Triangulation.Internal.Cdt.Build (fromDelaunay) -import Moonlight.Triangulation.Internal.Cdt.Combinators (foldWhileM, mapLeft) +import Moonlight.Triangulation.Internal.Cdt.Combinators (foldWhileM) import Moonlight.Triangulation.Internal.Cdt.Query (constraintEdges) import Moonlight.Triangulation.Internal.Cdt.Types import Moonlight.Triangulation.Internal.Join.Rebuild (rebuildCanonicalSiteSet) @@ -102,12 +104,12 @@ Just witnesses -> Left (ConstraintUnionConflicts witnesses) Nothing -> do unconstrained <- - mapLeft + Bifunctor.first (ConstraintUnionConstructionFailed . CdtBuildError) (rebuildCanonicalSiteSet unionSites) requests <- traverse (segmentRequest unconstrained) (V.toList segments) recovered <- - mapLeft ConstraintUnionConstructionFailed + Bifunctor.first ConstraintUnionConstructionFailed (recoverConstraints (fromDelaunay unconstrained) (V.fromList requests)) case firstRejected (constraintBatchOutcomes recovered) of Just blocking -> @@ -116,7 +118,7 @@ (ConstraintIntersection blocking) ) Nothing -> - mapLeft + Bifunctor.first (ConstraintUnionConstructionFailed . CdtBuildError) (canonicalize (constraintBatchTriangulation recovered)) where @@ -161,7 +163,7 @@ joinSeparatedConstrained left right = do seamPlan <- maybe (Left ConstraintUnionNotSeparated) Right (planSeam left right) seamExecution <- - mapLeft + Bifunctor.first (ConstraintUnionConstructionFailed . CdtBuildError) (executeConstrainedSeam seamPlan left right) let copied = seamExecutionTriangulation seamExecution @@ -172,7 +174,7 @@ V.filter (`Set.notMember` copiedSegments) (leftSegments V.++ rightSegments) requests <- traverse (segmentRequest copied) (V.toList missingSegments) recovered <- - mapLeft ConstraintUnionConstructionFailed + Bifunctor.first ConstraintUnionConstructionFailed (recoverConstraints copied (V.fromList requests)) case firstRejected (constraintBatchOutcomes recovered) of Just blocking -> @@ -182,7 +184,7 @@ ) Nothing -> do published <- - mapLeft + Bifunctor.first (ConstraintUnionConstructionFailed . CdtBuildError) (canonicalize (constraintBatchTriangulation recovered)) targetFaces <- targetFaceIndex published @@ -368,9 +370,7 @@ (insertAndRecoverExtension combine extensionSites extensionSegments) pure ConstrainedExtensionResult - { constrainedExtensionTriangulation = extended - , constrainedExtensionConstraintOutcomes = accumulatorOutcomes completed - , constrainedExtensionConstraintStats = accumulatedConstraintStats completed + { constrainedExtensionConstraintBatch = finalizeConstraintBatch extended completed , constrainedExtensionBuildStats = buildStats } where @@ -408,7 +408,7 @@ Right requests -> do interpreted <- fmap - (mapLeft ConstraintUnionConstructionFailed) + (Bifunctor.first ConstraintUnionConstructionFailed) (interpretConstraintRequests (V.fromList requests) mutable operation) case interpreted of Left obstruction -> pure (Left obstruction) @@ -447,7 +447,7 @@ insertOne rejected@(Left _) _ = pure rejected insertOne (Right accumulated) (point, annotation) = fmap - ( mapLeft (ConstraintUnionConstructionFailed . CdtBuildError) + ( Bifunctor.first (ConstraintUnionConstructionFailed . CdtBuildError) . fmap (\(vertex, _) -> (point, VertexId (fromIntegral vertex)) : accumulated) ) diff --git a/src-build/Moonlight/Triangulation/Internal/CircleSweep.hs b/src-build/Moonlight/Triangulation/Internal/CircleSweep.hs --- a/src-build/Moonlight/Triangulation/Internal/CircleSweep.hs +++ b/src-build/Moonlight/Triangulation/Internal/CircleSweep.hs @@ -18,7 +18,7 @@ import Data.Word (Word32) import Moonlight.Triangulation.Handles.HandleDefs (DirectedEdgeId (..)) import Moonlight.Triangulation.Insertion (insertExistingVertex) -import Moonlight.Triangulation.Internal.DcelOperations +import Moonlight.Triangulation.Internal.DcelOperations.Hull ( ReservedSweepCells , SweepCellCursor , SweepInsertion (..) @@ -447,17 +447,16 @@ -- | Whether an outer edge's key orders at or before the stated query key, -- settled field by field without materializing either key. -edgeAtMost +edgeAtMostAtAngle :: DenseMutableDcel s vertex directed undirected face - -> Hull s -> Int -> Double -> Double -> Double + -> Double -> Int -> ST s Bool -edgeAtMost dense hull edge queryAngle queryX queryY tie = do - angle <- readAngle hull edge +edgeAtMostAtAngle dense edge angle queryAngle queryX queryY tie = case compare angle queryAngle of LT -> pure True GT -> pure False @@ -473,6 +472,7 @@ LT -> pure True GT -> pure False EQ -> pure (edge <= tie) +{-# INLINE edgeAtMostAtAngle #-} -- | Reconcile the derived angular index once after the local topology section -- has glued. Replacing one outer edge by two adds one active edge; every closed @@ -516,22 +516,21 @@ else adjustFromBoundary bucket (fromIntegral raw) where adjustFromBoundary !bucket !initial = do - initialAtMost <- cyclicAtMost bucket initial + initialAngle <- readAngle hull initial + initialAtMost <- cyclicAtMost bucket initial initialAngle if initialAtMost - then advance active initial + then advance active initial initialAngle else retreat active initial where - cyclicAtMost boundaryBucket edge = do - angle <- readAngle hull edge + cyclicAtMost boundaryBucket edge angle = if boundaryBucket == 0 && angle > queryAngle then pure True - else edgeAtMost dense hull edge queryAngle queryX queryY maxBound + else edgeAtMostAtAngle dense edge angle queryAngle queryX queryY maxBound - advance !remaining !edge + advance !remaining !edge !edgeAngle | remaining <= 0 = pure initial | otherwise = do following <- denseReadNext dense edge - edgeAngle <- readAngle hull edge followingAngle <- readAngle hull following -- Only the bucket-zero anchor may precede the query by crossing the -- angular seam. Once the walk leaves that anchor, ordinary key order @@ -540,18 +539,19 @@ -- entire ring. let crossesSeam = followingAngle < edgeAngle seamPermitted = bucket == 0 && edgeAngle > queryAngle - followingAtMost <- edgeAtMost dense hull following queryAngle queryX queryY maxBound + followingAtMost <- edgeAtMostAtAngle dense following followingAngle queryAngle queryX queryY maxBound if (not crossesSeam || seamPermitted) && followingAtMost - then advance (remaining - 1) following + then advance (remaining - 1) following followingAngle else pure edge retreat !remaining !edge | remaining <= 0 = pure initial | otherwise = do previous <- denseReadPrevious dense edge - previousAtMost <- cyclicAtMost bucket previous + previousAngle <- readAngle hull previous + previousAtMost <- cyclicAtMost bucket previous previousAngle if previousAtMost - then advance remaining previous + then advance remaining previous previousAngle else retreat (remaining - 1) previous insertDeferred @@ -677,17 +677,15 @@ fromY <- denseReadPointY dense fromVertex middleX <- denseReadPointX dense middleVertex middleY <- denseReadPointY dense middleVertex - if orient2dWide fromX fromY middleX middleY insertedX insertedY /= GT + middleAngle <- readAngle hull second + -- Same-ray/acute compatibility rejects most local sections. Settle that + -- cheap obstruction before paying for the exact orientation predicate; the + -- conjunction is unchanged, only its evaluation order is less profligate. + if + middleAngle /= insertedAngle + && not (acuteAtMiddle fromX fromY middleX middleY insertedX insertedY) then pure False - else do - -- The second edge begins at the middle vertex and stands on the outer - -- cycle, so its cached key already is that vertex's pseudo-angle; - -- same-ray is a slot read rather than a second angle. - middleAngle <- readAngle hull second - pure - ( middleAngle == insertedAngle - || acuteAtMiddle fromX fromY middleX middleY insertedX insertedY - ) + else pure (orient2dCoordinates fromX fromY middleX middleY insertedX insertedY == GT) {-# INLINE shouldCloseLeftTurn #-} -- | The symmetric right-hand test, where the inserted point is the first @@ -709,23 +707,15 @@ middleY <- denseReadPointY dense middleVertex targetX <- denseReadPointX dense targetVertex targetY <- denseReadPointY dense targetVertex - if orient2dWide insertedX insertedY middleX middleY targetX targetY /= GT + middleAngle <- readAngle hull second + -- Symmetric to the left-hand descent above: compatibility first, exact + -- orientation only for sections that can actually glue. + if + middleAngle /= insertedAngle + && not (acuteAtMiddle insertedX insertedY middleX middleY targetX targetY) then pure False - else do - middleAngle <- readAngle hull second - pure - ( middleAngle == insertedAngle - || acuteAtMiddle insertedX insertedY middleX middleY targetX targetY - ) + else pure (orient2dCoordinates insertedX insertedY middleX middleY targetX targetY == GT) {-# INLINE shouldCloseRightTurn #-} - --- The deferred turn test deliberately runs the widened Binary64 predicate --- rather than the exact binary64 one; only the terminal Graham pass owns exact --- convexity. This is the class's Double instance called by name, which is --- what the boxed 'orient2d' on widened points resolved to. -orient2dWide :: Double -> Double -> Double -> Double -> Double -> Double -> Ordering -orient2dWide = orient2dCoordinates -{-# INLINE orient2dWide #-} -- Spade's deferred-convexity rule is local: close the turn when the angle at -- the shared hull vertex is strictly below 90 degrees. Requiring the entire diff --git a/src-build/Moonlight/Triangulation/Internal/Excision.hs b/src-build/Moonlight/Triangulation/Internal/Excision.hs --- a/src-build/Moonlight/Triangulation/Internal/Excision.hs +++ b/src-build/Moonlight/Triangulation/Internal/Excision.hs @@ -11,7 +11,11 @@ import Data.Bits (xor) import Data.Foldable (traverse_) import qualified Data.IntSet as IntSet -import Moonlight.Triangulation.Internal.DcelOperations (flipEdge, legalizeCavityFanScratch, legalizeEdges) +import Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite (flipEdge) +import Moonlight.Triangulation.Internal.DcelOperations.Legalize + ( legalizeCavityFanScratch + , legalizeEdges + ) import Moonlight.Triangulation.Handles.HandleDefs import Moonlight.Triangulation.Internal.Mutable import Moonlight.Triangulation.Internal.OperationState diff --git a/src-build/Moonlight/Triangulation/Internal/Join/Seam.hs b/src-build/Moonlight/Triangulation/Internal/Join/Seam.hs --- a/src-build/Moonlight/Triangulation/Internal/Join/Seam.hs +++ b/src-build/Moonlight/Triangulation/Internal/Join/Seam.hs @@ -37,7 +37,8 @@ , UndirectedEdgeId (..) , VertexId (..) ) -import Moonlight.Triangulation.Internal.DcelOperations (closeOuterTurn, legalizeEdges) +import Moonlight.Triangulation.Internal.DcelOperations.Hull (closeOuterTurn) +import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeEdges) import Moonlight.Triangulation.Internal.Cdt.Query (constraintEdges) import Moonlight.Triangulation.Internal.Mutable import Moonlight.Triangulation.Internal.OperationState @@ -334,7 +335,7 @@ BuildError (Triangulation outputMode vertex () () (), BuildStats) mergeSeparated constraintSections left right (SeamTangents lowerLeft lowerRight upperLeft upperRight) = runST $ do - mutable <- newMutableDcel unitElementDefaults (generalDcelCapacity totalVertices) + mutable <- newMutableDcel unitElementDefaults (planarDcelCapacity totalVertices) pointCapacityOutcome <- ensurePointCapacity mutable totalVertices cellCapacityOutcome <- ensureCellCapacity diff --git a/src-build/Moonlight/Triangulation/Internal/Location.hs b/src-build/Moonlight/Triangulation/Internal/Location.hs --- a/src-build/Moonlight/Triangulation/Internal/Location.hs +++ b/src-build/Moonlight/Triangulation/Internal/Location.hs @@ -9,8 +9,9 @@ ) where import Control.Monad.ST (ST) -import Data.Bits (xor, (.&.)) +import Data.Bits ((.&.)) import Data.STRef (readSTRef, writeSTRef) +import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex) import Moonlight.Triangulation.Internal.FaceProbe import Moonlight.Triangulation.Internal.Mutable import Moonlight.Triangulation.Internal.OperationState @@ -30,10 +31,6 @@ | MutableOutsideHull {-# UNPACK #-} !Int deriving stock (Eq, Ord, Show) -reverseIndex :: Int -> Int -reverseIndex edge = edge `xor` 1 -{-# INLINE reverseIndex #-} - locateMutable :: MutableDcel s vertex directed undirected face -> OperationState s @@ -316,5 +313,4 @@ else do edgeNext <- readNext mutable edge if edgeNext == start then pure (maybe edge id fallback') else go (remaining - 1) start edgeNext fallback' - diff --git a/src-build/Moonlight/Triangulation/Internal/Minkowski/Convex.hs b/src-build/Moonlight/Triangulation/Internal/Minkowski/Convex.hs deleted file mode 100644 --- a/src-build/Moonlight/Triangulation/Internal/Minkowski/Convex.hs +++ /dev/null @@ -1,326 +0,0 @@ --- | Pure exact convex-polygon algebra: admission, linear edge-angle --- convolution, reflection, hull construction, and support-half-plane erosion. -module Moonlight.Triangulation.Internal.Minkowski.Convex - ( convexPolygon - , convexPolygonPoints - , convexPolygonRegion - , admittedConvexLoop - , structuringElement - , structuringElementPolygon - , convexMinkowskiSum - , convexMinkowskiPolygon - , convexHullPolygon - , reflectConvexPolygon - , convexPolygonCentroid - , erodeConvexBy - , addExactPoints - , subtractExactPoints - ) where - -import Control.Monad (foldM) -import Data.Bifunctor (first) -import 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 - , ExactVector (..) - , addExactVectors - , compareExactVectorAngle - , exactVectorFromPoints - , exactSegment - , exactSupportingLineIntersection - , exactOrient2d - , exactPoint - , exactPointCoordinates - , translateExactPoint - ) -import Moonlight.Triangulation.Internal.BoundaryCycle - ( cyclePairs - , cyclePairsNonEmpty - , cyclicTriples - , rotateCycleLeast - , rotateCycleLeastBy - ) -import Moonlight.Triangulation.Internal.ExactRational - ( ExactRational - , exactDivide - ) -import Moonlight.Triangulation.Internal.Minkowski.Types - ( ConvexPolygon (..) - , MinkowskiError (..) - , StructuringElement (..) - ) -import Moonlight.Triangulation.Internal.Region.Types - ( ExactLoop (..) - , PlanarRegion (..) - , PolygonComponent (..) - , RegionPointLocation (..) - ) -import Moonlight.Triangulation.Region - ( exactLoop - , exactLoopPoints - , regionPointLocation - ) - -convexPolygon - :: NonEmpty ExactPoint - -> Either MinkowskiError ConvexPolygon -convexPolygon submitted = do - loop <- first MinkowskiInvalidConvexLoop (exactLoop submitted) - let points = exactLoopPoints loop - case - [ (index, turn) - | (index, (previous, current, next)) <- - zip [0 :: Int ..] (cyclicTriples (NonEmpty.toList points)) - , let turn = exactOrient2d previous current next - , turn /= GT - ] of - (index, turn) : _ -> Left (MinkowskiNonConvexTurn index turn) - [] -> Right (ConvexPolygon loop) - -convexPolygonPoints :: ConvexPolygon -> NonEmpty ExactPoint -convexPolygonPoints (ConvexPolygon loop) = exactLoopPoints loop - -convexPolygonRegion :: ConvexPolygon -> PlanarRegion -convexPolygonRegion (ConvexPolygon loop) = - PlanarRegion [PolygonComponent loop []] - -admittedConvexLoop :: ExactLoop -> Maybe ConvexPolygon -admittedConvexLoop loop - | all ((== GT) . orderedTurn) (cyclicTriples (NonEmpty.toList (exactLoopPoints loop))) = - Just (ConvexPolygon loop) - | otherwise = Nothing - where - orderedTurn (previous, current, next) = - exactOrient2d previous current next - -structuringElement - :: ConvexPolygon - -> Either MinkowskiError StructuringElement -structuringElement polygon = - let origin = exactPoint 0 0 - location = regionPointLocation (convexPolygonRegion polygon) origin - in case location of - RegionExterior -> Left (MinkowskiOriginOutside location) - _ -> Right (StructuringElement polygon) - -structuringElementPolygon :: StructuringElement -> ConvexPolygon -structuringElementPolygon (StructuringElement polygon) = polygon - -convexMinkowskiSum - :: ConvexPolygon - -> ConvexPolygon - -> PlanarRegion -convexMinkowskiSum left right = - convexPolygonRegion (convexMinkowskiPolygon left right) - -convexMinkowskiPolygon - :: ConvexPolygon - -> ConvexPolygon - -> ConvexPolygon -convexMinkowskiPolygon left right = - let leftPoints = rotateCycleLeastBy pointSweepKey (convexPolygonPoints left) - rightPoints = rotateCycleLeastBy pointSweepKey (convexPolygonPoints right) - start = addExactPoints (NonEmpty.head leftPoints) (NonEmpty.head rightPoints) - directions = - mergeDirections - (edgeDirections leftPoints) - (edgeDirections rightPoints) - directionList = NonEmpty.toList directions - scanned = scanl translateExactPoint start directionList - resultPoints = start :| take (length directionList - 1) (drop 1 scanned) - in ConvexPolygon (ExactLoop (rotateCycleLeast resultPoints)) - -convexHullPolygon - :: NonEmpty ExactPoint - -> Either MinkowskiError ConvexPolygon -convexHullPolygon submitted = - let points = NonEmpty.toList submitted - in case convexHullPoints points of - Nothing -> Left (MinkowskiConvexHullDegenerate points) - Just hullPoints -> Right (ConvexPolygon (ExactLoop (rotateCycleLeast hullPoints))) - -reflectConvexPolygon :: ConvexPolygon -> ConvexPolygon -reflectConvexPolygon polygon = - ConvexPolygon - ( ExactLoop - ( rotateCycleLeast - (NonEmpty.reverse (fmap negateExactPoint (convexPolygonPoints polygon))) - ) - ) - -convexPolygonCentroid - :: ConvexPolygon - -> Either MinkowskiError ExactPoint -convexPolygonCentroid polygon = do - let points = convexPolygonPoints polygon - count = fromIntegral (NonEmpty.length points) - (sumX, sumY) = - List.foldl' - (\(accumulatedX, accumulatedY) point -> - let (x, y) = exactPointCoordinates point - in (accumulatedX + x, accumulatedY + y)) - (0, 0) - points - x <- first MinkowskiExactArithmetic (exactDivide sumX count) - y <- first MinkowskiExactArithmetic (exactDivide sumY count) - pure (exactPoint x y) - --- | Erode one convex polygon by another through the strongest translated --- support half-plane for each source edge. Sutherland--Hodgman descent keeps --- the construction exact; a lower-dimensional residual is represented by the --- empty polygonal region at this two-dimensional publication boundary. -erodeConvexBy - :: ConvexPolygon - -> ConvexPolygon - -> Either MinkowskiError (Maybe ConvexPolygon) -erodeConvexBy source kernel = do - let sourcePoints = convexPolygonPoints source - kernelPoints = convexPolygonPoints kernel - firstKernel = NonEmpty.head kernelPoints - initial = - map - (`subtractExactPoints` firstKernel) - (NonEmpty.toList sourcePoints) - halfPlanes = - [ strongestHalfPlane kernelPoints from to - | (from, to) <- cyclePairs sourcePoints - ] - clipped <- foldM clipPolygon initial halfPlanes - pure (ConvexPolygon . ExactLoop . rotateCycleLeast <$> convexHullPoints clipped) - -edgeDirections :: NonEmpty ExactPoint -> NonEmpty ExactVector -edgeDirections = fmap (uncurry exactVectorFromPoints) . cyclePairsNonEmpty - -mergeDirections - :: NonEmpty ExactVector - -> NonEmpty ExactVector - -> NonEmpty ExactVector -mergeDirections (left :| leftTail) (right :| rightTail) = - case compareExactVectorAngle left right of - LT -> left :| mergeRemaining leftTail (right : rightTail) - GT -> right :| mergeRemaining (left : leftTail) rightTail - EQ -> addExactVectors left right :| mergeRemaining leftTail rightTail - -mergeRemaining :: [ExactVector] -> [ExactVector] -> [ExactVector] -mergeRemaining [] right = right -mergeRemaining left [] = left -mergeRemaining left@(leftHead : leftTail) right@(rightHead : rightTail) = - case compareExactVectorAngle leftHead rightHead of - LT -> leftHead : mergeRemaining leftTail right - GT -> rightHead : mergeRemaining left rightTail - EQ -> addExactVectors leftHead rightHead : mergeRemaining leftTail rightTail - -pointSweepKey :: ExactPoint -> (ExactRational, ExactRational) -pointSweepKey point = - let (x, y) = exactPointCoordinates point - in (y, x) - -convexHullPoints :: [ExactPoint] -> Maybe (NonEmpty ExactPoint) -convexHullPoints submitted = - case Set.toAscList (Set.fromList submitted) of - firstPoint : secondPoint : thirdPoint : remaining -> - let ordered = firstPoint : secondPoint : thirdPoint : remaining - lower = dropFinal (reverse (List.foldl' hullStep [] ordered)) - upper = dropFinal (reverse (List.foldl' hullStep [] (reverse ordered))) - in case lower <> upper of - firstHullPoint : secondHullPoint : thirdHullPoint : hullTail -> - Just (firstHullPoint :| (secondHullPoint : thirdHullPoint : hullTail)) - _ -> Nothing - _ -> Nothing - -hullStep :: [ExactPoint] -> ExactPoint -> [ExactPoint] -hullStep (current : previous : remaining) candidate - | exactOrient2d previous current candidate /= GT = - hullStep (previous : remaining) candidate -hullStep hull candidate = candidate : hull - -dropFinal :: [value] -> [value] -dropFinal values = - case reverse values of - _ : remaining -> reverse remaining - [] -> [] - -strongestHalfPlane - :: NonEmpty ExactPoint - -> ExactPoint - -> ExactPoint - -> (ExactPoint, ExactPoint) -strongestHalfPlane kernelPoints from to = - let direction = exactVectorFromPoints from to - supportPoint = - case kernelPoints of - initial :| remaining -> - List.foldl' - (\selected candidate -> - if directionPointCross direction candidate - < directionPointCross direction selected - then candidate - else selected) - initial - remaining - in ( subtractExactPoints from supportPoint - , subtractExactPoints to supportPoint - ) - -directionPointCross :: ExactVector -> ExactPoint -> ExactRational -directionPointCross (ExactVector directionX directionY) point = - let (x, y) = exactPointCoordinates point - in directionX * y - directionY * x - -clipPolygon - :: [ExactPoint] - -> (ExactPoint, ExactPoint) - -> Either MinkowskiError [ExactPoint] -clipPolygon [] _ = Right [] -clipPolygon polygon halfPlane = - concat <$> traverse (clipEdge halfPlane) (cyclePairsList polygon) - -clipEdge - :: (ExactPoint, ExactPoint) - -> (ExactPoint, ExactPoint) - -> Either MinkowskiError [ExactPoint] -clipEdge (boundaryFrom, boundaryTo) (from, to) = - case (inside from, inside to) of - (True, True) -> Right [to] - (True, False) -> (: []) <$> supportingLineIntersection from to boundaryFrom boundaryTo - (False, True) -> do - crossing <- supportingLineIntersection from to boundaryFrom boundaryTo - pure [crossing, to] - (False, False) -> Right [] - where - inside point = exactOrient2d boundaryFrom boundaryTo point /= LT - -supportingLineIntersection - :: ExactPoint - -> ExactPoint - -> ExactPoint - -> ExactPoint - -> Either MinkowskiError ExactPoint -supportingLineIntersection lineFrom lineTo boundaryFrom boundaryTo = do - clippedSegment <- first MinkowskiInvalidSegment (exactSegment lineFrom lineTo) - boundarySegment <- first MinkowskiInvalidSegment (exactSegment boundaryFrom boundaryTo) - first MinkowskiLineIntersection - (exactSupportingLineIntersection clippedSegment boundarySegment) - -addExactPoints :: ExactPoint -> ExactPoint -> ExactPoint -addExactPoints left right = - let (leftX, leftY) = exactPointCoordinates left - (rightX, rightY) = exactPointCoordinates right - in exactPoint (leftX + rightX) (leftY + rightY) - -subtractExactPoints :: ExactPoint -> ExactPoint -> ExactPoint -subtractExactPoints left right = - let (leftX, leftY) = exactPointCoordinates left - (rightX, rightY) = exactPointCoordinates right - in exactPoint (leftX - rightX) (leftY - rightY) - -negateExactPoint :: ExactPoint -> ExactPoint -negateExactPoint point = - let (x, y) = exactPointCoordinates point - in exactPoint (negate x) (negate y) - -cyclePairsList :: [value] -> [(value, value)] -cyclePairsList = maybe [] cyclePairs . NonEmpty.nonEmpty diff --git a/src-build/Moonlight/Triangulation/Internal/Minkowski/Types.hs b/src-build/Moonlight/Triangulation/Internal/Minkowski/Types.hs deleted file mode 100644 --- a/src-build/Moonlight/Triangulation/Internal/Minkowski/Types.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} - --- | Closed vocabulary and invariant carriers for exact polygonal morphology. -module Moonlight.Triangulation.Internal.Minkowski.Types - ( ConvexPolygon (..) - , StructuringElement (..) - , MinkowskiOperation (..) - , MinkowskiError (..) - , MinkowskiReceipt (..) - ) where - -import Control.DeepSeq (NFData) -import GHC.Generics (Generic) -import Moonlight.Triangulation.Exact - ( ExactGeometryError - , ExactIntersectionError - , ExactPoint - ) -import Moonlight.Triangulation.Handles.HandleDefs (FaceId) -import Moonlight.Triangulation.Internal.ExactRational (ExactArithmeticError) -import Moonlight.Triangulation.Internal.Overlay.Types - ( OverlayCellId - , OverlayCellWitness - , OverlayError - ) -import Moonlight.Triangulation.Internal.Region.Types - ( ExactLoop - , RegionPublicationError - , RegionPointLocation - , RegionValidationError - ) - -newtype ConvexPolygon = ConvexPolygon ExactLoop - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - -newtype StructuringElement = StructuringElement ConvexPolygon - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - -data MinkowskiOperation - = MinkowskiAddition - | MinkowskiErosion - | MinkowskiOpening - | MinkowskiClosing - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - -data MinkowskiError - = MinkowskiInvalidConvexLoop !RegionValidationError - | MinkowskiInvalidSegment !ExactGeometryError - | MinkowskiNonConvexTurn !Int !Ordering - | MinkowskiOriginOutside !RegionPointLocation - | MinkowskiExactArithmetic !ExactArithmeticError - | MinkowskiLineIntersection !ExactIntersectionError - | MinkowskiOverlayFailed !(OverlayError Bool Bool) - | MinkowskiPublicationFailed !RegionPublicationError - | MinkowskiOverlayCellWitness !OverlayCellWitness - | MinkowskiFaceArity !FaceId !Int - | MinkowskiCandidateCellMissing !OverlayCellId - | MinkowskiInclusionAmbiguous !OverlayCellId !ExactPoint - | MinkowskiConvexHullDegenerate ![ExactPoint] - deriving stock (Eq, Show, Generic) - deriving anyclass (NFData) - -data MinkowskiReceipt = MinkowskiReceipt - { minkowskiOperation :: !MinkowskiOperation - , minkowskiInputComponents :: !Int - , minkowskiConvexPieces :: !Int - , minkowskiGeneratedPieces :: !Int - , minkowskiGeneratedConvolutionEdges :: !Int - , minkowskiOverlayPasses :: !Int - , minkowskiExactCrossings :: !Int - , minkowskiOutputCells :: !Int - , minkowskiExactCoordinateBitGrowth :: !Int - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) diff --git a/src-build/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs b/src-build/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs deleted file mode 100644 --- a/src-build/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs +++ /dev/null @@ -1,807 +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 - , exactPointFromPoint - , exactSegment - , exactSegmentEndpoints - , exactVectorFromPoints - ) -import Moonlight.Triangulation.Internal.BoundaryCycle - ( consecutivePairs - , orderedPair - , unorderedPairs - ) -import Moonlight.Triangulation.Internal.ExactRational - ( ExactRational - , exactDivide - , exactRationalIsZero - ) -import Moonlight.Triangulation.Internal.ExactSegmentEvents - ( ExactSegmentEvent (..) - , ExactSegmentEventPlan - , ExactSweepSegmentId (..) - , exactSegmentEventPlan - , exactSegmentEvents - , exactSegmentPairChecks - , exactSegmentRelationMap - , exactSegmentSplitPoints - , exactSegmentSweepMaximumHeight - ) -import Moonlight.Triangulation.Internal.Overlay.Embedding - ( DraftIncidence (..) - , DraftNeighborhood (..) - , DraftReference (..) - , DraftSegmentId (..) - , DraftSourceId (..) - , DraftVertexId (..) - , ExactArrangementDraft (..) - , LocalEmbeddingCertificate (..) - , OverlayEmbeddingObstruction (..) - , certifyLocalEmbedding - ) -import Moonlight.Triangulation.Internal.Overlay.Types -import Moonlight.Triangulation.Internal.Types (HasPosition (..), Point) -import Moonlight.Triangulation.Region - ( ExactLoop - , PlanarLayer - , PolygonComponent - , exactLoopPoints - , planarLayerOutsideLabel - , planarLayerRegions - , planarRegionComponents - , polygonHoleLoops - , polygonOuterLoop - ) - -type ExactEdgeKey = (ExactPoint, ExactPoint) - -data SourceBoundary leftLabel rightLabel - = LeftSourceBoundary - !ExactSegment - !leftLabel - !(BoundaryVertexRef 'LeftOverlayOperand) - !(BoundaryVertexRef 'LeftOverlayOperand) - !(BoundaryEdgeRef 'LeftOverlayOperand) - | RightSourceBoundary - !ExactSegment - !rightLabel - !(BoundaryVertexRef 'RightOverlayOperand) - !(BoundaryVertexRef 'RightOverlayOperand) - !(BoundaryEdgeRef 'RightOverlayOperand) - -type SourceBoundaryConstructor operand label leftLabel rightLabel = - ExactSegment - -> label - -> BoundaryVertexRef operand - -> BoundaryVertexRef operand - -> BoundaryEdgeRef operand - -> SourceBoundary leftLabel rightLabel - -data AtomicContribution leftLabel rightLabel = - AtomicContribution !(SourceBoundary leftLabel rightLabel) !Bool - -data AtomicEdge leftLabel rightLabel = AtomicEdge - { atomicEdgeSegment :: !ExactSegment - , atomicEdgeOrigin :: !OverlayEdgeOrigin - , atomicEdgeLeftTransition :: !(Maybe (leftLabel, leftLabel)) - , atomicEdgeRightTransition :: !(Maybe (rightLabel, rightLabel)) - } - -data OriginAccumulation = OriginAccumulation - { accumulatedLeftVertices :: !(Set (BoundaryVertexRef 'LeftOverlayOperand)) - , accumulatedRightVertices :: !(Set (BoundaryVertexRef 'RightOverlayOperand)) - , accumulatedLeftEdges :: !(Set (BoundaryEdgeRef 'LeftOverlayOperand)) - , accumulatedRightEdges :: !(Set (BoundaryEdgeRef 'RightOverlayOperand)) - } - -data OverlayVertexSeed = OverlayVertexSeed - { seedExactPoint :: !ExactPoint - , seedEmbeddedPoint :: !Point - , seedOrigin :: !OverlayVertexOrigin - } - deriving stock (Eq, Ord, Show, Generic) - -instance HasPosition OverlayVertexSeed where - position = seedEmbeddedPoint - -data ArrangementMetrics = ArrangementMetrics - { arrangementInputSegments :: !Int - , arrangementRelationEvents :: !Int - , arrangementExactCrossings :: !Int - , arrangementOverlapIntervals :: !Int - , arrangementEmbeddingCandidates :: !Int - , arrangementTotalRelationChecks :: !Int - , arrangementSweepMaximumHeight :: !Int - } - -data CertifiedArrangement leftLabel rightLabel = CertifiedArrangement - { certifiedAtomicEdges :: !(V.Vector (AtomicEdge leftLabel rightLabel)) - , certifiedVertexSeeds :: !(V.Vector OverlayVertexSeed) - , certifiedConstraints :: !(V.Vector (Int, Int)) - , certifiedMetrics :: !ArrangementMetrics - } - -certifyArrangement - :: (Ord leftLabel, Ord rightLabel) - => PlanarLayer leftLabel - -> PlanarLayer rightLabel - -> Either - (OverlayError leftLabel rightLabel) - (CertifiedArrangement leftLabel rightLabel) -certifyArrangement leftLayer rightLayer = do - sources <- flattenLayers leftLayer rightLayer - sourcePlan <- - first OverlaySegmentEventsInvalid - (exactSegmentEventPlan (V.map sourceExactSegment sources)) - atomicEdges <- normalizeAtomicEdges leftLayer rightLayer sources sourcePlan - let atomicVector = V.fromList atomicEdges - pointIds = exactPointIds atomicVector - origins = vertexOrigins sources atomicVector - atomicRelations = atomicEndpointRelations atomicVector - draft <- exactArrangementDraft sources sourcePlan atomicVector pointIds atomicRelations - localCertificate <- first OverlayEmbeddingRefused (certifyLocalEmbedding draft) - projectedPoints <- projectedExactPoints localCertificate - projectedSegments <- projectedAtomicSegments atomicVector pointIds projectedPoints - projectedPlan <- - first OverlaySegmentEventsInvalid - (exactSegmentEventPlan projectedSegments) - dischargeGlobalRelations atomicRelations projectedPlan - seeds <- overlayVertexSeeds pointIds origins localCertificate - constraints <- atomicConstraints pointIds atomicVector - let events = exactSegmentEvents sourcePlan - pure - CertifiedArrangement - { certifiedAtomicEdges = atomicVector - , certifiedVertexSeeds = seeds - , certifiedConstraints = constraints - , certifiedMetrics = - ArrangementMetrics - { arrangementInputSegments = V.length sources - , arrangementRelationEvents = length events - , arrangementExactCrossings = - length [() | ExactProperCrossing {} <- events] - , arrangementOverlapIntervals = - length [() | ExactCollinearOverlap {} <- events] - , arrangementEmbeddingCandidates = Map.size pointIds - , arrangementTotalRelationChecks = - exactSegmentPairChecks sourcePlan - + exactSegmentPairChecks projectedPlan - , arrangementSweepMaximumHeight = - max - (exactSegmentSweepMaximumHeight sourcePlan) - (exactSegmentSweepMaximumHeight projectedPlan) - } - } -flattenLayers - :: PlanarLayer leftLabel - -> PlanarLayer rightLabel - -> Either (OverlayError leftLabel rightLabel) (V.Vector (SourceBoundary leftLabel rightLabel)) -flattenLayers leftLayer rightLayer = do - leftSources <- flattenLayer LeftSourceBoundary leftLayer - rightSources <- flattenLayer RightSourceBoundary rightLayer - pure (V.fromList (leftSources <> rightSources)) - -flattenLayer - :: SourceBoundaryConstructor operand label leftLabel rightLabel - -> PlanarLayer label - -> Either (OverlayError leftLabel rightLabel) [SourceBoundary leftLabel rightLabel] -flattenLayer makeBoundary layer = - fmap concat - ( traverse - (\(componentIndex, (label, component)) -> - flattenComponent makeBoundary componentIndex label component) - (zip [0 ..] (labelledComponents layer)) - ) -{-# INLINE flattenLayer #-} - -labelledComponents :: PlanarLayer label -> [(label, PolygonComponent)] -labelledComponents layer = - [ (label, component) - | (label, region) <- Map.toAscList (planarLayerRegions layer) - , component <- planarRegionComponents region - ] - -flattenComponent - :: SourceBoundaryConstructor operand label leftLabel rightLabel - -> Int - -> label - -> PolygonComponent - -> Either (OverlayError leftLabel rightLabel) [SourceBoundary leftLabel rightLabel] -flattenComponent makeBoundary componentIndex label component = do - outer <- - flattenLoop - makeBoundary - componentIndex - BoundaryOuterLoop - label - (polygonOuterLoop component) - holes <- - fmap concat - ( traverse - (\(holeIndex, loop) -> - flattenLoop - makeBoundary - componentIndex - (BoundaryHoleLoop holeIndex) - label - loop) - (zip [0 ..] (polygonHoleLoops component)) - ) - pure (outer <> holes) -{-# INLINE flattenComponent #-} - -flattenLoop - :: SourceBoundaryConstructor operand label leftLabel rightLabel - -> Int - -> BoundaryLoopRef - -> label - -> ExactLoop - -> Either (OverlayError leftLabel rightLabel) [SourceBoundary leftLabel rightLabel] -flattenLoop makeBoundary componentIndex loopRef label loop = - traverse constructSource (indexedCycle (exactLoopPoints loop)) - where - constructSource (edgeIndex, fromIndex, from, toIndex, to) = do - segment <- first (sourceGeometryError from) (exactSegment from to) - pure - ( makeBoundary - segment - label - (BoundaryVertexRef componentIndex loopRef fromIndex) - (BoundaryVertexRef componentIndex loopRef toIndex) - (BoundaryEdgeRef componentIndex loopRef edgeIndex) - ) -{-# INLINE flattenLoop #-} - -sourceGeometryError - :: ExactPoint - -> ExactGeometryError - -> OverlayError leftLabel rightLabel -sourceGeometryError point _ = OverlayArrangementInvalid (OverlayRotationDegenerate point) - -indexedCycle :: NonEmpty value -> [(Int, Int, value, Int, value)] -indexedCycle (firstValue :| remaining) = - let values = firstValue : remaining - count = length values - in [ (index, index, from, (index + 1) `mod` count, to) - | (index, (from, to)) <- zip [0 ..] (zip values (remaining <> [firstValue])) - ] - -sourceExactSegment :: SourceBoundary leftLabel rightLabel -> ExactSegment -sourceExactSegment (LeftSourceBoundary segment _ _ _ _) = segment -sourceExactSegment (RightSourceBoundary segment _ _ _ _) = segment - -normalizeAtomicEdges - :: (Ord leftLabel, Ord rightLabel) - => PlanarLayer leftLabel - -> PlanarLayer rightLabel - -> V.Vector (SourceBoundary leftLabel rightLabel) - -> ExactSegmentEventPlan - -> Either (OverlayError leftLabel rightLabel) [AtomicEdge leftLabel rightLabel] -normalizeAtomicEdges leftLayer rightLayer sources plan = - fmap concat - ( traverse - (resolveAtomicContributions leftOutside rightOutside) - (Map.toAscList grouped) - ) - where - leftOutside = planarLayerOutsideLabel leftLayer - rightOutside = planarLayerOutsideLabel rightLayer - grouped = - V.ifoldl' - (\groups sourceIndex source -> - 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 DraftVertexId [0 ..]) - ) - where - collect - :: Set ExactPoint - -> AtomicEdge leftLabel rightLabel - -> Set ExactPoint - collect points edge = Set.insert (atomicEdgeFrom edge) (Set.insert (atomicEdgeTo edge) points) - -vertexOrigins - :: V.Vector (SourceBoundary leftLabel rightLabel) - -> V.Vector (AtomicEdge leftLabel rightLabel) - -> Map ExactPoint OverlayVertexOrigin -vertexOrigins sources atomicEdges = - Map.map finalizeOrigin - ( V.foldl' - addAtomicOrigin - (V.foldl' addSourceEndpoints Map.empty sources) - atomicEdges - ) - -emptyOrigin :: OriginAccumulation -emptyOrigin = OriginAccumulation Set.empty Set.empty Set.empty Set.empty - -mergeOrigin :: OriginAccumulation -> OriginAccumulation -> OriginAccumulation -mergeOrigin left right = - OriginAccumulation - { accumulatedLeftVertices = accumulatedLeftVertices left <> accumulatedLeftVertices right - , accumulatedRightVertices = accumulatedRightVertices left <> accumulatedRightVertices right - , accumulatedLeftEdges = accumulatedLeftEdges left <> accumulatedLeftEdges right - , accumulatedRightEdges = accumulatedRightEdges left <> accumulatedRightEdges right - } - -addSourceEndpoints - :: Map ExactPoint OriginAccumulation - -> SourceBoundary leftLabel rightLabel - -> Map ExactPoint OriginAccumulation -addSourceEndpoints origins source = - case source of - LeftSourceBoundary segment _ fromReference toReference _ -> - let (from, to) = exactSegmentEndpoints segment - in insertOrigin to (emptyOrigin{accumulatedLeftVertices = Set.singleton toReference}) - (insertOrigin from (emptyOrigin{accumulatedLeftVertices = Set.singleton fromReference}) origins) - RightSourceBoundary segment _ fromReference toReference _ -> - let (from, to) = exactSegmentEndpoints segment - in insertOrigin to (emptyOrigin{accumulatedRightVertices = Set.singleton toReference}) - (insertOrigin from (emptyOrigin{accumulatedRightVertices = Set.singleton fromReference}) origins) - -addAtomicOrigin - :: Map ExactPoint OriginAccumulation - -> AtomicEdge leftLabel rightLabel - -> Map ExactPoint OriginAccumulation -addAtomicOrigin origins edge = - let origin = atomicEdgeOrigin edge - accumulation = - emptyOrigin - { accumulatedLeftEdges = Set.fromList (overlayEdgeLeftSources origin) - , accumulatedRightEdges = Set.fromList (overlayEdgeRightSources origin) - } - in insertOrigin (atomicEdgeTo edge) accumulation - (insertOrigin (atomicEdgeFrom edge) accumulation origins) - -insertOrigin - :: ExactPoint - -> OriginAccumulation - -> Map ExactPoint OriginAccumulation - -> Map ExactPoint OriginAccumulation -insertOrigin = Map.insertWith mergeOrigin - -finalizeOrigin :: OriginAccumulation -> OverlayVertexOrigin -finalizeOrigin accumulated = - OverlayVertexOrigin - { overlayOriginLeftVertices = Set.toAscList (accumulatedLeftVertices accumulated) - , overlayOriginRightVertices = Set.toAscList (accumulatedRightVertices accumulated) - , overlayOriginLeftEdges = Set.toAscList (accumulatedLeftEdges accumulated) - , overlayOriginRightEdges = Set.toAscList (accumulatedRightEdges accumulated) - } - -exactArrangementDraft - :: V.Vector (SourceBoundary leftLabel rightLabel) - -> ExactSegmentEventPlan - -> V.Vector (AtomicEdge leftLabel rightLabel) - -> Map ExactPoint DraftVertexId - -> Map (ExactSweepSegmentId, ExactSweepSegmentId) SegmentRelation - -> Either (OverlayError leftLabel rightLabel) ExactArrangementDraft -exactArrangementDraft sources sourcePlan atomicEdges pointIds atomicRelations = do - draftSegmentsMap <- - Map.fromList - <$> traverse - (\(segmentIndex, edge) -> do - from <- requireDraftVertex pointIds (atomicEdgeFrom edge) - to <- requireDraftVertex pointIds (atomicEdgeTo edge) - pure (DraftSegmentId segmentIndex, (from, to))) - (V.toList (V.indexed atomicEdges)) - memberships <- - Map.fromList - <$> traverse - (\(sourceIndex, source) -> do - values <- - traverse - (\point -> do - parameter <- exactSourceParameter source point - vertex <- requireDraftVertex pointIds point - pure (parameter, vertex)) - (exactSegmentSplitPoints sourcePlan (ExactSweepSegmentId sourceIndex)) - pure (DraftSourceId sourceIndex, values)) - (V.toList (V.indexed sources)) - neighborhoods <- buildDraftNeighborhoods atomicEdges pointIds - let incidences = - [ DraftIncidence - (DraftSegmentId leftIndex) - (DraftSegmentId rightIndex) - relation - | ((ExactSweepSegmentId leftIndex, ExactSweepSegmentId rightIndex), relation) <- - Map.toAscList atomicRelations - ] - pure - ExactArrangementDraft - { draftVertices = Map.fromList [(vertexId, point) | (point, vertexId) <- Map.toAscList pointIds] - , draftSegments = draftSegmentsMap - , draftSourceMemberships = memberships - , draftIncidences = incidences - , draftNeighborhoods = neighborhoods - } - -requireDraftVertex - :: Map ExactPoint DraftVertexId - -> ExactPoint - -> Either (OverlayError leftLabel rightLabel) DraftVertexId -requireDraftVertex pointIds point = - case Map.lookup point pointIds of - Just vertex -> Right vertex - Nothing -> Left (OverlayProvenanceIncomplete (OverlayExactVertexMissing point)) - -exactSourceParameter - :: SourceBoundary leftLabel rightLabel - -> ExactPoint - -> Either (OverlayError leftLabel rightLabel) ExactRational -exactSourceParameter source point = - let (from, to) = exactSegmentEndpoints (sourceExactSegment source) - (fromX, fromY) = exactPointCoordinates from - (toX, toY) = exactPointCoordinates to - (pointX, pointY) = exactPointCoordinates point - (numerator, denominator) = - if exactRationalIsZero (toX - fromX) - then (pointY - fromY, toY - fromY) - else (pointX - fromX, toX - fromX) - in first OverlayExactArithmetic (exactDivide numerator denominator) - -buildDraftNeighborhoods - :: V.Vector (AtomicEdge leftLabel rightLabel) - -> Map ExactPoint DraftVertexId - -> Either (OverlayError leftLabel rightLabel) [DraftNeighborhood] -buildDraftNeighborhoods edges pointIds = - traverse neighborhood (Map.toAscList pointIds) - where - neighborhood (centerPoint, centerId) = do - let neighbors = Map.findWithDefault Set.empty centerPoint adjacency - orderedPoints <- - case NonEmpty.nonEmpty (sortBy (compareAround centerPoint) (Set.toList neighbors)) of - Just points -> Right points - Nothing -> Left (OverlayArrangementInvalid (OverlayRotationDegenerate centerPoint)) - orderedIds <- traverse (requireDraftVertex pointIds) orderedPoints - pure (DraftNeighborhood centerId orderedIds) - adjacency = - V.foldl' - (\graph edge -> - Map.insertWith Set.union (atomicEdgeTo edge) (Set.singleton (atomicEdgeFrom edge)) - (Map.insertWith Set.union (atomicEdgeFrom edge) (Set.singleton (atomicEdgeTo edge)) graph)) - Map.empty - edges - -compareAround :: ExactPoint -> ExactPoint -> ExactPoint -> Ordering -compareAround center left right = - case - compareExactVectorAngle - (exactVectorFromPoints center left) - (exactVectorFromPoints center right) of - EQ -> compare left right - ordering -> ordering - --- | Normalization splits every source at every exact event and coalesces --- duplicate intervals. Distinct atomics can therefore meet only at a stored --- endpoint; their entire relation section is the endpoint-incidence index. -atomicEndpointRelations - :: V.Vector (AtomicEdge leftLabel rightLabel) - -> Map (ExactSweepSegmentId, ExactSweepSegmentId) SegmentRelation -atomicEndpointRelations edges = - Map.fromList - [ ( orderedPair - (ExactSweepSegmentId leftIndex) - (ExactSweepSegmentId rightIndex) - , SegmentsShareEndpoint - ) - | incident <- Map.elems incidenceByPoint - , (leftIndex, rightIndex) <- unorderedPairs (Set.toAscList incident) - ] - where - incidenceByPoint = - V.ifoldl' - (\incidence index edge -> - Map.insertWith Set.union (atomicEdgeTo edge) (Set.singleton index) - ( Map.insertWith Set.union - (atomicEdgeFrom edge) - (Set.singleton index) - incidence - )) - Map.empty - edges -projectedExactPoints - :: LocalEmbeddingCertificate - -> Either (OverlayError leftLabel rightLabel) (Map DraftVertexId ExactPoint) -projectedExactPoints certificate = - Map.traverseWithKey - (\vertex point -> - first - (\projectionError -> - OverlayEmbeddingRefused - (VertexProjectionRefused vertex projectionError :| [])) - (exactPointFromPoint point)) - (certificateRoundedVertices certificate) - -projectedAtomicSegments - :: V.Vector (AtomicEdge leftLabel rightLabel) - -> Map ExactPoint DraftVertexId - -> Map DraftVertexId ExactPoint - -> Either (OverlayError leftLabel rightLabel) (V.Vector ExactSegment) -projectedAtomicSegments edges pointIds projected = - V.imapM project edges - where - project segmentIndex edge = do - fromId <- requireDraftVertex pointIds (atomicEdgeFrom edge) - toId <- requireDraftVertex pointIds (atomicEdgeTo edge) - from <- requireProjected fromId - to <- requireProjected toId - first - (\_ -> - OverlayEmbeddingRefused - ( ProjectedSegmentCollapsed - (DraftSegmentId segmentIndex) - fromId - toId - :| [] - )) - (exactSegment from to) - requireProjected vertex = - case Map.lookup vertex projected of - Just point -> Right point - Nothing -> - Left - ( OverlayEmbeddingRefused - (DraftReferenceMissing (DraftVertexReference vertex) :| []) - ) - -dischargeGlobalRelations - :: Map (ExactSweepSegmentId, ExactSweepSegmentId) SegmentRelation - -> ExactSegmentEventPlan - -> Either (OverlayError leftLabel rightLabel) () -dischargeGlobalRelations exactRelations projectedPlan = - case NonEmpty.nonEmpty obstructions of - Nothing -> Right () - Just failures -> Left (OverlayEmbeddingRefused failures) - where - projectedRelations = exactSegmentRelationMap projectedPlan - keys = Set.toAscList (Map.keysSet exactRelations <> Map.keysSet projectedRelations) - obstructions = concatMap compareRelation keys - compareRelation key@(ExactSweepSegmentId leftId, ExactSweepSegmentId rightId) = - case (Map.lookup key exactRelations, Map.lookup key projectedRelations) of - (Nothing, Just projected) -> - [GlobalRelationAdded (DraftSegmentId leftId) (DraftSegmentId rightId) projected] - (Just exact, Nothing) -> - [GlobalRelationRemoved (DraftSegmentId leftId) (DraftSegmentId rightId) exact] - (Just exact, Just projected) - | exact /= projected -> - [GlobalRelationChanged (DraftSegmentId leftId) (DraftSegmentId rightId) exact projected] - _ -> [] - -overlayVertexSeeds - :: Map ExactPoint DraftVertexId - -> Map ExactPoint OverlayVertexOrigin - -> LocalEmbeddingCertificate - -> Either (OverlayError leftLabel rightLabel) (V.Vector OverlayVertexSeed) -overlayVertexSeeds pointIds origins certificate = - V.fromList - <$> traverse - (\(point, vertexId) -> do - embedded <- - case Map.lookup vertexId (certificateRoundedVertices certificate) of - Just value -> Right value - Nothing -> - Left - ( OverlayEmbeddingRefused - (DraftReferenceMissing (DraftVertexReference vertexId) :| []) - ) - origin <- - case Map.lookup point origins of - Just value -> Right value - Nothing -> Left (OverlayProvenanceIncomplete (OverlayExactVertexMissing point)) - pure (OverlayVertexSeed point embedded origin)) - (Map.toAscList pointIds) - -atomicConstraints - :: Map ExactPoint DraftVertexId - -> V.Vector (AtomicEdge leftLabel rightLabel) - -> Either (OverlayError leftLabel rightLabel) (V.Vector (Int, Int)) -atomicConstraints pointIds = - V.mapM - (\edge -> do - DraftVertexId from <- requireDraftVertex pointIds (atomicEdgeFrom edge) - DraftVertexId to <- requireDraftVertex pointIds (atomicEdgeTo edge) - pure (from, to)) - - -canonicalEdgeKey :: ExactPoint -> ExactPoint -> ExactEdgeKey -canonicalEdgeKey = orderedPair - -atomicEdgeFrom :: AtomicEdge leftLabel rightLabel -> ExactPoint -atomicEdgeFrom = fst . exactSegmentEndpoints . atomicEdgeSegment - -atomicEdgeTo :: AtomicEdge leftLabel rightLabel -> ExactPoint -atomicEdgeTo = snd . exactSegmentEndpoints . atomicEdgeSegment - -atomicKey :: AtomicEdge leftLabel rightLabel -> ExactEdgeKey -atomicKey edge = (atomicEdgeFrom edge, atomicEdgeTo edge) diff --git a/src-build/Moonlight/Triangulation/Internal/Overlay/Resident.hs b/src-build/Moonlight/Triangulation/Internal/Overlay/Resident.hs deleted file mode 100644 --- a/src-build/Moonlight/Triangulation/Internal/Overlay/Resident.hs +++ /dev/null @@ -1,869 +0,0 @@ -{-# LANGUAGE DataKinds #-} - --- | Resident DCEL descent and exact-cell gluing. The certified arrangement is --- authoritative at this seam; diagonal schedules may change only its resident --- triangulation, never its exact cell descriptors. -module Moonlight.Triangulation.Internal.Overlay.Resident - ( OverlayDiagonalSchedule (..) - , residentOverlay - , faceLabels - , regionFaceLabels - , vertexSupport - , edgeSupport - ) where - -import Control.Monad (foldM) -import Data.Bifunctor (first) -import Data.Foldable (traverse_) -import Data.List (partition, sort, sortBy) -import 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.Maybe (listToMaybe, mapMaybe) -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import Data.Set (Set) -import qualified Data.Vector as V -import qualified Moonlight.Triangulation.Dcel as Dcel -import Moonlight.Triangulation.Dcel - ( faceData - , faceDirectedEdges - , imapUndirectedEdges - , incidentFace - , isConstraintEdge - , numInnerFaces - , numVertices - , outerFace - , undirectedEndpoints - , vertexData - , vertexOutgoingEdges - ) -import Moonlight.Triangulation.Exact (ExactPoint, exactOrient2d) -import Moonlight.Triangulation.FloodFillIterator - ( FaceComponent - , componentBoundary - , faceComponentFaces - , faceComponents - ) -import Moonlight.Triangulation.Handles.HandleDefs - ( DirectedEdgeId - , FaceId - , UndirectedEdgeId - , VertexId - , asUndirected - , directedPair - , reverseEdge - ) -import Moonlight.Triangulation.Handles.Iterators.FixedIterators - ( allFaces - , innerFaces - , undirectedEdges - ) -import Moonlight.Triangulation.Internal.BoxedPaged (boxedFromVector) -import Moonlight.Triangulation.Internal.BoundaryCycle (consecutivePairs) -import Moonlight.Triangulation.Internal.Canonical (canonicalize) -import Moonlight.Triangulation.Internal.Cdt.Build (constrainedDelaunay) -import Moonlight.Triangulation.Internal.Cdt.Types (CdtError (..)) -import Moonlight.Triangulation.Internal.Overlay.Arrangement - ( ArrangementMetrics (..) - , AtomicEdge (..) - , atomicEdgeFrom - , atomicEdgeTo - , CertifiedArrangement (..) - , ExactEdgeKey - , OverlayVertexSeed (..) - , atomicKey - , canonicalEdgeKey - , compareAround - ) -import Moonlight.Triangulation.Internal.Overlay.Types -import Moonlight.Triangulation.Internal.Region.Publication - ( polygonComponentFromBoundaryCoordinates - ) -import Moonlight.Triangulation.Internal.Region.Types - ( ExactLoop - , PolygonComponent - , RegionPublicationError (..) - ) -import Moonlight.Triangulation.Internal.Representation - ( BuildResult (..) - , Triangulation (..) - ) -import Moonlight.Triangulation.Internal.Types - ( ConstraintMode (Constrained) - , ElementDefaults (..) - ) -import Moonlight.Triangulation.Region (exactLoop) - -data OverlayDiagonalSchedule - = CanonicalOverlayDiagonals - | FlipFirstAdmissibleDiagonal - deriving stock (Eq, Ord, Show) - -data ComponentDraft leftLabel rightLabel = ComponentDraft - { componentDraftLabels :: !(leftLabel, rightLabel) - , componentDraftFaces :: !FaceComponent - , componentDraftPolygon :: !PolygonComponent - , componentDraftTouchesOuter :: !Bool - } - -residentOverlay - :: (Ord leftLabel, Ord rightLabel) - => OverlayDiagonalSchedule - -> (leftLabel, rightLabel) - -> CertifiedArrangement leftLabel rightLabel - -> Either - (OverlayError leftLabel rightLabel) - (OverlayResult leftLabel rightLabel) -residentOverlay diagonalSchedule outsidePair certified = do - let atomicVector = certifiedAtomicEdges certified - seeds = certifiedVertexSeeds certified - constraints = certifiedConstraints certified - metrics = certifiedMetrics certified - defaults = ElementDefaults () () () - built <- first OverlayBuildFailed (constrainedDelaunay defaults seeds constraints) - let resident = buildTriangulation built - if numVertices resident == V.length seeds - then Right () - else - Left - ( OverlayProvenanceIncomplete - (OverlayEmbeddedVertexCountMismatch (V.length seeds) (numVertices resident)) - ) - canonicalResident <- - first (OverlayBuildFailed . CdtBuildError) (canonicalize resident) - let atomicByKey = - Map.fromList - [ (atomicKey edge, edge) - | edge <- V.toList atomicVector - ] - validateAtomicConstraints canonicalResident atomicByKey - scheduledResident <- - applyDiagonalSchedule - diagonalSchedule - defaults - seeds - constraints - canonicalResident - labelledFaces <- labelResidentFaces outsidePair scheduledResident atomicByKey - componentDrafts <- residentComponentDrafts scheduledResident labelledFaces - let (unboundedDrafts, boundedDrafts) = - partitionDrafts outsidePair componentDrafts - numberedBounded <- numberBoundedComponents boundedDrafts - let cellIdByFace = - Map.fromList - ( [ (face, OverlayCellId 0) - | draftComponent <- unboundedDrafts - , face <- faceComponentFaces (componentDraftFaces draftComponent) - ] - <> [ (face, cellId) - | (cellId, draftComponent) <- numberedBounded - , face <- faceComponentFaces (componentDraftFaces draftComponent) - ] - ) - unboundedLoops <- - unboundedCellBoundaryLoops scheduledResident atomicByKey cellIdByFace - let cells = - V.fromList - ( OverlayCell - { overlayCellLeft = fst outsidePair - , overlayCellRight = snd outsidePair - , overlayCellGeometry = UnboundedOverlayCell unboundedLoops - } - : [ OverlayCell - { overlayCellLeft = fst (componentDraftLabels draftComponent) - , overlayCellRight = snd (componentDraftLabels draftComponent) - , overlayCellGeometry = - BoundedOverlayCell (componentDraftPolygon draftComponent) - } - | (_, draftComponent) <- numberedBounded - ] - ) - withFaces <- attachFaceCells cellIdByFace scheduledResident - let withVertices = attachOverlayVertices withFaces - withEdges = - imapUndirectedEdges - OverlayDiagonal - (\edge _ -> - case Map.lookup (residentEdgeKey withVertices edge) atomicByKey of - Nothing -> OverlayDiagonal - Just atomic -> OverlayBoundary (atomicEdgeOrigin atomic)) - withVertices - receipt = - OverlayReceipt - { overlayInputSegments = arrangementInputSegments metrics - , overlayRelationEvents = arrangementRelationEvents metrics - , overlayExactCrossings = arrangementExactCrossings metrics - , overlayOverlapIntervals = arrangementOverlapIntervals metrics - , overlayAtomicEdges = V.length atomicVector - , overlayOutputVertices = numVertices withEdges - , overlayArrangementCells = V.length cells - , overlayResidentFaces = numInnerFaces withEdges - , overlayEmbeddingCandidates = arrangementEmbeddingCandidates metrics - , overlayTotalRelationChecks = arrangementTotalRelationChecks metrics - , overlaySweepMaximumHeight = arrangementSweepMaximumHeight metrics - } - pure - OverlayResult - { overlayResultTriangulation = withEdges - , overlayResultCells = cells - , overlayResultOutsideLabels = outsidePair - , overlayResultReceipt = receipt - } - -applyDiagonalSchedule - :: OverlayDiagonalSchedule - -> ElementDefaults () () () - -> V.Vector OverlayVertexSeed - -> V.Vector (Int, Int) - -> Triangulation 'Constrained OverlayVertexSeed () () () - -> Either - (OverlayError leftLabel rightLabel) - (Triangulation 'Constrained OverlayVertexSeed () () ()) -applyDiagonalSchedule CanonicalOverlayDiagonals _ _ _ triangulation = - Right triangulation -applyDiagonalSchedule - FlipFirstAdmissibleDiagonal - defaults - seeds - constraints - triangulation = - case firstAlternativeDiagonal triangulation of - Nothing -> Right triangulation - Just (from, to) -> do - let indexByPoint = - Map.fromList - [ (seedExactPoint seed, index) - | (index, seed) <- V.toList (V.indexed seeds) - ] - fromIndex <- requireSeedIndex indexByPoint from - toIndex <- requireSeedIndex indexByPoint to - rebuilt <- - first OverlayBuildFailed - (constrainedDelaunay defaults seeds (V.snoc constraints (fromIndex, toIndex))) - first (OverlayBuildFailed . CdtBuildError) - (canonicalize (buildTriangulation rebuilt)) - -requireSeedIndex - :: Map ExactPoint Int - -> ExactPoint - -> Either (OverlayError leftLabel rightLabel) Int -requireSeedIndex indexByPoint point = - case Map.lookup point indexByPoint of - Just index -> Right index - Nothing -> Left (OverlayProvenanceIncomplete (OverlayExactVertexMissing point)) - -firstAlternativeDiagonal - :: Triangulation 'Constrained OverlayVertexSeed () () () - -> Maybe ExactEdgeKey -firstAlternativeDiagonal triangulation = - listToMaybe - (mapMaybe (alternativeDiagonal triangulation) (undirectedEdges triangulation)) - -alternativeDiagonal - :: Triangulation 'Constrained OverlayVertexSeed () () () - -> UndirectedEdgeId - -> Maybe ExactEdgeKey -alternativeDiagonal triangulation edge - | isConstraintEdge triangulation edge = Nothing - | leftFace == outerFace || rightFace == outerFace = Nothing - | exactOrient2d c d b == GT && exactOrient2d d c a == GT = - Just (canonicalEdgeKey c d) - | otherwise = Nothing - where - (forward, backward) = directedPair edge - leftFace = incidentFace triangulation forward - rightFace = incidentFace triangulation backward - a = seedExactPoint (vertexData triangulation (Dcel.origin triangulation forward)) - b = seedExactPoint (vertexData triangulation (Dcel.origin triangulation backward)) - c = - seedExactPoint - (vertexData triangulation (Dcel.origin triangulation (Dcel.previous triangulation forward))) - d = - seedExactPoint - (vertexData triangulation (Dcel.origin triangulation (Dcel.previous triangulation backward))) -labelResidentFaces - :: (Ord leftLabel, Ord rightLabel) - => (leftLabel, rightLabel) - -> Triangulation 'Constrained OverlayVertexSeed () () () - -> Map ExactEdgeKey (AtomicEdge leftLabel rightLabel) - -> Either - (OverlayError leftLabel rightLabel) - (Map FaceId (leftLabel, rightLabel)) -labelResidentFaces outsideLabels triangulation atomicByKey = do - labelled <- - descendFaceTransitions - triangulation - atomicByKey - (Map.singleton outerFace outsideLabels) - (Seq.singleton outerFace) - case - [ face - | face <- innerFaces triangulation - , Map.notMember face labelled - ] of - missing : _ -> - Left (OverlayProvenanceIncomplete (OverlayResidentFaceUnassigned missing)) - [] -> Right (Map.delete outerFace labelled) - -seedDirectedEndpoints - :: Triangulation mode OverlayVertexSeed directed undirected face - -> DirectedEdgeId - -> ExactEdgeKey -seedDirectedEndpoints triangulation edge = - ( seedExactPoint (vertexData triangulation (Dcel.origin triangulation edge)) - , seedExactPoint (vertexData triangulation (Dcel.destination triangulation edge)) - ) - -swapTransition :: (label, label) -> (label, label) -swapTransition (fromLabel, toLabel) = (toLabel, fromLabel) - -descendFaceTransitions - :: (Eq leftLabel, Eq rightLabel) - => Triangulation 'Constrained OverlayVertexSeed () () () - -> Map ExactEdgeKey (AtomicEdge leftLabel rightLabel) - -> Map FaceId (leftLabel, rightLabel) - -> Seq.Seq FaceId - -> Either - (OverlayError leftLabel rightLabel) - (Map FaceId (leftLabel, rightLabel)) -descendFaceTransitions triangulation atomicByKey labelled queued = - case Seq.viewl queued of - Seq.EmptyL -> Right labelled - face Seq.:< remaining -> - case Map.lookup face labelled of - Nothing -> - Left (OverlayProvenanceIncomplete (OverlayResidentFaceUnassigned face)) - Just current -> do - (nextLabels, nextQueue) <- - foldM - (descendFaceTransition triangulation atomicByKey face current) - (labelled, remaining) - (faceDirectedEdges triangulation face) - descendFaceTransitions triangulation atomicByKey nextLabels nextQueue - -descendFaceTransition - :: (Eq leftLabel, Eq rightLabel) - => Triangulation 'Constrained OverlayVertexSeed () () () - -> Map ExactEdgeKey (AtomicEdge leftLabel rightLabel) - -> FaceId - -> (leftLabel, rightLabel) - -> (Map FaceId (leftLabel, rightLabel), Seq.Seq FaceId) - -> DirectedEdgeId - -> Either - (OverlayError leftLabel rightLabel) - (Map FaceId (leftLabel, rightLabel), Seq.Seq FaceId) -descendFaceTransition triangulation atomicByKey source current (labelled, queued) directed = do - let edge = asUndirected directed - destinationFace = incidentFace triangulation (reverseEdge directed) - (leftTransition, rightTransition) <- - case Map.lookup (residentSeedEdgeKey triangulation edge) atomicByKey of - Nothing -> Right (Nothing, Nothing) - Just atomic -> orientedTransitions edge directed atomic - let - expected = - ( maybe (fst current) fst leftTransition - , maybe (snd current) fst rightTransition - ) - derived = - ( maybe (fst current) snd leftTransition - , maybe (snd current) snd rightTransition - ) - if current == expected - then - case Map.lookup destinationFace labelled of - Nothing -> - Right - ( Map.insert destinationFace derived labelled - , queued Seq.|> destinationFace - ) - Just existing - | existing == derived -> Right (labelled, queued) - | otherwise -> - Left - ( OverlayArrangementInvalid - ( OverlayResidentFaceLabelConflict - destinationFace - edge - existing - derived - ) - ) - else - Left - ( OverlayArrangementInvalid - (OverlayTransitionSourceMismatch source edge current expected) - ) - where - orientedTransitions edge candidateDirection atomic - | directedEndpoints == (atomicEdgeFrom atomic, atomicEdgeTo atomic) = - Right - ( atomicEdgeLeftTransition atomic - , atomicEdgeRightTransition atomic - ) - | directedEndpoints == (atomicEdgeTo atomic, atomicEdgeFrom atomic) = - Right - ( swapTransition <$> atomicEdgeLeftTransition atomic - , swapTransition <$> atomicEdgeRightTransition atomic - ) - | otherwise = - Left - ( OverlayProvenanceIncomplete - ( OverlayAtomicConstraintOrientationMismatch - edge - (atomicEdgeFrom atomic) - (atomicEdgeTo atomic) - ) - ) - where - directedEndpoints = seedDirectedEndpoints triangulation candidateDirection - -residentComponentDrafts - :: (Ord leftLabel, Ord rightLabel) - => Triangulation 'Constrained OverlayVertexSeed () () () - -> Map FaceId (leftLabel, rightLabel) - -> Either - (OverlayError leftLabel rightLabel) - [ComponentDraft leftLabel rightLabel] -residentComponentDrafts triangulation labels = - traverse convert (faceComponents triangulation (`Map.lookup` labels)) - where - exactPointAt vertex = - Right (seedExactPoint (vertexData triangulation vertex)) - convert (maybeLabels, component) = do - componentLabels <- - case maybeLabels of - Just value -> Right value - Nothing -> - case faceComponentFaces component of - face : _ -> Left (OverlayProvenanceIncomplete (OverlayResidentFaceUnassigned face)) - [] -> Left (OverlayArrangementInvalid OverlayFaceComponentEmpty) - boundary <- - first - (OverlayRegionPublicationFailed . RegionBoundaryObstruction) - (componentBoundary triangulation component) - polygon <- - first OverlayRegionPublicationFailed - (polygonComponentFromBoundaryCoordinates exactPointAt boundary) - pure - ComponentDraft - { componentDraftLabels = componentLabels - , componentDraftFaces = component - , componentDraftPolygon = polygon - , componentDraftTouchesOuter = touchesOuter triangulation component - } - -touchesOuter - :: Triangulation mode vertex directed undirected face - -> FaceComponent - -> Bool -touchesOuter triangulation component = - any - ( any ((== outerFace) . incidentFace triangulation . reverseEdge) - . faceDirectedEdges triangulation - ) - (faceComponentFaces component) - -partitionDrafts - :: (Eq leftLabel, Eq rightLabel) - => (leftLabel, rightLabel) - -> [ComponentDraft leftLabel rightLabel] - -> ([ComponentDraft leftLabel rightLabel], [ComponentDraft leftLabel rightLabel]) -partitionDrafts outsidePair = - partition - (\draftComponent -> - componentDraftTouchesOuter draftComponent - && componentDraftLabels draftComponent == outsidePair) - -sortComponentDrafts - :: (Ord leftLabel, Ord rightLabel) - => [ComponentDraft leftLabel rightLabel] - -> [ComponentDraft leftLabel rightLabel] -sortComponentDrafts = - sortBy - (\left right -> - compare - (componentDraftPolygon left, componentDraftLabels left) - (componentDraftPolygon right, componentDraftLabels right)) - -numberBoundedComponents - :: (Ord leftLabel, Ord rightLabel) - => [ComponentDraft leftLabel rightLabel] - -> Either - (OverlayError leftLabel rightLabel) - [(OverlayCellId, ComponentDraft leftLabel rightLabel)] -numberBoundedComponents drafts = - case - [ componentDraftPolygon left - | (left, right) <- consecutivePairs ordered - , componentSignature left == componentSignature right - ] of - duplicate : _ -> - Left - ( OverlayArrangementInvalid - (OverlayDuplicateCellSignature duplicate) - ) - [] -> - Right - ( zipWith - (\index component -> (OverlayCellId index, component)) - [1 ..] - ordered - ) - where - ordered = sortComponentDrafts drafts - componentSignature - :: ComponentDraft leftLabel' rightLabel' - -> (PolygonComponent, (leftLabel', rightLabel')) - componentSignature component = - (componentDraftPolygon component, componentDraftLabels component) - --- | Trace the finite boundary cycles of the unbounded exact cell from atomic --- edges only. Resident hull edges and Delaunay diagonals are absent by --- construction; the DCEL contributes only the already-proved incident-cell --- gluing needed to orient each atomic edge with cell zero on its left. -unboundedCellBoundaryLoops - :: Triangulation 'Constrained OverlayVertexSeed () () () - -> Map ExactEdgeKey (AtomicEdge leftLabel rightLabel) - -> Map FaceId OverlayCellId - -> Either (OverlayError leftLabel rightLabel) [ExactLoop] -unboundedCellBoundaryLoops triangulation atomicByKey cellIdByFace = do - orientedEdges <- - Set.fromList . concat - <$> traverse orientAtomicEdge (undirectedEdges triangulation) - traceBoundaryCycles orientedEdges - where - orientAtomicEdge edge - | Map.notMember (residentSeedEdgeKey triangulation edge) atomicByKey = Right [] - | otherwise = do - let (forward, backward) = directedPair edge - forwardCell <- faceCellId (incidentFace triangulation forward) - backwardCell <- faceCellId (incidentFace triangulation backward) - pure - ( case (forwardCell == OverlayCellId 0, backwardCell == OverlayCellId 0) of - (True, False) -> [seedDirectedEndpoints triangulation forward] - (False, True) -> [seedDirectedEndpoints triangulation backward] - _ -> [] - ) - faceCellId face - | face == outerFace = Right (OverlayCellId 0) - | otherwise = - case Map.lookup face cellIdByFace of - Just cellId -> Right cellId - Nothing -> Left (OverlayProvenanceIncomplete (OverlayResidentFaceUnassigned face)) - -traceBoundaryCycles - :: Set ExactEdgeKey - -> Either (OverlayError leftLabel rightLabel) [ExactLoop] -traceBoundaryCycles orientedEdges = descend orientedEdges [] - where - outgoing = - Map.mapWithKey orderAroundOrigin - ( Set.foldl' - (\byOrigin edge@(from, _) -> Map.insertWith (<>) from [edge] byOrigin) - Map.empty - orientedEdges - ) - orderAroundOrigin :: ExactPoint -> [ExactEdgeKey] -> [ExactEdgeKey] - orderAroundOrigin origin = - sortBy (\(_, left) (_, right) -> compareAround origin left right) - descend remaining cycles = - case Set.lookupMin remaining of - Nothing -> Right (sort cycles) - Just seed -> - let (untraced, circuit) = boundaryEulerCircuit outgoing remaining (fst seed) - in case splitBoundaryCircuit circuit of - Nothing -> - Left - ( OverlayArrangementInvalid - (uncurry OverlayCellCycleDidNotClose seed) - ) - Just pointCycles -> do - loops <- - traverse - ( first - (OverlayRegionPublicationFailed . RegionValidationObstruction) - . exactLoop - ) - pointCycles - descend untraced (loops <> cycles) - --- | Consume one directed Eulerian boundary component. Each edge is deleted --- exactly once; circuit extraction therefore cannot acquire the exponential --- branch factor of simple-cycle backtracking at point contacts. -boundaryEulerCircuit - :: Map ExactPoint [ExactEdgeKey] - -> Set ExactEdgeKey - -> ExactPoint - -> (Set ExactEdgeKey, [ExactEdgeKey]) -boundaryEulerCircuit outgoing remaining start = - descend remaining [start] [] [] - where - descend untraced vertexStack incomingEdges circuit = - case vertexStack of - [] -> (untraced, circuit) - vertex : previousVertices -> - case nextUntracedEdge vertex untraced of - Just edge -> - descend - (Set.delete edge untraced) - (snd edge : vertexStack) - (edge : incomingEdges) - circuit - Nothing -> - case incomingEdges of - edge : previousEdges -> - descend - untraced - previousVertices - previousEdges - (edge : circuit) - [] -> (untraced, circuit) - nextUntracedEdge vertex untraced = - case - [ edge - | edge <- Map.findWithDefault [] vertex outgoing - , Set.member edge untraced - ] of - edge : _ -> Just edge - [] -> Nothing - --- | Split an Euler circuit at repeated vertices. The maintained path is --- simple; closing against any resident path vertex emits one simple cycle and --- deletes precisely that suffix before descent continues. -splitBoundaryCircuit :: [ExactEdgeKey] -> Maybe [NonEmpty ExactPoint] -splitBoundaryCircuit circuit = - case circuit of - [] -> Nothing - (start, _) : _ -> - reverse - <$> descend - start - 0 - (Map.singleton start 0) - [start] - [] - [] - circuit - where - descend - :: ExactPoint - -> Int - -> Map ExactPoint Int - -> [ExactPoint] - -> [ExactEdgeKey] - -> [NonEmpty ExactPoint] - -> [ExactEdgeKey] - -> Maybe [NonEmpty ExactPoint] - descend - current - currentDepth - depthByPoint - reversedPathPoints - reversedPathEdges - cycles - remainingEdges = - case remainingEdges of - [] - | currentDepth == 0 - , [_] <- reversedPathPoints - , null reversedPathEdges -> Just cycles - | otherwise -> Nothing - edge@(fromPoint, toPoint) : rest - | fromPoint /= current -> Nothing - | otherwise -> - case Map.lookup toPoint depthByPoint of - Nothing -> - descend - toPoint - (currentDepth + 1) - (Map.insert toPoint (currentDepth + 1) depthByPoint) - (toPoint : reversedPathPoints) - (edge : reversedPathEdges) - cycles - rest - Just repeatedDepth -> - let cyclePathLength = currentDepth - repeatedDepth - removedPoints = take cyclePathLength reversedPathPoints - cycleEdges = reverse (edge : take cyclePathLength reversedPathEdges) - remainingPathPoints = drop cyclePathLength reversedPathPoints - remainingPathEdges = drop cyclePathLength reversedPathEdges - remainingDepths = - foldr Map.delete depthByPoint removedPoints - in case NonEmpty.nonEmpty (map fst cycleEdges) of - Nothing -> Nothing - Just cyclePoints -> - descend - toPoint - repeatedDepth - remainingDepths - remainingPathPoints - remainingPathEdges - (cyclePoints : cycles) - rest - -attachFaceCells - :: Map FaceId OverlayCellId - -> Triangulation 'Constrained OverlayVertexSeed () () () - -> Either - (OverlayError leftLabel rightLabel) - (Triangulation 'Constrained OverlayVertexSeed () () OverlayFace) -attachFaceCells cellIdByFace triangulation = do - payloads <- V.fromList <$> traverse facePayload (allFaces triangulation) - let outerPayload = OverlayFace (OverlayCellId 0) - defaults = triElementDefaults triangulation - pure - triangulation - { triFaceData = boxedFromVector (Just outerPayload) payloads - , triElementDefaults = defaults{defaultFaceData = outerPayload} - } - where - facePayload face - | face == outerFace = Right (OverlayFace (OverlayCellId 0)) - | otherwise = - case Map.lookup face cellIdByFace of - Just cellId -> Right (OverlayFace cellId) - Nothing -> - Left - ( OverlayProvenanceIncomplete - (OverlayResidentFaceUnassigned face) - ) - -attachOverlayVertices - :: Triangulation 'Constrained OverlayVertexSeed () () face - -> Triangulation 'Constrained OverlayVertex () () face -attachOverlayVertices = - Dcel.mapVertices - (\seed -> OverlayVertex (seedExactPoint seed) (seedOrigin seed)) - -cellPayload - :: V.Vector (OverlayCell leftLabel rightLabel) - -> OverlayCellId - -> Either OverlayCellWitness (OverlayCell leftLabel rightLabel) -cellPayload cells cellId@(OverlayCellId index) = - case cells V.!? index of - Just cell -> Right cell - Nothing -> Left (OverlayCellPayloadMissing cellId) - -faceLabels - :: OverlayResult leftLabel rightLabel - -> FaceId - -> Either OverlayCellWitness (leftLabel, rightLabel) -faceLabels result face = do - cell <- - cellPayload - (overlayResultCells result) - (overlayFaceCellId (faceData (overlayResultTriangulation result) face)) - pure (overlayCellLeft cell, overlayCellRight cell) - -regionFaceLabels - :: OverlayResult leftLabel rightLabel - -> FaceId - -> Either RegionPublicationError (leftLabel, rightLabel) -regionFaceLabels result face = - case faceLabels result face of - Right labels -> Right labels - Left _ -> Left (RegionFaceLabelMissing face) - -vertexSupport - :: (Ord leftLabel, Ord rightLabel) - => OverlayResult leftLabel rightLabel - -> VertexId - -> Either OverlayCellWitness (OverlayCellSupport leftLabel rightLabel) -vertexSupport result vertex = do - labels <- - traverse - (faceLabels result . incidentFace triangulation) - (vertexOutgoingEdges triangulation vertex) - case supportFromPairs labels of - Just support -> Right support - Nothing -> Left (OverlayVertexSupportMissing vertex) - where - triangulation = overlayResultTriangulation result - -edgeSupport - :: (Ord leftLabel, Ord rightLabel) - => OverlayResult leftLabel rightLabel - -> UndirectedEdgeId - -> Either OverlayCellWitness (OverlayCellSupport leftLabel rightLabel) -edgeSupport result edge = do - pairs <- traverse (faceLabels result . incidentFace triangulation) [forward, backward] - case supportFromPairs pairs of - Just support -> Right support - Nothing -> Left (OverlayEdgeSupportMissing edge) - where - triangulation = overlayResultTriangulation result - (forward, backward) = directedPair edge - -supportFromPairs - :: (Ord leftLabel, Ord rightLabel) - => [(leftLabel, rightLabel)] - -> Maybe (OverlayCellSupport leftLabel rightLabel) -supportFromPairs pairs = do - let (leftLabels, rightLabels) = - 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-build/Moonlight/Triangulation/Internal/Overlay/Types.hs b/src-build/Moonlight/Triangulation/Internal/Overlay/Types.hs deleted file mode 100644 --- a/src-build/Moonlight/Triangulation/Internal/Overlay/Types.hs +++ /dev/null @@ -1,267 +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 (..) - , BoundaryVertexRef (..) - , BoundaryEdgeRef (..) - , OverlayVertexOrigin (..) - , OverlayEdgeOrigin (..) - , OverlaySupport (..) - , overlaySupportLabels - , OverlayCellSupport (..) - , OverlayCellId (..) - , OverlayCellGeometry (..) - , OverlayCell (..) - , OverlayFace (..) - , OverlayVertex (..) - , OverlayEdge (..) - , OverlayReceipt (..) - , OverlayArrangementObstruction (..) - , OverlayCellWitness (..) - , OverlayError (..) - , OverlayResult (..) - , OverlaySelectionKind (..) - , OverlaySelectionError (..) - ) where - -import Control.DeepSeq (NFData) -import Data.List.NonEmpty (NonEmpty) -import Data.Vector (Vector) -import GHC.Generics (Generic) -import Moonlight.Triangulation.CellSet (CellSelectionError) -import Moonlight.Triangulation.Exact - ( ExactPoint - ) -import Moonlight.Triangulation.Handles.HandleDefs - ( FaceId - , UndirectedEdgeId - , VertexId - ) -import Moonlight.Triangulation.Internal.Cdt.Types (CdtError) -import Moonlight.Triangulation.Internal.ExactRational (ExactArithmeticError) -import Moonlight.Triangulation.Internal.ExactSegmentEvents (ExactSegmentEventObstruction) -import Moonlight.Triangulation.Internal.Overlay.Embedding (OverlayEmbeddingObstruction) -import Moonlight.Triangulation.Internal.Region.Types - ( ExactLoop - , PolygonComponent - , RegionPublicationError - ) -import Moonlight.Triangulation.Internal.Representation (Triangulation) -import Moonlight.Triangulation.Internal.Types - ( ConstraintMode (Constrained) - ) - --- | Which cycle inside a polygon component supplied a source reference. -data BoundaryLoopRef - = BoundaryOuterLoop - | BoundaryHoleLoop !Int - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - -data OverlayOperand - = LeftOverlayOperand - | RightOverlayOperand - --- | A boundary vertex reference whose phantom operand prevents left/right --- provenance from being interchanged while sharing their identical payload. -data BoundaryVertexRef (operand :: OverlayOperand) = BoundaryVertexRef - { boundaryVertexComponent :: !Int - , boundaryVertexLoop :: !BoundaryLoopRef - , boundaryVertexLocalIndex :: !Int - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - --- | The corresponding typed reference for one source boundary edge. -data BoundaryEdgeRef (operand :: OverlayOperand) = BoundaryEdgeRef - { boundaryEdgeComponent :: !Int - , boundaryEdgeLoop :: !BoundaryLoopRef - , boundaryEdgeLocalIndex :: !Int - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - --- | Complete typed source closure of one arrangement vertex. -data OverlayVertexOrigin = OverlayVertexOrigin - { overlayOriginLeftVertices :: ![BoundaryVertexRef 'LeftOverlayOperand] - , overlayOriginRightVertices :: ![BoundaryVertexRef 'RightOverlayOperand] - , overlayOriginLeftEdges :: ![BoundaryEdgeRef 'LeftOverlayOperand] - , overlayOriginRightEdges :: ![BoundaryEdgeRef 'RightOverlayOperand] - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - --- | Nonempty typed source-edge provenance of one exact atomic interval. -data OverlayEdgeOrigin = OverlayEdgeOrigin - { overlayEdgeLeftSources :: ![BoundaryEdgeRef 'LeftOverlayOperand] - , overlayEdgeRightSources :: ![BoundaryEdgeRef 'RightOverlayOperand] - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - --- | Sorted nonempty labels whose closures contain one relatively open cell. -newtype OverlaySupport label = OverlaySupport (NonEmpty label) - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - -overlaySupportLabels :: OverlaySupport label -> NonEmpty label -overlaySupportLabels (OverlaySupport labels) = labels - -data OverlayCellSupport leftLabel rightLabel = OverlayCellSupport - { overlaySupportLeft :: !(OverlaySupport leftLabel) - , overlaySupportRight :: !(OverlaySupport rightLabel) - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - -newtype OverlayCellId = OverlayCellId Int - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - -data OverlayCellGeometry - = BoundedOverlayCell !PolygonComponent - | UnboundedOverlayCell ![ExactLoop] - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - -data OverlayCell leftLabel rightLabel = OverlayCell - { overlayCellLeft :: !leftLabel - , overlayCellRight :: !rightLabel - , overlayCellGeometry :: !OverlayCellGeometry - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - --- | A resident face stores only its authoritative dense-cell reference. --- Labels and geometry belong to 'OverlayCell'; duplicating them here made --- every observation carry a reconciliation obligation with no additional law. -newtype OverlayFace = OverlayFace - { overlayFaceCellId :: OverlayCellId - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - --- | Exact geometry and provenance are intrinsic to a vertex. Label support is --- the finite union of incident cell descriptors and is therefore a view. -data OverlayVertex = OverlayVertex - { overlayExactPoint :: !ExactPoint - , overlayVertexOrigin :: !OverlayVertexOrigin - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - --- | Boundary provenance is intrinsic; label support is derived from the two --- incident face-cell references. -data OverlayEdge - = OverlayBoundary !OverlayEdgeOrigin - | OverlayDiagonal - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - -data OverlayReceipt = OverlayReceipt - { overlayInputSegments :: !Int - , overlayRelationEvents :: !Int - , overlayExactCrossings :: !Int - , overlayOverlapIntervals :: !Int - , overlayAtomicEdges :: !Int - , overlayOutputVertices :: !Int - , overlayArrangementCells :: !Int - , overlayResidentFaces :: !Int - , overlayEmbeddingCandidates :: !Int - , overlayTotalRelationChecks :: !Int - , overlaySweepMaximumHeight :: !Int - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - -data OverlayArrangementObstruction leftLabel rightLabel - = OverlayLeftSourceSideConflict - !OverlayEdgeOrigin - !(NonEmpty leftLabel) - | OverlayRightSourceSideConflict - !OverlayEdgeOrigin - !(NonEmpty rightLabel) - | OverlayRotationDegenerate !ExactPoint - | OverlayFaceComponentEmpty - | OverlayCellCycleDidNotClose !ExactPoint !ExactPoint - | OverlayTransitionSourceMismatch - !FaceId - !UndirectedEdgeId - !(leftLabel, rightLabel) - !(leftLabel, rightLabel) - | OverlayResidentFaceLabelConflict - !FaceId - !UndirectedEdgeId - !(leftLabel, rightLabel) - !(leftLabel, rightLabel) - | OverlayDuplicateCellSignature !PolygonComponent - deriving stock (Eq, Show, Generic) - deriving anyclass (NFData) - -data OverlayCellWitness - = OverlayAtomicConstraintMissing !ExactPoint !ExactPoint - | OverlayAtomicConstraintOrientationMismatch - !UndirectedEdgeId - !ExactPoint - !ExactPoint - | OverlayUnexpectedConstraint !UndirectedEdgeId - | OverlayBoundaryEdgeNotConstrained !UndirectedEdgeId - | OverlayResidentFaceUnassigned !FaceId - | OverlayCellPayloadMissing !OverlayCellId - | OverlayVertexSupportMissing !VertexId - | OverlayEdgeSupportMissing !UndirectedEdgeId - | OverlayEmbeddedVertexCountMismatch !Int !Int - | OverlayExactVertexMissing !ExactPoint - deriving stock (Eq, Show, Generic) - deriving anyclass (NFData) - -data OverlayError leftLabel rightLabel - = OverlayExactArithmetic !ExactArithmeticError - | OverlaySegmentEventsInvalid !ExactSegmentEventObstruction - | OverlayArrangementInvalid !(OverlayArrangementObstruction leftLabel rightLabel) - | OverlayEmbeddingRefused !(NonEmpty OverlayEmbeddingObstruction) - | OverlayBuildFailed !CdtError - | OverlayRegionPublicationFailed !RegionPublicationError - | OverlayProvenanceIncomplete !OverlayCellWitness - deriving stock (Eq, Show, Generic) - deriving anyclass (NFData) - --- | The singular exact subdivision carrier. Its embedded DCEL is a derived --- binary64 realization; exact coordinates remain in the vertex payload plane. -data OverlayResult leftLabel rightLabel = OverlayResult - { overlayResultTriangulation - :: !( Triangulation - 'Constrained - OverlayVertex - () - OverlayEdge - OverlayFace - ) - , overlayResultCells :: !(Vector (OverlayCell leftLabel rightLabel)) - , overlayResultOutsideLabels :: !(leftLabel, rightLabel) - , overlayResultReceipt :: !OverlayReceipt - } - deriving stock (Generic) - deriving anyclass (NFData) - -data OverlaySelectionKind - = ClosedUnionSelection - | ClosedIntersectionSelection - | RegularizedDifferenceSelection - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - -data OverlaySelectionError - = OverlaySelectionContainsUnboundedCell !OverlaySelectionKind - | OverlaySelectionProvenance !OverlayCellWitness - | OverlaySelectionInvalid !CellSelectionError - deriving stock (Eq, Show, Generic) - deriving anyclass (NFData) diff --git a/src-build/Moonlight/Triangulation/Internal/Refinement.hs b/src-build/Moonlight/Triangulation/Internal/Refinement.hs --- a/src-build/Moonlight/Triangulation/Internal/Refinement.hs +++ b/src-build/Moonlight/Triangulation/Internal/Refinement.hs @@ -19,7 +19,6 @@ import Control.Monad (filterM, forM_, unless, when) import Control.Monad.ST (ST) import Data.Foldable (traverse_) -import Data.Bits (xor) import qualified Data.IntSet as IntSet import Data.List (find) import qualified Data.Map.Strict as Map @@ -28,7 +27,9 @@ import qualified Data.Vector.Unboxed.Mutable as MUV import Data.Word (Word32) import Moonlight.Triangulation.Handles.HandleDefs (FaceId (..), UndirectedEdgeId (..)) -import Moonlight.Triangulation.Internal.DcelOperations (insertOnEdge, legalizeEdges) +import Moonlight.Triangulation.Internal.DcelOperations.Legalize (legalizeEdges) +import Moonlight.Triangulation.Internal.DcelOperations.Subdivide (insertOnEdge) +import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex) import Moonlight.Triangulation.Internal.Growable ( GrowableWord32 , clearGrowable @@ -169,10 +170,6 @@ , refinementDomainInputEdgeCount :: {-# UNPACK #-} !Int } deriving stock (Eq, Show) - -reverseIndex :: Int -> Int -reverseIndex edge = edge `xor` 1 -{-# INLINE reverseIndex #-} -- | Refine the existing finite DCEL. Fixed edges (constraints and the convex -- hull) are legal barriers: a candidate whose prospective cavity meets one diff --git a/src-build/Moonlight/Triangulation/Internal/Transaction.hs b/src-build/Moonlight/Triangulation/Internal/Transaction.hs --- a/src-build/Moonlight/Triangulation/Internal/Transaction.hs +++ b/src-build/Moonlight/Triangulation/Internal/Transaction.hs @@ -10,6 +10,7 @@ -- forgeable. module Moonlight.Triangulation.Internal.Transaction ( runTransaction + , runUnmeasuredTransaction ) where import Control.Monad.ST (ST, runST) @@ -43,8 +44,46 @@ -> Int -> (forall s. MutableDcel s vertex directed undirected face -> OperationState s -> ST s (Either failure result)) -> Either failure (result, Triangulation mode vertex directed undirected face, BuildStats) -runTransaction mapBuildFailure shape triangulation additional action = do - let !capacity = numVertices triangulation + max 0 additional +runTransaction = runTransactionWithReceipt freezeBuildStats +{-# INLINE runTransaction #-} + +-- | Publish a transaction whose caller observes no instrumentation. Avoiding +-- the statistics fold matters for singleton constraint verbs: their public +-- result has no statistics field, so reading every counter would be dead work. +runUnmeasuredTransaction + :: (BuildError -> failure) + -> TransactionShape + -> Triangulation mode vertex directed undirected face + -> Int + -> (forall s. MutableDcel s vertex directed undirected face -> OperationState s -> ST s (Either failure result)) + -> Either failure (result, Triangulation mode vertex directed undirected face) +runUnmeasuredTransaction mapBuildFailure shape triangulation additional action = + fmap + (\(result, frozen, ()) -> (result, frozen)) + ( runTransactionWithReceipt + (const (pure ())) + mapBuildFailure + shape + triangulation + additional + action + ) +{-# INLINE runUnmeasuredTransaction #-} + +runTransactionWithReceipt + :: (forall s. OperationState s -> ST s receipt) + -> (BuildError -> failure) + -> TransactionShape + -> Triangulation mode vertex directed undirected face + -> Int + -> (forall s. MutableDcel s vertex directed undirected face -> OperationState s -> ST s (Either failure result)) + -> Either failure (result, Triangulation mode vertex directed undirected face, receipt) +runTransactionWithReceipt freezeReceipt mapBuildFailure shape triangulation additional action = do + let !currentCapacity = numVertices triangulation + !requestedAdditional = max 0 additional + !capacity + | requestedAdditional > maxBound - currentCapacity = maxBound + | otherwise = currentCapacity + requestedAdditional case ensureCapacity capacity of Left failure -> Left (mapBuildFailure failure) Right () -> pure () @@ -62,6 +101,6 @@ case frozenOutcome of Left obstruction -> pure (Left (mapBuildFailure obstruction)) Right frozen -> do - stats <- freezeBuildStats operation - pure (Right (value, frozen, stats)) -{-# INLINE runTransaction #-} + receipt <- freezeReceipt operation + pure (Right (value, frozen, receipt)) +{-# INLINE runTransactionWithReceipt #-} diff --git a/src-build/Moonlight/Triangulation/Minkowski.hs b/src-build/Moonlight/Triangulation/Minkowski.hs deleted file mode 100644 --- a/src-build/Moonlight/Triangulation/Minkowski.hs +++ /dev/null @@ -1,584 +0,0 @@ -{-# LANGUAGE DataKinds #-} - --- | Exact polygonal Minkowski addition and regularized two-dimensional --- morphology. Convex convolution is direct; nonconvex construction descends --- through the existing exact overlay, resident CDT, and grouped publication --- owners. Lower-dimensional erosion residuals cannot inhabit 'PlanarRegion' --- and therefore publish as empty rather than being forged as polygons. -module Moonlight.Triangulation.Minkowski - ( ConvexPolygon - , convexPolygon - , convexPolygonPoints - , StructuringElement - , structuringElement - , MinkowskiOperation (..) - , MinkowskiError (..) - , MinkowskiReceipt (..) - , convexMinkowskiSum - , minkowskiSum - , erodeBy - , openWith - , closeWith - , polygonOffset - , polygonInset - ) where - -import Control.Applicative ((<|>)) -import Control.Monad (filterM) -import Data.Bifunctor (first) -import qualified Data.IntMap.Strict as IntMap -import qualified Data.List as List -import qualified Data.Map.Strict as Map -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe (fromMaybe) -import qualified Data.Set as Set -import qualified Data.Vector as V -import Moonlight.Triangulation.Dcel - ( faceData - , faceVertices - , vertexData - ) -import Moonlight.Triangulation.Exact - ( ExactPoint - , exactPointCoordinates - ) -import Moonlight.Triangulation.Handles.HandleDefs - ( FaceId - ) -import Moonlight.Triangulation.Handles.Iterators.FixedIterators (innerFaces) -import Moonlight.Triangulation.Internal.ExactRational - ( ExactRational - , exactRationalDenominator - , exactRationalNumerator - ) -import Moonlight.Triangulation.Internal.BoundaryCycle (cyclePairs) -import Moonlight.Triangulation.Internal.Dyadic (integerBitLength) -import Moonlight.Triangulation.Internal.Minkowski.Convex - ( addExactPoints - , admittedConvexLoop - , convexHullPolygon - , convexMinkowskiPolygon - , convexMinkowskiSum - , convexPolygon - , convexPolygonCentroid - , convexPolygonPoints - , convexPolygonRegion - , erodeConvexBy - , reflectConvexPolygon - , structuringElement - , structuringElementPolygon - ) -import Moonlight.Triangulation.Internal.Minkowski.Types -import Moonlight.Triangulation.Internal.Overlay.Resident (faceLabels) -import Moonlight.Triangulation.Internal.Overlay.Types - ( OverlayCell (..) - , OverlayCellGeometry (..) - , OverlayCellId (..) - , OverlayFace (..) - , OverlayResult (..) - , OverlayVertex (..) - ) -import Moonlight.Triangulation.Overlay - ( OverlayReceipt (..) - , overlayLayers - , overlayReceipt - , overlaySelectedRegion - ) -import Moonlight.Triangulation.Region - ( PlanarLayer - , PlanarRegion - , PolygonComponent - , RegionPointLocation (..) - , emptyPlanarRegion - , exactLoopPoints - , planarLayerRegions - , planarRegionComponents - , polygonHoleLoops - , polygonOuterLoop - , regionPointLocation - ) -import Moonlight.Triangulation.Internal.Region.Publication - ( labelledPlanarLayerFromExactCoordinates - , planarLayerFromAdmittedComponents - ) - -data MorphologyMetrics = MorphologyMetrics - { metricOverlayPasses :: !Int - , metricExactCrossings :: !Int - , metricOutputCells :: !(Maybe Int) - } - -emptyMetrics :: MorphologyMetrics -emptyMetrics = MorphologyMetrics 0 0 Nothing - -appendMetrics :: MorphologyMetrics -> MorphologyMetrics -> MorphologyMetrics -appendMetrics left right = - MorphologyMetrics - { metricOverlayPasses = metricOverlayPasses left + metricOverlayPasses right - , metricExactCrossings = metricExactCrossings left + metricExactCrossings right - , metricOutputCells = metricOutputCells right <|> metricOutputCells left - } - -minkowskiSum - :: PlanarRegion - -> PlanarRegion - -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) -minkowskiSum left right = do - (leftPieces, leftMetrics) <- decomposeRegion left - (rightPieces, rightMetrics) <- decomposeRegion right - let generated = - [ convexMinkowskiPolygon leftPiece rightPiece - | leftPiece <- leftPieces - , rightPiece <- rightPieces - ] - generatedRegions = map convexPolygonRegion generated - convolutionEdges = sum (map (NonEmpty.length . convexPolygonPoints) generated) - (result, unionMetrics) <- unionRegions generatedRegions - let metrics = leftMetrics `appendMetrics` rightMetrics `appendMetrics` unionMetrics - pure - ( result - , MinkowskiReceipt - { minkowskiOperation = MinkowskiAddition - , minkowskiInputComponents = - length (planarRegionComponents left) - + length (planarRegionComponents right) - , minkowskiConvexPieces = length leftPieces + length rightPieces - , minkowskiGeneratedPieces = length generated - , minkowskiGeneratedConvolutionEdges = convolutionEdges - , minkowskiOverlayPasses = metricOverlayPasses metrics - , minkowskiExactCrossings = metricExactCrossings metrics - , minkowskiOutputCells = fromMaybe 0 (metricOutputCells metrics) - , minkowskiExactCoordinateBitGrowth = - coordinateBitGrowth [left, right] result - } - ) - --- | Erode a polygonal region by an origin-anchored convex kernel and publish --- the regularized full-dimensional result. A residual consisting only of --- points or segments is represented by 'emptyPlanarRegion'. -erodeBy - :: StructuringElement - -> PlanarRegion - -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) -erodeBy element source = - case singleConvexRegion source of - Just sourcePolygon -> convexErosion element source sourcePolygon - Nothing -> generalErosion element source - -openWith - :: StructuringElement - -> PlanarRegion - -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) -openWith element source = do - (eroded, erosionReceipt) <- erodeBy element source - (opened, additionReceipt) <- polygonOffset element eroded - pure - ( opened - , composeReceipts - MinkowskiOpening - (length (planarRegionComponents source)) - erosionReceipt - additionReceipt - ) - -closeWith - :: StructuringElement - -> PlanarRegion - -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) -closeWith element source = do - (expanded, additionReceipt) <- polygonOffset element source - (closed, erosionReceipt) <- erodeBy element expanded - pure - ( closed - , composeReceipts - MinkowskiClosing - (length (planarRegionComponents source)) - additionReceipt - erosionReceipt - ) - -polygonOffset - :: StructuringElement - -> PlanarRegion - -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) -polygonOffset element source = - minkowskiSum source (convexPolygonRegion (structuringElementPolygon element)) - -polygonInset - :: StructuringElement - -> PlanarRegion - -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) -polygonInset = erodeBy - -decomposeRegion - :: PlanarRegion - -> Either MinkowskiError ([ConvexPolygon], MorphologyMetrics) -decomposeRegion region = - case traverse convexComponent (planarRegionComponents region) of - Just convexPieces -> Right (convexPieces, emptyMetrics) - Nothing -> triangulatedPieces region - -convexComponent :: PolygonComponent -> Maybe ConvexPolygon -convexComponent component = - case polygonHoleLoops component of - [] -> admittedConvexLoop (polygonOuterLoop component) - _ -> Nothing - -singleConvexRegion :: PlanarRegion -> Maybe ConvexPolygon -singleConvexRegion region = - case planarRegionComponents region of - [component] -> convexComponent component - _ -> Nothing - -triangulatedPieces - :: PlanarRegion - -> Either MinkowskiError ([ConvexPolygon], MorphologyMetrics) -triangulatedPieces region = do - let sourceLayer = morphologyLayer region - result <- first MinkowskiOverlayFailed (overlayLayers sourceLayer emptyMorphologyLayer) - selectedFaces <- - filterM - ( fmap fst - . first MinkowskiOverlayCellWitness - . faceLabels result - ) - (innerFaces (overlayResultTriangulation result)) - pieces <- traverse (faceConvexPolygon result) selectedFaces - pure (pieces, metricsFromOverlay result (length pieces)) - -faceConvexPolygon - :: OverlayResult leftLabel rightLabel - -> FaceId - -> Either MinkowskiError ConvexPolygon -faceConvexPolygon result face = - case - map - (overlayExactPoint . vertexData triangulation) - (faceVertices triangulation face) of - [firstPoint, secondPoint, thirdPoint] -> - convexHullPolygon (firstPoint :| [secondPoint, thirdPoint]) - vertices -> Left (MinkowskiFaceArity face (length vertices)) - where - triangulation = overlayResultTriangulation result - -unionRegions - :: [PlanarRegion] - -> Either MinkowskiError (PlanarRegion, MorphologyMetrics) -unionRegions [] = Right (emptyPlanarRegion, emptyMetrics) -unionRegions [region] = - Right - ( region - , emptyMetrics{metricOutputCells = Just (length (planarRegionComponents region))} - ) -unionRegions regions = do - let (leftRegions, rightRegions) = splitAt (length regions `div` 2) regions - left <- unionRegions leftRegions - right <- unionRegions rightRegions - glueRegionUnion left right - -glueRegionUnion - :: (PlanarRegion, MorphologyMetrics) - -> (PlanarRegion, MorphologyMetrics) - -> Either MinkowskiError (PlanarRegion, MorphologyMetrics) -glueRegionUnion (left, leftMetrics) (right, rightMetrics) - | null (planarRegionComponents left) = Right (right, leftMetrics `appendMetrics` rightMetrics) - | null (planarRegionComponents right) = Right (left, leftMetrics `appendMetrics` rightMetrics) - | otherwise = do - result <- - first MinkowskiOverlayFailed - (overlayLayers (morphologyLayer left) (morphologyLayer right)) - published <- - first MinkowskiPublicationFailed - ( overlaySelectedRegion - (uncurry (||)) - result - ) - let selectedCells = - V.foldl' - (\count cell -> - case overlayCellGeometry cell of - BoundedOverlayCell _ - | overlayCellLeft cell || overlayCellRight cell -> - count + 1 - _ -> count) - 0 - (overlayResultCells result) - pure - ( published - , leftMetrics - `appendMetrics` rightMetrics - `appendMetrics` metricsFromOverlay result selectedCells - ) - -convexErosion - :: StructuringElement - -> PlanarRegion - -> ConvexPolygon - -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) -convexErosion element source sourcePolygon = do - eroded <- erodeConvexBy sourcePolygon (structuringElementPolygon element) - let result = maybe emptyPlanarRegion convexPolygonRegion eroded - outputCells = maybe 0 (const 1) eroded - generatedEdges = maybe 0 (NonEmpty.length . convexPolygonPoints) eroded - pure - ( result - , MinkowskiReceipt - { minkowskiOperation = MinkowskiErosion - , minkowskiInputComponents = 1 - , minkowskiConvexPieces = 2 - , minkowskiGeneratedPieces = outputCells - , minkowskiGeneratedConvolutionEdges = generatedEdges - , minkowskiOverlayPasses = 0 - , minkowskiExactCrossings = 0 - , minkowskiOutputCells = outputCells - , minkowskiExactCoordinateBitGrowth = - coordinateBitGrowth - [ source - , convexPolygonRegion (structuringElementPolygon element) - ] - result - } - ) - -generalErosion - :: StructuringElement - -> PlanarRegion - -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) -generalErosion element source - | null sourceEdges = Right (emptyPlanarRegion, emptyErosionReceipt) - | otherwise = do - sweptPolygons <- traverse (sweepBoundaryEdge reflectedKernel) sourceEdges - let sweptRegions = map convexPolygonRegion sweptPolygons - generatedEdges = - sum (map (NonEmpty.length . convexPolygonPoints) sweptPolygons) - (contactRegion, unionMetrics) <- unionRegions sweptRegions - candidateOverlay <- - first MinkowskiOverlayFailed - (overlayLayers (morphologyLayer contactRegion) emptyMorphologyLayer) - kernelWitness <- convexPolygonCentroid kernel - let representativeFaceByCell = representativeFaces candidateOverlay - selectedCellIds <- - Set.fromList - <$> filterM - ( classifyCandidateCell - source - kernelWitness - representativeFaceByCell - candidateOverlay - ) - (boundedOutsideCellIds candidateOverlay) - published <- publishCellSelection selectedCellIds candidateOverlay - let candidateMetrics = - metricsFromOverlay candidateOverlay (Set.size selectedCellIds) - metrics = unionMetrics `appendMetrics` candidateMetrics - pure - ( published - , MinkowskiReceipt - { minkowskiOperation = MinkowskiErosion - , minkowskiInputComponents = length (planarRegionComponents source) - , minkowskiConvexPieces = 1 - , minkowskiGeneratedPieces = length sweptPolygons - , minkowskiGeneratedConvolutionEdges = generatedEdges - , minkowskiOverlayPasses = metricOverlayPasses metrics - , minkowskiExactCrossings = metricExactCrossings metrics - , minkowskiOutputCells = Set.size selectedCellIds - , minkowskiExactCoordinateBitGrowth = - coordinateBitGrowth - [source, convexPolygonRegion kernel] - published - } - ) - where - kernel = structuringElementPolygon element - reflectedKernel = reflectConvexPolygon kernel - sourceEdges = regionBoundaryEdges source - emptyErosionReceipt = - MinkowskiReceipt - { minkowskiOperation = MinkowskiErosion - , minkowskiInputComponents = 0 - , minkowskiConvexPieces = 1 - , minkowskiGeneratedPieces = 0 - , minkowskiGeneratedConvolutionEdges = 0 - , minkowskiOverlayPasses = 0 - , minkowskiExactCrossings = 0 - , minkowskiOutputCells = 0 - , minkowskiExactCoordinateBitGrowth = 0 - } - -sweepBoundaryEdge - :: ConvexPolygon - -> (ExactPoint, ExactPoint) - -> Either MinkowskiError ConvexPolygon -sweepBoundaryEdge reflectedKernel (from, to) = - case convexPolygonPoints reflectedKernel of - firstKernelPoint :| remainingKernelPoints -> - convexHullPolygon - ( addExactPoints from firstKernelPoint - :| ( map (addExactPoints from) remainingKernelPoints - <> map (addExactPoints to) kernelPoints - ) - ) - where - kernelPoints = NonEmpty.toList (convexPolygonPoints reflectedKernel) - -boundedOutsideCellIds - :: OverlayResult Bool Bool - -> [OverlayCellId] -boundedOutsideCellIds result = - V.ifoldr - (\index cell selected -> - case overlayCellGeometry cell of - BoundedOverlayCell _ - | not (overlayCellLeft cell) - && not (overlayCellRight cell) -> - OverlayCellId index : selected - _ -> selected) - [] - (overlayResultCells result) - -classifyCandidateCell - :: PlanarRegion - -> ExactPoint - -> IntMap.IntMap FaceId - -> OverlayResult Bool Bool - -> OverlayCellId - -> Either MinkowskiError Bool -classifyCandidateCell source kernelWitness representativeFaceByCell result cellId = do - face <- - maybe - (Left (MinkowskiCandidateCellMissing cellId)) - Right - (IntMap.lookup (overlayCellIndex cellId) representativeFaceByCell) - candidate <- convexPolygonCentroid =<< faceConvexPolygon result face - let inclusionWitness = addExactPoints candidate kernelWitness - case regionPointLocation source inclusionWitness of - RegionInterior -> Right True - RegionExterior -> Right False - RegionOnBoundary -> Left (MinkowskiInclusionAmbiguous cellId inclusionWitness) - -representativeFaces - :: OverlayResult leftLabel rightLabel - -> IntMap.IntMap FaceId -representativeFaces result = - IntMap.fromListWith min - [ (overlayCellIndex (overlayFaceCellId (faceData triangulation face)), face) - | face <- innerFaces triangulation - ] - where - triangulation = overlayResultTriangulation result - -overlayCellIndex :: OverlayCellId -> Int -overlayCellIndex (OverlayCellId index) = index - -publishCellSelection - :: Set.Set OverlayCellId - -> OverlayResult leftLabel rightLabel - -> Either MinkowskiError PlanarRegion -publishCellSelection selected result = do - layer <- - first MinkowskiPublicationFailed - ( labelledPlanarLayerFromExactCoordinates - False - triangulation - (\vertex -> Right (overlayExactPoint (vertexData triangulation vertex))) - (\face -> - Right - ( Set.member - (overlayFaceCellId (faceData triangulation face)) - selected - )) - ) - pure (Map.findWithDefault emptyPlanarRegion True (planarLayerRegions layer)) - where - triangulation = overlayResultTriangulation result - -morphologyLayer - :: PlanarRegion - -> PlanarLayer Bool -morphologyLayer region = - planarLayerFromAdmittedComponents - False - [(True, component) | component <- planarRegionComponents region] - -emptyMorphologyLayer :: PlanarLayer Bool -emptyMorphologyLayer = morphologyLayer emptyPlanarRegion - -regionBoundaryEdges :: PlanarRegion -> [(ExactPoint, ExactPoint)] -regionBoundaryEdges region = - concatMap - (\component -> - concatMap - (cyclePairs . exactLoopPoints) - (polygonOuterLoop component : polygonHoleLoops component)) - (planarRegionComponents region) - -metricsFromOverlay - :: OverlayResult leftLabel rightLabel - -> Int - -> MorphologyMetrics -metricsFromOverlay result outputCells = - MorphologyMetrics - { metricOverlayPasses = 1 - , metricExactCrossings = overlayExactCrossings (overlayReceipt result) - , metricOutputCells = Just outputCells - } - -composeReceipts - :: MinkowskiOperation - -> Int - -> MinkowskiReceipt - -> MinkowskiReceipt - -> MinkowskiReceipt -composeReceipts operation inputComponents firstReceipt secondReceipt = - MinkowskiReceipt - { minkowskiOperation = operation - , minkowskiInputComponents = inputComponents - , minkowskiConvexPieces = - minkowskiConvexPieces firstReceipt - + minkowskiConvexPieces secondReceipt - , minkowskiGeneratedPieces = - minkowskiGeneratedPieces firstReceipt - + minkowskiGeneratedPieces secondReceipt - , minkowskiGeneratedConvolutionEdges = - minkowskiGeneratedConvolutionEdges firstReceipt - + minkowskiGeneratedConvolutionEdges secondReceipt - , minkowskiOverlayPasses = - minkowskiOverlayPasses firstReceipt - + minkowskiOverlayPasses secondReceipt - , minkowskiExactCrossings = - minkowskiExactCrossings firstReceipt - + minkowskiExactCrossings secondReceipt - , minkowskiOutputCells = minkowskiOutputCells secondReceipt - , minkowskiExactCoordinateBitGrowth = - max - (minkowskiExactCoordinateBitGrowth firstReceipt) - (minkowskiExactCoordinateBitGrowth secondReceipt) - } - -coordinateBitGrowth :: [PlanarRegion] -> PlanarRegion -> Int -coordinateBitGrowth inputs output = - max 0 - ( regionCoordinateBits output - - List.foldl' (\maximumBits -> max maximumBits . regionCoordinateBits) 0 inputs - ) - -regionCoordinateBits :: PlanarRegion -> Int -regionCoordinateBits = List.foldl' componentBits 0 . planarRegionComponents - where - componentBits maximumBits component = - List.foldl' - loopBits - maximumBits - (polygonOuterLoop component : polygonHoleLoops component) - loopBits maximumBits = - List.foldl' pointBits maximumBits . exactLoopPoints - pointBits maximumBits point = - let (x, y) = exactPointCoordinates point - in max maximumBits (max (rationalBits x) (rationalBits y)) - -rationalBits :: ExactRational -> Int -rationalBits value = - max - (integerBitLength (abs (exactRationalNumerator value))) - (integerBitLength (exactRationalDenominator value)) diff --git a/src-build/Moonlight/Triangulation/Overlay.hs b/src-build/Moonlight/Triangulation/Overlay.hs deleted file mode 100644 --- a/src-build/Moonlight/Triangulation/Overlay.hs +++ /dev/null @@ -1,291 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} - --- | Exact labelled common refinement. Source boundaries descend through one --- exact segment-event plan, glue into canonical atomic constraints, and are --- admitted only when their binary64 DCEL realization preserves every exact --- relation. -module Moonlight.Triangulation.Overlay - ( BoundaryLoopRef (..) - , OverlayOperand - , BoundaryVertexRef - , boundaryVertexComponent - , boundaryVertexLoop - , boundaryVertexLocalIndex - , BoundaryEdgeRef - , boundaryEdgeComponent - , boundaryEdgeLoop - , boundaryEdgeLocalIndex - , OverlayVertexOrigin - , overlayOriginLeftVertices - , overlayOriginRightVertices - , overlayOriginLeftEdges - , overlayOriginRightEdges - , OverlayEdgeOrigin - , overlayEdgeLeftSources - , overlayEdgeRightSources - , OverlaySupport - , overlaySupportLabels - , OverlayCellSupport (..) - , OverlayCellId (..) - , OverlayCellGeometry (..) - , OverlayCell (..) - , OverlayFace (..) - , OverlayVertex (..) - , OverlayEdge (..) - , OverlayReceipt (..) - , OverlayArrangementObstruction (..) - , OverlayCellWitness (..) - , OverlayError (..) - , OverlayResult - , OverlaySelectionKind (..) - , OverlaySelectionError (..) - , overlayLayers - , overlayEmbeddedTriangulation - , overlayReceipt - , overlayCells - , overlayArrangementVertices - , overlayArrangementEdges - , overlayPlanarLayer - , overlaySelectedRegion - , overlayClosedUnion - , overlayClosedIntersection - , overlayRegularizedDifference - ) where - -import Data.Bifunctor (first) -import Control.Monad (filterM) -import qualified Data.Map.Strict as Map -import qualified Data.Vector as V -import Moonlight.Triangulation.CellSet (ExactCellSet) -import qualified Moonlight.Triangulation.Dcel as Dcel -import Moonlight.Triangulation.Dcel (vertexData) -import Moonlight.Triangulation.Handles.HandleDefs - ( UndirectedEdgeId - , VertexId - ) -import Moonlight.Triangulation.Handles.Iterators.FixedIterators - ( innerFaces - , undirectedEdges - , vertices - ) -import Moonlight.Triangulation.Internal.CellSet (closeExactCellSetWith) -import Moonlight.Triangulation.Internal.Overlay.Arrangement - ( certifyArrangement - ) -import Moonlight.Triangulation.Internal.Overlay.Resident - ( OverlayDiagonalSchedule (CanonicalOverlayDiagonals) - , edgeSupport - , faceLabels - , regionFaceLabels - , residentOverlay - , vertexSupport - ) -import Moonlight.Triangulation.Internal.Overlay.Types -import Moonlight.Triangulation.Internal.Representation (Triangulation) -import Moonlight.Triangulation.Internal.Types - ( ConstraintMode (Constrained) - ) -import Moonlight.Triangulation.Region - ( PlanarLayer - , PlanarRegion - , RegionPublicationError (..) - , emptyPlanarRegion - , planarLayerOutsideLabel - , planarLayerRegions - ) -import Moonlight.Triangulation.Internal.Region.Publication - ( labelledPlanarLayerFromExactCoordinates - , planarLayerFromAdmittedComponents - ) - --- | Construct the exact common refinement and its one faithful resident DCEL. -overlayLayers - :: (Ord leftLabel, Ord rightLabel) - => PlanarLayer leftLabel - -> PlanarLayer rightLabel - -> Either - (OverlayError leftLabel rightLabel) - (OverlayResult leftLabel rightLabel) -overlayLayers leftLayer rightLayer = do - certified <- certifyArrangement leftLayer rightLayer - residentOverlay - CanonicalOverlayDiagonals - (planarLayerOutsideLabel leftLayer, planarLayerOutsideLabel rightLayer) - certified - --- | The binary64 realization used by existing DCEL observations. Exact overlay --- operations accept 'OverlayResult', never this projection. -overlayEmbeddedTriangulation - :: OverlayResult leftLabel rightLabel - -> Triangulation - 'Constrained - OverlayVertex - () - OverlayEdge - OverlayFace -overlayEmbeddedTriangulation = overlayResultTriangulation - -overlayReceipt :: OverlayResult leftLabel rightLabel -> OverlayReceipt -overlayReceipt = overlayResultReceipt - -overlayCells - :: OverlayResult leftLabel rightLabel - -> [(OverlayCellId, OverlayCell leftLabel rightLabel)] -overlayCells result = - V.toList - (V.imap (\index cell -> (OverlayCellId index, cell)) (overlayResultCells result)) - -overlayArrangementVertices - :: OverlayResult leftLabel rightLabel - -> [(VertexId, OverlayVertex)] -overlayArrangementVertices result = - let triangulation = overlayResultTriangulation result - in [(vertex, vertexData triangulation vertex) | vertex <- vertices triangulation] - -overlayArrangementEdges - :: OverlayResult leftLabel rightLabel - -> [(UndirectedEdgeId, OverlayEdgeOrigin)] -overlayArrangementEdges result = - let triangulation = overlayResultTriangulation result - in [ (edge, origin) - | edge <- undirectedEdges triangulation - , OverlayBoundary origin <- [Dcel.undirectedEdgeData triangulation edge] - ] - --- | Publish the already-admitted bounded cell geometry. The resident DCEL is --- a realization of these exact cells, not a second authoring source. -overlayPlanarLayer - :: (Ord leftLabel, Ord rightLabel) - => OverlayResult leftLabel rightLabel - -> PlanarLayer (leftLabel, rightLabel) -overlayPlanarLayer result = - planarLayerFromAdmittedComponents - (overlayResultOutsideLabels result) - [ ( (overlayCellLeft cell, overlayCellRight cell) - , component - ) - | cell <- V.toList (overlayResultCells result) - , (overlayCellLeft cell, overlayCellRight cell) - /= overlayResultOutsideLabels result - , BoundedOverlayCell component <- [overlayCellGeometry cell] - ] - --- | Publish the selected two-dimensional cells. Internal arrangement edges --- between differently labelled but jointly selected cells dissolve because --- selection precedes component descent. -overlaySelectedRegion - :: ((leftLabel, rightLabel) -> Bool) - -> OverlayResult leftLabel rightLabel - -> Either RegionPublicationError PlanarRegion -overlaySelectedRegion selected result - | selected (overlayResultOutsideLabels result) = Left RegionUnboundedSelection - | otherwise = do - published <- - labelledPlanarLayerFromExactCoordinates - False - triangulation - exactPointAt - labelFace - pure (Map.findWithDefault emptyPlanarRegion True (planarLayerRegions published)) - where - triangulation = overlayResultTriangulation result - exactPointAt vertex = Right (overlayExactPoint (vertexData triangulation vertex)) - labelFace face = - selected <$> regionFaceLabels result face - -overlayClosedUnion - :: (Ord leftLabel, Ord rightLabel) - => (leftLabel -> Bool) - -> (rightLabel -> Bool) - -> OverlayResult leftLabel rightLabel - -> Either OverlaySelectionError ExactCellSet -overlayClosedUnion selectLeft selectRight = - selectClosedCells - ClosedUnionSelection - (\support -> supportAny selectLeft (overlaySupportLeft support) || supportAny selectRight (overlaySupportRight support)) - (\leftLabel rightLabel -> selectLeft leftLabel || selectRight rightLabel) - -overlayClosedIntersection - :: (Ord leftLabel, Ord rightLabel) - => (leftLabel -> Bool) - -> (rightLabel -> Bool) - -> OverlayResult leftLabel rightLabel - -> Either OverlaySelectionError ExactCellSet -overlayClosedIntersection selectLeft selectRight = - selectClosedCells - ClosedIntersectionSelection - (\support -> supportAny selectLeft (overlaySupportLeft support) && supportAny selectRight (overlaySupportRight support)) - (\leftLabel rightLabel -> selectLeft leftLabel && selectRight rightLabel) - -overlayRegularizedDifference - :: (leftLabel -> Bool) - -> (rightLabel -> Bool) - -> OverlayResult leftLabel rightLabel - -> Either OverlaySelectionError ExactCellSet -overlayRegularizedDifference selectLeft selectRight result = - let outsidePair = overlayResultOutsideLabels result - selectFace leftLabel rightLabel = selectLeft leftLabel && not (selectRight rightLabel) - in if uncurry selectFace outsidePair - then Left (OverlaySelectionContainsUnboundedCell RegularizedDifferenceSelection) - else closeSelectedCells [] [] selectFace result - -selectClosedCells - :: (Ord leftLabel, Ord rightLabel) - => OverlaySelectionKind - -> (OverlayCellSupport leftLabel rightLabel -> Bool) - -> (leftLabel -> rightLabel -> Bool) - -> OverlayResult leftLabel rightLabel - -> Either OverlaySelectionError ExactCellSet -selectClosedCells selectionKind selectSupport selectFace result = - let outsidePair = overlayResultOutsideLabels result - triangulation = overlayResultTriangulation result - in if uncurry selectFace outsidePair - then Left (OverlaySelectionContainsUnboundedCell selectionKind) - else do - selectedVertices <- - filterM - ( fmap selectSupport - . first OverlaySelectionProvenance - . vertexSupport result - ) - (vertices triangulation) - selectedEdges <- - filterM - (\edge -> - case Dcel.undirectedEdgeData triangulation edge of - OverlayDiagonal -> Right False - OverlayBoundary _ -> - selectSupport - <$> first OverlaySelectionProvenance (edgeSupport result edge)) - (undirectedEdges triangulation) - closeSelectedCells selectedVertices selectedEdges selectFace result - -closeSelectedCells - :: [VertexId] - -> [UndirectedEdgeId] - -> (leftLabel -> rightLabel -> Bool) - -> OverlayResult leftLabel rightLabel - -> Either OverlaySelectionError ExactCellSet -closeSelectedCells selectedVertices selectedEdges selectFace result = - let triangulation = overlayResultTriangulation result - exactPointAt vertex = Right (overlayExactPoint (vertexData triangulation vertex)) - in do - selectedFaces <- - filterM - ( fmap (uncurry selectFace) - . first OverlaySelectionProvenance - . faceLabels result - ) - (innerFaces triangulation) - first OverlaySelectionInvalid - ( closeExactCellSetWith - exactPointAt - triangulation - selectedVertices - selectedEdges - selectedFaces - ) - -supportAny :: (label -> Bool) -> OverlaySupport label -> Bool -supportAny predicate = any predicate . overlaySupportLabels diff --git a/src-build/Moonlight/Triangulation/Refinement.hs b/src-build/Moonlight/Triangulation/Refinement.hs --- a/src-build/Moonlight/Triangulation/Refinement.hs +++ b/src-build/Moonlight/Triangulation/Refinement.hs @@ -11,7 +11,7 @@ , radiusEdgeRatioForAngle ) where -import Control.Monad.ST (ST, runST) +import Control.Monad.ST (ST) import Data.Foldable (traverse_) import qualified Data.IntSet as IntSet import Data.List (sort) @@ -30,15 +30,15 @@ , vertexPoint ) import Moonlight.Triangulation.FloodFillIterator (facesAtEvenBarrierDepth) -import Moonlight.Triangulation.Handles +import Moonlight.Triangulation.Handles.HandleDefs ( FaceId (..) , UndirectedEdgeId (..) , directedPair ) import Moonlight.Triangulation.Internal.Mutable -import Moonlight.Triangulation.Internal.Capacity (ensureCapacity) -import Moonlight.Triangulation.Internal.OperationState (freezeBuildStats, newOperationState) +import Moonlight.Triangulation.Internal.Paged (TransactionShape (DenseTransaction)) import Moonlight.Triangulation.Internal.Refinement +import Moonlight.Triangulation.Internal.Transaction (runTransaction) import Moonlight.Triangulation.Types import Moonlight.Triangulation.Validation (validateTopology) @@ -200,7 +200,6 @@ [] -> pure () let originalCount = numVertices triangulation budget = max 0 (fromMaybe (10 * max 1 originalCount) (refineMaxAdditionalVertices parameters)) - maximumVerticesInteger = toInteger originalCount + toInteger budget initialExcludedFaces = if refineExcludeOuterFaces parameters then @@ -212,19 +211,13 @@ (isConstraintEdge triangulation) ] else IntSet.empty - let maximumVertices = - if maximumVerticesInteger > toInteger (maxBound :: Int) - then maxBound - else fromInteger maximumVerticesInteger - ensureCapacity maximumVertices - runST $ do - mutable <- - thawTriangulationDense - maximumVertices - triangulation - operation <- newOperationState (halfEdgeCapacity mutable) + ( outcome + , frozen + , stats + ) <- + runTransaction id DenseTransaction triangulation budget $ \mutable operation -> do installInterfaceBarriers mutable domain - outcome <- + refinement <- refineMutable makeVertex mutable @@ -235,30 +228,22 @@ initialSeed domain removeInterfaceBarriers mutable triangulation domain - case outcome of - Left failure -> pure (Left failure) - Right (complete, added, excluded, visited, interfaceBoundaryReads, boundaryCrossingAttempts) -> do - frozenOutcome <- freezeTriangulation mutable - case frozenOutcome of - Left obstruction -> pure (Left obstruction) - Right frozen -> do - stats <- freezeBuildStats operation - pure - ( Right - RefinementExecution - { refinementExecutionResult = - RefinementResult - { refinedTriangulation = frozen - , refinementStats = stats - , refinementAddedVertices = added - , refinementComplete = complete - , refinementExcludedFaces = V.fromList (map (FaceId . fromIntegral) excluded) - } - , refinementExecutionVisitedFaces = visited - , refinementExecutionInterfaceBoundaryReads = interfaceBoundaryReads - , refinementExecutionBoundaryCrossingAttempts = boundaryCrossingAttempts - } - ) + pure refinement + let (complete, added, excluded, visited, interfaceBoundaryReads, boundaryCrossingAttempts) = outcome + pure + RefinementExecution + { refinementExecutionResult = + RefinementResult + { refinedTriangulation = frozen + , refinementStats = stats + , refinementAddedVertices = added + , refinementComplete = complete + , refinementExcludedFaces = V.fromList (map (FaceId . fromIntegral) excluded) + } + , refinementExecutionVisitedFaces = visited + , refinementExecutionInterfaceBoundaryReads = interfaceBoundaryReads + , refinementExecutionBoundaryCrossingAttempts = boundaryCrossingAttempts + } installInterfaceBarriers :: MutableDcel s vertex directed undirected face diff --git a/src-capi/Moonlight/Triangulation/Foreign/Exports.hs b/src-capi/Moonlight/Triangulation/Foreign/Exports.hs --- a/src-capi/Moonlight/Triangulation/Foreign/Exports.hs +++ b/src-capi/Moonlight/Triangulation/Foreign/Exports.hs @@ -3,32 +3,73 @@ module Moonlight.Triangulation.Foreign.Exports where +import Data.Int (Int64) import Data.Word (Word32) -import Foreign.C.Types (CDouble, CSize (..), CUInt (..)) +import Foreign.C.Types (CChar, CDouble (..), CSize (..), CUInt (..)) import Foreign.Ptr (Ptr) -import Moonlight.Triangulation.Foreign.ABI (CObstruction) +import Moonlight.Triangulation.Foreign.ABI + ( CMesh + , CMinkowskiReceipt + , CObstruction + , CRegion + , CStructuringElement + ) import qualified Moonlight.Triangulation.Foreign.ABI as ABI delaunayF64 = ABI.delaunayF64 meshInsertManyF64 = ABI.meshInsertManyF64 -meshUnion = ABI.meshUnion -meshIntersection = ABI.meshIntersection -meshDifference = ABI.meshDifference -meshSymmetricDifference = ABI.meshSymmetricDifference +meshSiteUnion = ABI.meshSiteUnion +meshSiteIntersection = ABI.meshSiteIntersection +meshSiteDifference = ABI.meshSiteDifference +meshSiteSymmetricDifference = ABI.meshSiteSymmetricDifference meshVertexCount = ABI.meshVertexCount meshTriangleCount = ABI.meshTriangleCount meshCopyVerticesF64 = ABI.meshCopyVerticesF64 meshCopyTrianglesU32 = ABI.meshCopyTrianglesU32 meshFree = ABI.meshFree +regionCreateF64 = ABI.regionCreateF64 +regionCounts = ABI.regionCounts +regionCopyF64 = ABI.regionCopyF64 +regionUnion = ABI.regionUnion +regionIntersection = ABI.regionIntersection +regionDifference = ABI.regionDifference +regionSymmetricDifference = ABI.regionSymmetricDifference +regionLocatePointF64 = ABI.regionLocatePointF64 +regionMeasure = ABI.regionMeasure +regionFree = ABI.regionFree +structuringElementCreateF64 = ABI.structuringElementCreateF64 +structuringElementFree = ABI.structuringElementFree +regionMinkowskiSum = ABI.regionMinkowskiSum +regionOffset = ABI.regionOffset +regionInset = ABI.regionInset +regionOpen = ABI.regionOpen +regionClose = ABI.regionClose -foreign export ccall "ml_delaunay_f64" delaunayF64 :: Ptr CDouble -> CSize -> Ptr (Ptr ()) -> Ptr CObstruction -> IO CUInt -foreign export ccall "ml_mesh_insert_many_f64" meshInsertManyF64 :: Ptr () -> Ptr CDouble -> CSize -> Ptr (Ptr ()) -> Ptr CObstruction -> IO CUInt -foreign export ccall "ml_mesh_union" meshUnion :: Ptr () -> Ptr () -> Ptr (Ptr ()) -> Ptr CObstruction -> IO CUInt -foreign export ccall "ml_mesh_intersection" meshIntersection :: Ptr () -> Ptr () -> Ptr (Ptr ()) -> Ptr CObstruction -> IO CUInt -foreign export ccall "ml_mesh_difference" meshDifference :: Ptr () -> Ptr () -> Ptr (Ptr ()) -> Ptr CObstruction -> IO CUInt -foreign export ccall "ml_mesh_symmetric_difference" meshSymmetricDifference :: Ptr () -> Ptr () -> Ptr (Ptr ()) -> Ptr CObstruction -> IO CUInt -foreign export ccall "ml_mesh_vertex_count" meshVertexCount :: Ptr () -> Ptr CSize -> Ptr CObstruction -> IO CUInt -foreign export ccall "ml_mesh_triangle_count" meshTriangleCount :: Ptr () -> Ptr CSize -> Ptr CObstruction -> IO CUInt -foreign export ccall "ml_mesh_copy_vertices_f64" meshCopyVerticesF64 :: Ptr () -> Ptr CDouble -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt -foreign export ccall "ml_mesh_copy_triangles_u32" meshCopyTrianglesU32 :: Ptr () -> Ptr Word32 -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt -foreign export ccall "ml_mesh_free" meshFree :: Ptr () -> IO () +foreign export ccall "ml_delaunay_f64" delaunayF64 :: Ptr CDouble -> CSize -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_insert_many_f64" meshInsertManyF64 :: Ptr CMesh -> Ptr CDouble -> CSize -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_site_union" meshSiteUnion :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_site_intersection" meshSiteIntersection :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_site_difference" meshSiteDifference :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_site_symmetric_difference" meshSiteSymmetricDifference :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_vertex_count" meshVertexCount :: Ptr CMesh -> Ptr CSize -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_triangle_count" meshTriangleCount :: Ptr CMesh -> Ptr CSize -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_copy_vertices_f64" meshCopyVerticesF64 :: Ptr CMesh -> Ptr CDouble -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_copy_triangles_u32" meshCopyTrianglesU32 :: Ptr CMesh -> Ptr Word32 -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_mesh_free" meshFree :: Ptr CMesh -> IO () +foreign export ccall "ml_region_create_f64" regionCreateF64 :: Ptr CDouble -> CSize -> Ptr CSize -> CSize -> Ptr CSize -> CSize -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_counts" regionCounts :: Ptr CRegion -> Ptr CSize -> Ptr CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_copy_f64" regionCopyF64 :: Ptr CRegion -> Ptr CDouble -> CSize -> Ptr CSize -> CSize -> Ptr CSize -> CSize -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_union" regionUnion :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_intersection" regionIntersection :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_difference" regionDifference :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_symmetric_difference" regionSymmetricDifference :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_locate_point_f64" regionLocatePointF64 :: Ptr CRegion -> CDouble -> CDouble -> Ptr CUInt -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_measure" regionMeasure :: Ptr CRegion -> Ptr Int64 -> Ptr CChar -> CSize -> Ptr CSize -> Ptr CDouble -> Ptr CDouble -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_free" regionFree :: Ptr CRegion -> IO () +foreign export ccall "ml_structuring_element_create_f64" structuringElementCreateF64 :: Ptr CDouble -> CSize -> Ptr (Ptr CStructuringElement) -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_structuring_element_free" structuringElementFree :: Ptr CStructuringElement -> IO () +foreign export ccall "ml_region_minkowski_sum" regionMinkowskiSum :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_offset" regionOffset :: Ptr CStructuringElement -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_inset" regionInset :: Ptr CStructuringElement -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_open" regionOpen :: Ptr CStructuringElement -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt +foreign export ccall "ml_region_close" regionClose :: Ptr CStructuringElement -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt diff --git a/src-cell-complex/Moonlight/Triangulation/CellComplex.hs b/src-cell-complex/Moonlight/Triangulation/CellComplex.hs new file mode 100644 --- /dev/null +++ b/src-cell-complex/Moonlight/Triangulation/CellComplex.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE EmptyDataDeriving #-} + +-- | The admitted Moonlight triangulation cell section as a generic +-- 'CellComplex2D'. The 'ExactCellSet' remains the semantic owner: this module +-- only supplies the incidence interpretation required by downstream topology. +module Moonlight.Triangulation.CellComplex + ( DCELComplex, + DCELError, + fromExactCellSet, + ) +where + +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet qualified as IntSet +import Moonlight.Algebra.Pure.Orientation (Orientation (..)) +import Moonlight.Homology.Pure.Topology.CellComplex + ( CellComplex2D (..), + CellTypes (..), + OrientedEdge (..), + ValidateComplex2D (..), + ) +import Moonlight.Triangulation.Dcel qualified as Dcel +import Moonlight.Triangulation.Handles.HandleDefs + ( FaceId (..), + UndirectedEdgeId (..), + VertexId (..), + asUndirected, + directedPair, + isNormalized, + ) +import Moonlight.Triangulation.Internal.CellSet (ExactCellSet (..)) +import Moonlight.Triangulation.Types (Triangulation) + +-- | An incidence view of one already-validated, downward-closed exact cell +-- selection. It deliberately has no independent cell inventory. +newtype DCELComplex = DCELComplex ExactCellSet + +-- | 'ExactCellSet' construction discharges every closure and handle +-- obligation before this view exists, so there are no residual validation +-- failures for the adapter to manufacture. +data DCELError + deriving stock (Eq, Show) + +fromExactCellSet :: ExactCellSet -> DCELComplex +fromExactCellSet = DCELComplex + +instance CellTypes DCELComplex where + type Vertex DCELComplex = VertexId + type Edge DCELComplex = UndirectedEdgeId + type Face DCELComplex = FaceId + +instance CellComplex2D DCELComplex where + vertices (DCELComplex (ExactCellSet _ selectedVertices _ _)) = + fmap (VertexId . fromIntegral) (IntMap.keys selectedVertices) + + edges (DCELComplex (ExactCellSet _ _ selectedEdges _)) = + fmap (UndirectedEdgeId . fromIntegral) (IntSet.toAscList selectedEdges) + + faces (DCELComplex (ExactCellSet _ _ _ selectedFaces)) = + fmap (FaceId . fromIntegral) (IntSet.toAscList selectedFaces) + + edgeBoundary (DCELComplex (ExactCellSet triangulation _ _ _)) = + Dcel.undirectedEndpoints triangulation + + faceBoundary (DCELComplex (ExactCellSet triangulation _ _ _)) face = + fmap orientedBoundaryEdge (Dcel.faceDirectedEdges triangulation face) + where + orientedBoundaryEdge directedEdge = + OrientedEdge + { orientedEdge = asUndirected directedEdge, + edgeOrientation = + if isNormalized directedEdge + then Positive + else Negative + } + + edgesAtVertex complexValue@(DCELComplex (ExactCellSet triangulation _ _ _)) vertex = + filter (edgeContainsVertex triangulation vertex) (edges complexValue) + + facesAtEdge (DCELComplex (ExactCellSet triangulation _ _ selectedFaces)) edge = + let (forward, backward) = directedPair edge + selectedIncidentFace directedEdge = + let face@(FaceId rawFace) = Dcel.incidentFace triangulation directedEdge + in if IntSet.member (fromIntegral rawFace) selectedFaces + then Just face + else Nothing + in (selectedIncidentFace forward, selectedIncidentFace backward) + +instance ValidateComplex2D DCELComplex where + type ValidationIssue DCELComplex = DCELError + validateComplex _ = [] + +edgeContainsVertex :: + Triangulation mode vertex directed undirected face -> + VertexId -> + UndirectedEdgeId -> + Bool +edgeContainsVertex triangulation vertex edge = + let (sourceVertex, targetVertex) = Dcel.undirectedEndpoints triangulation edge + in vertex == sourceVertex || vertex == targetVertex 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 @@ -25,7 +25,7 @@ import GHC.Generics (Generic) -- | A checked wrapper around a reduced ratio with a strictly positive --- denominator. 'Data.Ratio' owns normalization, including the unique zero +-- denominator. 'Ratio' owns normalization, including the unique zero -- representation @0 / 1@. newtype ExactRational = ExactRational (Ratio Integer) deriving stock (Eq, Ord, Show, Generic) diff --git a/src-core/Moonlight/Triangulation/Scalar.hs b/src-core/Moonlight/Triangulation/Scalar.hs --- a/src-core/Moonlight/Triangulation/Scalar.hs +++ b/src-core/Moonlight/Triangulation/Scalar.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fllvm -optlo-O3 -optlc-O3 #-} +{-# OPTIONS_GHC -O3 -fllvm -optlo-O3 -optlc-O3 #-} -- | The binary64 coordinate kernel and exact predicate boundary. module Moonlight.Triangulation.Scalar @@ -86,6 +86,7 @@ :: Double -> Double -> Double -> Double -> Double -> Double -> Ordering orient2dCoordinates = filteredOrient2dDouble +{-# INLINE orient2dCoordinates #-} -- | Exact in-circle ordering of four binary64 coordinate pairs. inCircleCoordinates @@ -93,6 +94,7 @@ -> Double -> Double -> Double -> Double -> Ordering inCircleCoordinates = filteredInCircle scalarInCircleErrorBound +{-# INLINE inCircleCoordinates #-} -- | Closed exact circumradius membership at a finite, non-negative binary64 -- threshold. Invalid thresholds and collinear triples are outside. diff --git a/src-dcel/Moonlight/Triangulation/FloodFillIterator.hs b/src-dcel/Moonlight/Triangulation/FloodFillIterator.hs --- a/src-dcel/Moonlight/Triangulation/FloodFillIterator.hs +++ b/src-dcel/Moonlight/Triangulation/FloodFillIterator.hs @@ -25,14 +25,18 @@ , facesAtEvenBarrierDepth , FaceComponent , faceComponentFaces + , BoundaryOrientation (..) , BoundaryLoop + , boundaryLoopOrientation , boundaryLoopVertices , RegionBoundary , regionBoundaryOuterLoop , regionBoundaryHoleLoops , BoundaryObstruction (..) , faceComponents + , faceComponentsBy , labelledRegionBoundaries + , componentBoundaryLoops , componentBoundary , RadiusSquared , mkRadiusSquared @@ -46,13 +50,19 @@ import Data.List (partition, unfoldr) import qualified Data.List as List import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq +import qualified Data.Set as Set import qualified Data.Vector as V import GHC.Generics (Generic) import Moonlight.Triangulation.Dcel import Moonlight.Triangulation.Handles.HandleDefs import Moonlight.Triangulation.Handles.Iterators.FixedIterators (undirectedEdges) -import Moonlight.Triangulation.Internal.BoundaryCycle (simplifyBoundaryCycle) +import Moonlight.Triangulation.Internal.BoundaryCycle + ( simplifyBoundaryCycle + , traceOrientedBoundaryCircuits + ) import Moonlight.Triangulation.Math import Moonlight.Triangulation.PointLocation import Moonlight.Triangulation.Scalar (circumradiusSquaredWithinCoordinates) @@ -68,10 +78,18 @@ faceComponentFaces (FaceComponent faces) = fmap (FaceId . fromIntegral) (IntSet.toAscList faces) --- | One non-empty simple boundary loop. Outer loops are counter-clockwise and --- hole loops clockwise. -newtype BoundaryLoop = BoundaryLoop - { boundaryLoopVertices :: NonEmpty VertexId +-- | Winding carried explicitly by a simple boundary loop. +data BoundaryOrientation + = BoundaryCounterClockwise + | BoundaryClockwise + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +-- | One non-empty simple boundary loop. Counter-clockwise loops contribute +-- filled area under nonzero winding; clockwise loops subtract holes. +data BoundaryLoop = BoundaryLoop + { boundaryLoopOrientation :: !BoundaryOrientation + , boundaryLoopVertices :: !(NonEmpty VertexId) } deriving stock (Eq, Show, Generic) deriving anyclass (NFData) @@ -84,7 +102,8 @@ deriving stock (Eq, Show, Generic) deriving anyclass (NFData) --- | Typed failure to descend boundary half-edges into simple polygon loops. +-- | Typed failure to descend boundary half-edges or project their oriented +-- loops into one strict polygon component. data BoundaryObstruction = BoundaryComponentFaceOutOfRange !FaceId {-# UNPACK #-} !Int | BoundaryPinch !VertexId !DirectedEdgeId !DirectedEdgeId @@ -94,6 +113,15 @@ deriving stock (Eq, Show, Generic) deriving anyclass (NFData) +-- | Complete boundary edges refined by whether each vertex has one successor. +data BoundaryGraph + = SimpleBoundaryGraph !IntSet.IntSet !(IntMap.IntMap DirectedEdgeId) + | PinchedBoundaryGraph + !IntSet.IntSet + !VertexId + !DirectedEdgeId + !DirectedEdgeId + -- | An admitted finite, non-negative squared radius. newtype RadiusSquared = RadiusSquared Double deriving stock (Eq, Ord, Show, Generic) @@ -292,15 +320,46 @@ => Triangulation mode vertex directed undirected face -> (FaceId -> label) -> [(label, FaceComponent)] -faceComponents triangulation labelFace = unfoldr descend initialUnvisited +faceComponents triangulation labelFace = + faceComponentsFromLabels triangulation labelAt (const True) where labels = V.generate (numInnerFaces triangulation) (\index -> labelFace (FaceId (fromIntegral (index + 1)))) + labelAt faceIndex = labels V.!? (faceIndex - 1) + +-- | Connected components over a selected face section and admitted adjacency. +-- A missing label removes a face from the section; the edge predicate states +-- which overlaps glue. This is the common descent used by ordinary labelled +-- regions and exact-overlay charts whose representation diagonals alone may +-- connect collapsed resident faces. +faceComponentsBy + :: Eq label + => Triangulation mode vertex directed undirected face + -> (FaceId -> Maybe label) + -> (UndirectedEdgeId -> Bool) + -> [(label, FaceComponent)] +faceComponentsBy triangulation labelFace = + faceComponentsFromLabels triangulation labelAt + where + labels = + V.generate + (numInnerFaces triangulation) + (\index -> labelFace (FaceId (fromIntegral (index + 1)))) + labelAt faceIndex = labels V.!? (faceIndex - 1) >>= id + +faceComponentsFromLabels + :: Eq label + => Triangulation mode vertex directed undirected face + -> (Int -> Maybe label) + -> (UndirectedEdgeId -> Bool) + -> [(label, FaceComponent)] +faceComponentsFromLabels triangulation labelAt canCross = + unfoldr descend initialUnvisited + where initialUnvisited = IntSet.fromRange (1, numFaces triangulation - 1) - labelAt faceIndex = labels V.!? (faceIndex - 1) descend remaining = case IntSet.minView remaining of @@ -332,7 +391,8 @@ admitAdjacent componentLabel (queued, unvisited) edge = if - adjacent /= outerFace + canCross (asUndirected edge) + && adjacent /= outerFace && IntSet.member adjacentIndex unvisited && labelAt adjacentIndex == Just componentLabel then @@ -344,6 +404,7 @@ adjacent@(FaceId adjacentRaw) = incidentFace triangulation (reverseEdge edge) adjacentIndex = fromIntegral adjacentRaw +{-# INLINE faceComponentsFromLabels #-} -- | Descend every equally labelled bounded-face component through the one -- authoritative boundary tracer. Components are converted independently; @@ -358,14 +419,47 @@ (\(label, component) -> (label,) <$> componentBoundary triangulation component) (faceComponents triangulation labelFace) --- | Extract all simple boundary loops of a component from the DCEL. Boundary --- half-edges retain their incident component face on the left; this gives the --- outer loop counter-clockwise and holes clockwise without a later guess. +-- | Extract the non-empty oriented boundary chain of one component. Boundary +-- half-edges retain their incident component face on the left. If several +-- boundary arms meet at one vertex, Euler descent consumes every half-edge +-- once and repeated-vertex splitting publishes finitely many simple loops. +componentBoundaryLoops + :: Triangulation mode vertex directed undirected face + -> FaceComponent + -> Either BoundaryObstruction (NonEmpty BoundaryLoop) +componentBoundaryLoops triangulation component = do + graph <- componentBoundaryGraph triangulation component + loops <- + case graph of + SimpleBoundaryGraph edges outgoing -> + traceBoundaryLoops triangulation outgoing edges + PinchedBoundaryGraph edges _ _ _ -> + tracePinchedBoundaryLoops triangulation edges + case NonEmpty.nonEmpty loops of + Just nonEmptyLoops -> Right nonEmptyLoops + Nothing -> Left (BoundaryOuterLoopCardinality 0) + +-- | Project one component into a strict polygon boundary. A pinched oriented +-- chain remains available through 'componentBoundaryLoops', but it is not one +-- lawful 'RegionBoundary' and is refused here with its first pinch witness. componentBoundary :: Triangulation mode vertex directed undirected face -> FaceComponent -> Either BoundaryObstruction RegionBoundary -componentBoundary triangulation (FaceComponent componentFaces) = do +componentBoundary triangulation component = do + graph <- componentBoundaryGraph triangulation component + case graph of + PinchedBoundaryGraph _ vertex firstEdge secondEdge -> + Left (BoundaryPinch vertex firstEdge secondEdge) + SimpleBoundaryGraph edges outgoing -> + traceBoundaryLoops triangulation outgoing edges + >>= regionBoundaryFromLoops + +componentBoundaryGraph + :: Triangulation mode vertex directed undirected face + -> FaceComponent + -> Either BoundaryObstruction BoundaryGraph +componentBoundaryGraph triangulation (FaceComponent componentFaces) = case IntSet.lookupGE (numFaces triangulation) componentFaces of Just invalid -> Left @@ -373,16 +467,55 @@ (FaceId (fromIntegral invalid)) (numFaces triangulation) ) - Nothing -> Right () - (boundaryEdges, outgoingSuccessor) <- - IntSet.foldl' - collectFaceBoundaryEdges - (Right (IntSet.empty, IntMap.empty)) - componentFaces - orientedLoops <- traceBoundaryLoops triangulation outgoingSuccessor boundaryEdges - let (outer, holes) = partition ((== GT) . fst) orientedLoops - outerLoops = fmap snd outer - holeLoops = fmap snd holes + Nothing -> + Right + ( IntSet.foldl' + collectFace + (SimpleBoundaryGraph IntSet.empty IntMap.empty) + componentFaces + ) + where + collectFace graph (face :: Int) = + foldFaceDirectedEdges' + triangulation + (FaceId (fromIntegral face)) + insertBoundaryEdge + graph + + insertBoundaryEdge graph edge + | IntSet.member adjacentIndex componentFaces = graph + | otherwise = + case graph of + PinchedBoundaryGraph edges pinchVertex firstEdge secondEdge -> + PinchedBoundaryGraph + (insertEdge edges) + pinchVertex + firstEdge + secondEdge + SimpleBoundaryGraph edges outgoing -> + case IntMap.lookup vertexIndex outgoing of + Nothing -> + SimpleBoundaryGraph + (insertEdge edges) + (IntMap.insert vertexIndex edge outgoing) + Just previousEdge -> + PinchedBoundaryGraph + (insertEdge edges) + vertex + previousEdge + edge + where + FaceId adjacent = incidentFace triangulation (reverseEdge edge) + adjacentIndex = fromIntegral adjacent + vertex@(VertexId rawVertex) = origin triangulation edge + vertexIndex = fromIntegral rawVertex + DirectedEdgeId rawEdge = edge + insertEdge = IntSet.insert (fromIntegral rawEdge) + +regionBoundaryFromLoops + :: [BoundaryLoop] + -> Either BoundaryObstruction RegionBoundary +regionBoundaryFromLoops loops = case outerLoops of [outerLoop] -> Right @@ -392,35 +525,44 @@ } _ -> Left (BoundaryOuterLoopCardinality (length outerLoops)) where - collectFaceBoundaryEdges boundaryGraph face = - foldFaceDirectedEdges' - triangulation - (FaceId (fromIntegral face)) - insertBoundaryEdge - boundaryGraph + (outerLoops, holeLoops) = + partition + ((== BoundaryCounterClockwise) . boundaryLoopOrientation) + loops - insertBoundaryEdge outcome edge = do - graph@(edges, successors) <- outcome - let FaceId adjacent = incidentFace triangulation (reverseEdge edge) - if IntSet.member (fromIntegral adjacent) componentFaces - then Right graph - else - let vertex@(VertexId rawVertex) = origin triangulation edge - vertexIndex = fromIntegral rawVertex - DirectedEdgeId rawEdge = edge - in case IntMap.lookup vertexIndex successors of - Just previousEdge -> Left (BoundaryPinch vertex previousEdge edge) - Nothing -> - Right - ( IntSet.insert (fromIntegral rawEdge) edges - , IntMap.insert vertexIndex edge successors - ) +tracePinchedBoundaryLoops + :: Triangulation mode vertex directed undirected face + -> IntSet.IntSet + -> Either BoundaryObstruction [BoundaryLoop] +tracePinchedBoundaryLoops triangulation boundaryEdges = do + cycles <- + traceOrientedBoundaryCircuits + (origin triangulation) + (destination triangulation) + BoundaryCycleDidNotClose + outgoingByVertex + orientedEdges + traverse + (simplifyBoundaryLoop triangulation . NonEmpty.toList) + cycles + where + orientedEdges = + Set.fromDistinctAscList + ( fmap + (DirectedEdgeId . fromIntegral) + (IntSet.toAscList boundaryEdges) + ) + outgoingByVertex = + Set.foldr + (\edge -> Map.insertWith (<>) (origin triangulation edge) [edge]) + Map.empty + orientedEdges traceBoundaryLoops :: Triangulation mode vertex directed undirected face -> IntMap.IntMap DirectedEdgeId -> IntSet.IntSet - -> Either BoundaryObstruction [(Ordering, BoundaryLoop)] + -> Either BoundaryObstruction [BoundaryLoop] traceBoundaryLoops triangulation outgoingByVertex = descend [] where descend loops unvisited = @@ -429,8 +571,8 @@ Just (rawStart, _) -> do let start = DirectedEdgeId (fromIntegral rawStart) (vertices, remaining) <- traceCycle start start unvisited [] - oriented <- simplifyBoundaryLoop triangulation vertices - descend (oriented : loops) remaining + loop <- simplifyBoundaryLoop triangulation vertices + descend (loop : loops) remaining traceCycle start current unvisited reversedVertices = let DirectedEdgeId rawCurrent = current @@ -449,10 +591,19 @@ simplifyBoundaryLoop :: Triangulation mode vertex directed undirected face -> [VertexId] - -> Either BoundaryObstruction (Ordering, BoundaryLoop) -simplifyBoundaryLoop triangulation = - fmap (\(orientation, vertices) -> (orientation, BoundaryLoop vertices)) - . simplifyBoundaryCycle BoundaryLoopDegenerate redundant winding key + -> Either BoundaryObstruction BoundaryLoop +simplifyBoundaryLoop triangulation vertices = do + (windingOrder, simplifiedVertices) <- + simplifyBoundaryCycle + BoundaryLoopDegenerate + redundant + winding + key + vertices + case windingOrder of + GT -> Right (BoundaryLoop BoundaryCounterClockwise simplifiedVertices) + LT -> Right (BoundaryLoop BoundaryClockwise simplifiedVertices) + EQ -> Left (BoundaryLoopDegenerate (NonEmpty.toList simplifiedVertices)) where point vertex = vertexPoint triangulation vertex redundant previousVertex current nextVertex = diff --git a/src-dcel/Moonlight/Triangulation/Handles.hs b/src-dcel/Moonlight/Triangulation/Handles.hs deleted file mode 100644 --- a/src-dcel/Moonlight/Triangulation/Handles.hs +++ /dev/null @@ -1,11 +0,0 @@ --- | The handle surface as one import: identifiers, their dynamic views, and --- the iterator family. -module Moonlight.Triangulation.Handles - ( module Moonlight.Triangulation.Handles.HandleDefs - , module Moonlight.Triangulation.Handles.Dynamic - , module Moonlight.Triangulation.Handles.Iterators - ) where - -import Moonlight.Triangulation.Handles.Dynamic -import Moonlight.Triangulation.Handles.HandleDefs -import Moonlight.Triangulation.Handles.Iterators diff --git a/src-dcel/Moonlight/Triangulation/Handles/Iterators.hs b/src-dcel/Moonlight/Triangulation/Handles/Iterators.hs deleted file mode 100644 --- a/src-dcel/Moonlight/Triangulation/Handles/Iterators.hs +++ /dev/null @@ -1,13 +0,0 @@ --- | The iterator family over a mesh: whole-mesh ranges, incidence fans, the --- circular walk they are built from, and the hull. -module Moonlight.Triangulation.Handles.Iterators - ( module Moonlight.Triangulation.Handles.Iterators.CircularIterator - , module Moonlight.Triangulation.Handles.Iterators.DynamicIterators - , module Moonlight.Triangulation.Handles.Iterators.FixedIterators - , module Moonlight.Triangulation.Handles.Iterators.HullIterator - ) where - -import Moonlight.Triangulation.Handles.Iterators.CircularIterator -import Moonlight.Triangulation.Handles.Iterators.DynamicIterators -import Moonlight.Triangulation.Handles.Iterators.FixedIterators -import Moonlight.Triangulation.Handles.Iterators.HullIterator 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 @@ -1,8 +1,8 @@ --- | The shared algebra for simplifying and classifying an already-traced --- boundary cycle. Topology traversal remains in 'FloodFillIterator'; this --- module owns only fixed-point collinear deletion and winding observation. +-- | Shared pure algebra for descending oriented boundary graphs into simple +-- cycles, then simplifying and classifying those cycles. module Moonlight.Triangulation.Internal.BoundaryCycle - ( simplifyBoundaryCycle + ( traceOrientedBoundaryCircuits + , simplifyBoundaryCycle , rotateCycleLeast , rotateCycleLeastBy , consecutivePairs @@ -13,10 +13,128 @@ , cyclicTriples ) where -import Data.List.NonEmpty (NonEmpty (..)) import Data.List (tails) import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import qualified Data.Set as Set +import Data.Set (Set) + +-- | Consume every supplied oriented edge exactly once and split point contacts +-- into vertex-simple cycles. The outgoing lists carry the caller's required +-- local angular or identifier order. A malformed graph is translated directly +-- through the caller's obstruction constructor; this shared worker owns no +-- disposable error vocabulary. +traceOrientedBoundaryCircuits + :: (Ord vertex, Ord edge) + => (edge -> vertex) + -> (edge -> vertex) + -> (edge -> edge -> obstruction) + -> Map vertex [edge] + -> Set edge + -> Either obstruction [NonEmpty vertex] +traceOrientedBoundaryCircuits edgeOrigin edgeDestination obstruction outgoing edges = + descend edges [] + where + descend remaining cycles = + case Set.lookupMin remaining of + Nothing -> Right (reverse cycles) + Just seed -> + let (untraced, circuitEdges) = + eulerCircuit remaining (edgeOrigin seed) + in case NonEmpty.nonEmpty circuitEdges of + Nothing -> Left (obstruction seed seed) + Just circuit -> + case splitCircuit circuit of + Left failedEdge -> Left (obstruction seed failedEdge) + Right splitCycles -> + descend + untraced + (reverse (NonEmpty.toList splitCycles) <> cycles) + + -- Hierholzer descent: delete each chosen edge, then prepend it while + -- backtracking. No graph-state stream or branch search is materialized. + eulerCircuit remaining start = walk remaining start [] [] + where + walk untraced current incomingEdges circuit = + case + List.find + (`Set.member` untraced) + (Map.findWithDefault [] current outgoing) of + Just edge -> + walk + (Set.delete edge untraced) + (edgeDestination edge) + (edge : incomingEdges) + circuit + Nothing -> + case incomingEdges of + edge : previousEdges -> + walk + untraced + (edgeOrigin edge) + previousEdges + (edge : circuit) + [] -> (untraced, circuit) + + -- The resident path stays simple. Closing at a resident vertex emits and + -- removes exactly that suffix, partitioning the Euler circuit into cycles. + splitCircuit circuit = + walk + start + 0 + (Map.singleton start 0) + [] + [] + (NonEmpty.toList circuit) + where + start = edgeOrigin (NonEmpty.head circuit) + + walk current depth depths reversedEdges cycles remaining = + case remaining of + [] -> + case + ( depth + , reversedEdges + , NonEmpty.nonEmpty (reverse cycles) + ) of + (0, [], Just simpleCycles) -> Right simpleCycles + _ -> Left (NonEmpty.last circuit) + edge : rest + | edgeOrigin edge /= current -> Left edge + | otherwise -> + let target = edgeDestination edge + in case Map.lookup target depths of + Nothing -> + walk + target + (depth + 1) + (Map.insert target (depth + 1) depths) + (edge : reversedEdges) + cycles + rest + Just repeatedDepth -> + let suffixLength = depth - repeatedDepth + suffixEdges = take suffixLength reversedEdges + simpleCycle = + fmap edgeOrigin + ( NonEmpty.reverse + (edge :| suffixEdges) + ) + in walk + target + repeatedDepth + ( foldr + (Map.delete . edgeDestination) + depths + suffixEdges + ) + (drop suffixLength reversedEdges) + (simpleCycle : cycles) + rest +{-# INLINABLE traceOrientedBoundaryCircuits #-} -- | Remove precisely the vertices admitted by @isRedundant@ until a fixed -- point is reached, then classify the winding at the least keyed retained diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations.hs deleted file mode 100644 --- a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- | The topology-mutating primitives, gathered from their role modules. -module Moonlight.Triangulation.Internal.DcelOperations - ( setupFirstVertex - , setupSecondVertex - , splitLineEdge - , extendLine - , lineToArea - , insertIntoFace - , insertOnEdge - , ReservedSweepCells - , SweepCellCursor - , SweepInsertion (..) - , reserveSweepCells - , initialSweepCellCursor - , commitReservedSweepConnections - , insertOutsideHull - , insertOutsideHullAtEdge - , closeOuterTurn - , closeOuterTurnReserved - , fixHullConvexity - , flipEdge - , legalizeScratch - , legalizeStarEdge - , legalizeEdges - , legalizeCavityFanScratch - , LegalizationLaw (..) - , seedStarScratch - , seedGenericEdges - , drainLegalization - , CandidateDiscipline (..) - , isFlippableEdge - , collectLineChain - ) where - -import Moonlight.Triangulation.Internal.DcelOperations.CandidateArena - ( CandidateDiscipline (..) - , seedGenericEdges - , seedStarScratch - ) -import Moonlight.Triangulation.Internal.DcelOperations.Chain - ( collectLineChain - , extendLine - , lineToArea - , setupFirstVertex - , setupSecondVertex - , splitLineEdge - ) -import Moonlight.Triangulation.Internal.DcelOperations.FlipRewrite (flipEdge) -import Moonlight.Triangulation.Internal.DcelOperations.FlipRule - ( LegalizationLaw (..) - , isFlippableEdge - ) -import Moonlight.Triangulation.Internal.DcelOperations.Hull - ( ReservedSweepCells - , SweepCellCursor - , SweepInsertion (..) - , closeOuterTurn - , closeOuterTurnReserved - , commitReservedSweepConnections - , fixHullConvexity - , initialSweepCellCursor - , insertOutsideHull - , insertOutsideHullAtEdge - , reserveSweepCells - ) -import Moonlight.Triangulation.Internal.DcelOperations.Legalize - ( legalizeCavityFanScratch - , legalizeEdges - , legalizeScratch - , legalizeStarEdge - ) -import Moonlight.Triangulation.Internal.DcelOperations.Normalize (drainLegalization) -import Moonlight.Triangulation.Internal.DcelOperations.Subdivide - ( insertIntoFace - , insertOnEdge - ) diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/CandidateArena.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/CandidateArena.hs --- a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/CandidateArena.hs +++ b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/CandidateArena.hs @@ -21,6 +21,7 @@ ( LegalizationArena (..) , OperationState , legalizationArena + , legalizationArenaLength , readScratch , storeLegalizationArena ) @@ -89,7 +90,3 @@ where !current = MUV.length values {-# INLINE growLegalizationArena #-} - -legalizationArenaLength :: LegalizationArena s -> Int -legalizationArenaLength (LegalizationArena values) = MUV.length values -{-# INLINE legalizationArenaLength #-} diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRule.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRule.hs --- a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRule.hs +++ b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/FlipRule.hs @@ -11,10 +11,10 @@ , diagonalFires , illegalDiagonal , isFlippableEdge - , orderedPair ) where import Control.Monad.ST (ST) +import Moonlight.Triangulation.Internal.BoundaryCycle (orderedPair) import Moonlight.Triangulation.Internal.DcelOperations.Twin (reverseIndex) import Moonlight.Triangulation.Internal.Mutable ( MutableDcel @@ -124,9 +124,3 @@ data LegalizationLaw = ValidMesh | CavityRepair {-# UNPACK #-} !Int - -orderedPair :: Ord a => a -> a -> (a, a) -orderedPair left right - | left <= right = (left, right) - | otherwise = (right, left) -{-# INLINE orderedPair #-} diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Hull.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Hull.hs --- a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Hull.hs +++ b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Hull.hs @@ -4,7 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fllvm -optlo-O3 -optlc-O3 #-} +{-# OPTIONS_GHC -O3 -fllvm -optlo-O3 -optlc-O3 #-} -- | Growth outside the hull: visible ranges, turn closure, and convexity repair. module Moonlight.Triangulation.Internal.DcelOperations.Hull diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Legalize.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Legalize.hs --- a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Legalize.hs +++ b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Legalize.hs @@ -4,7 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fllvm -optlo-O3 -optlc-O3 #-} +{-# OPTIONS_GHC -O3 -fllvm -optlo-O3 -optlc-O3 #-} -- | The seeding entry points that drive one legalization epoch. module Moonlight.Triangulation.Internal.DcelOperations.Legalize @@ -42,6 +42,7 @@ , OperationState , addCounter , legalizationArena + , legalizationArenaLength , maxCounter , readScratch , storeLegalizationArena @@ -134,7 +135,3 @@ MUV.unsafeWrite values 0 (packIndex edge) drainDenseUnconstrainedStarLegalization dense arena 1 vertex {-# NOINLINE legalizeDenseStarEdgeInArena #-} - -legalizationArenaLength :: LegalizationArena s -> Int -legalizationArenaLength (LegalizationArena values) = MUV.length values -{-# INLINE legalizationArenaLength #-} diff --git a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Normalize.hs b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Normalize.hs --- a/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Normalize.hs +++ b/src-dcel/Moonlight/Triangulation/Internal/DcelOperations/Normalize.hs @@ -4,7 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fllvm -optlo-O3 -optlc-O3 #-} +{-# OPTIONS_GHC -O3 -fllvm -optlo-O3 -optlc-O3 #-} -- | The normalization procedure of the flip rewrite system. module Moonlight.Triangulation.Internal.DcelOperations.Normalize @@ -41,6 +41,7 @@ , LegalizationArena (..) , OperationState , legalizationArena + , legalizationArenaLength , storeLegalizationArena ) import Moonlight.Triangulation.Internal.PackedIndex (packIndex) @@ -347,7 +348,3 @@ GenericCandidates ValidMesh {-# INLINE drainDenseUnconstrainedGenericLegalization #-} - -legalizationArenaLength :: LegalizationArena s -> Int -legalizationArenaLength (LegalizationArena values) = MUV.length values -{-# INLINE legalizationArenaLength #-} diff --git a/src-dcel/Moonlight/Triangulation/Internal/Mutable.hs b/src-dcel/Moonlight/Triangulation/Internal/Mutable.hs --- a/src-dcel/Moonlight/Triangulation/Internal/Mutable.hs +++ b/src-dcel/Moonlight/Triangulation/Internal/Mutable.hs @@ -211,6 +211,11 @@ -- | Tight fresh planar capacity. Circle sweep allocates monotonically and no -- rewrite abandons a cell, so Euler's bounds plus seed slack are authoritative: -- at most @6n@ directed edges and @2n@ faces. +-- +-- The separated seam merge is the second lawful caller. It copies two planar +-- sources and then only adds: stitching creates seam cells, legalization +-- rewires without allocating, and nothing is abandoned. Its peak is therefore +-- its published result, a planar triangulation on the summed vertex count. planarDcelCapacity :: Int -> DcelCapacity planarDcelCapacity maximumVertices = let !vertices = max 1 maximumVertices diff --git a/src-dcel/Moonlight/Triangulation/Internal/OperationState.hs b/src-dcel/Moonlight/Triangulation/Internal/OperationState.hs --- a/src-dcel/Moonlight/Triangulation/Internal/OperationState.hs +++ b/src-dcel/Moonlight/Triangulation/Internal/OperationState.hs @@ -15,6 +15,7 @@ , OperationState , newOperationState , legalizationArena + , legalizationArenaLength , storeLegalizationArena , writeScratch , readScratch @@ -127,6 +128,10 @@ legalizationArena :: OperationState s -> ST s (LegalizationArena s) legalizationArena = readSTRef . osLegalizationArena {-# INLINE legalizationArena #-} + +legalizationArenaLength :: LegalizationArena s -> Int +legalizationArenaLength (LegalizationArena values) = MUV.length values +{-# INLINE legalizationArenaLength #-} storeLegalizationArena :: OperationState s -> LegalizationArena s -> ST s () storeLegalizationArena = writeSTRef . osLegalizationArena diff --git a/src-dcel/Moonlight/Triangulation/Validation.hs b/src-dcel/Moonlight/Triangulation/Validation.hs --- a/src-dcel/Moonlight/Triangulation/Validation.hs +++ b/src-dcel/Moonlight/Triangulation/Validation.hs @@ -14,6 +14,7 @@ import Data.List (nub) import qualified Data.IntSet as IntSet import Moonlight.Triangulation.Internal.BoxedPaged (boxedPagedLength) +import Moonlight.Triangulation.Internal.BoundaryCycle (orderedPair) import Moonlight.Triangulation.Internal.Paged (pagedFoldl', pagedLength, pagedUnsafeIndex) import Moonlight.Triangulation.Dcel import Moonlight.Triangulation.Handles.HandleDefs @@ -264,6 +265,3 @@ where angle left right opposite = acos (clamp ((left * left + right * right - opposite * opposite) / (2 * left * right))) * 180 / pi clamp = max (-1) . min 1 - -orderedPair :: Ord a => a -> a -> (a, a) -orderedPair a b = if a <= b then (a, b) else (b, a) 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 @@ -27,6 +27,7 @@ , ValuationError (..) , cellValuations , regionValuations + , planarValuationsPerimeter , cellSetPerimeter , regionPerimeter ) where @@ -226,18 +227,20 @@ -> Either ValuationError ExactLengthMeasurement cellSetPerimeter cellSet | exactCellSetIsFaceClosure cellSet = - cellValuations cellSet >>= conventionalPerimeter + cellValuations cellSet >>= planarValuationsPerimeter | otherwise = Left ValuationCellSetNotPureRegion regionPerimeter :: PlanarRegion -> Either ValuationError ExactLengthMeasurement -regionPerimeter region = regionValuations region >>= conventionalPerimeter +regionPerimeter region = regionValuations region >>= planarValuationsPerimeter -conventionalPerimeter +-- | Derive conventional boundary length from an already-computed intrinsic +-- valuation without traversing the source geometry again. +planarValuationsPerimeter :: PlanarValuations -> Either ValuationError ExactLengthMeasurement -conventionalPerimeter valuations = +planarValuationsPerimeter valuations = measureLength (scaleLengthExpression 2 (exactLengthExpression (valuationIntrinsic1 valuations))) diff --git a/src-dual/Moonlight/Triangulation/HintGenerator.hs b/src-dual/Moonlight/Triangulation/HintGenerator.hs deleted file mode 100644 --- a/src-dual/Moonlight/Triangulation/HintGenerator.hs +++ /dev/null @@ -1,492 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} - --- | Reusable point-location hints and their topology-preserving maintenance. -module Moonlight.Triangulation.HintGenerator - ( LastUsedHint - , emptyLastUsedHint - , lastUsedHint - , rememberVertex - , HierarchyHint - , defaultHierarchyBranchFactor - , buildHierarchyHint - , hierarchyHint - , hierarchyBranchFactor - , hierarchyBaseCount - , hierarchyLevelCount - , hierarchyVertexCount - , updateHierarchyAfterInsertion - , updateHierarchyAfterRemoval - , rebuildHierarchyHint - , removeManyWithHierarchy - ) where - -import qualified Data.Vector as V -import Control.DeepSeq (NFData) -import Data.List (sort) -import Data.Word (Word32) -import Moonlight.Triangulation.BulkLoad (delaunay, insert) -import Moonlight.Triangulation.Dcel (numUndirectedEdges, numVertices, undirectedEndpoints, vertexPoint) -import Moonlight.Triangulation.Handles.HandleDefs (UndirectedEdgeId (..), VertexId (..)) -import Moonlight.Triangulation.Interpolation (nearestNeighbor) -import Moonlight.Triangulation.Math (canonicalPoint, validatePoint) -import Moonlight.Triangulation.Removal (RemovalOutcome, removalTriangulation, removeVertex) -import Moonlight.Triangulation.Session (removeManyAtNear, withSession) -import Moonlight.Triangulation.Types -import GHC.Generics (Generic) - --- | Most recently admitted vertex, suitable as the next descent seed. -newtype LastUsedHint = LastUsedHint (Maybe VertexId) - deriving stock (Show) - deriving newtype (Eq, Ord) - --- | A last-used hint with no remembered vertex. -emptyLastUsedHint :: LastUsedHint -emptyLastUsedHint = LastUsedHint Nothing - --- | Project a remembered vertex into a location hint. -lastUsedHint :: LastUsedHint -> Maybe LocationHint -lastUsedHint (LastUsedHint vertex) = VertexHint <$> vertex - --- | Replace the remembered vertex. -rememberVertex :: VertexId -> LastUsedHint -> LastUsedHint -rememberVertex vertex _ = LastUsedHint (Just vertex) - --- | A Delaunay hierarchy for logarithmic expected random point location. --- The first vector element is the finest sparse level; the final element is --- the coarsest. The base triangulation is not duplicated. --- --- The levels are nested by a single arithmetic law rather than by a stored --- correspondence. Level @i@ holds every @branch^(i+1)@-th base vertex in base --- order, so a level-local handle @j@ names handle @j * branch@ one level finer --- — and at level 0 the finer level is the base mesh itself, under the very --- same multiplication. Descent therefore never rediscovers a handle it has --- already computed, and no level carries an index vector. --- --- 'hierarchyBaseCount' is the base cardinality the levels were sampled from. --- It is the hierarchy's claim about which triangulation it answers for, and --- every maintenance entry is stated against it: a base whose cardinality is not --- the one recorded here plus the movement the operation performs is not the --- base this hierarchy describes, and is rebuilt for rather than patched. -data HierarchyHint = HierarchyHint - { hierarchyBranchFactor :: {-# UNPACK #-} !Int - -- ^ Sampling stride between adjacent hierarchy levels. - , hierarchyBaseCount :: {-# UNPACK #-} !Int - -- ^ Cardinality of the base mesh described by the hierarchy. - , hierarchyLevels :: !(V.Vector (Triangulation 'Unconstrained (Point) () () ())) - } - deriving stock (Generic) - deriving anyclass (NFData) - -instance Show (HierarchyHint) where - showsPrec precedence hierarchy = - showParen (precedence > 10) $ - showString "HierarchyHint " - . shows (hierarchyBranchFactor hierarchy) - . showString " " - . shows (hierarchyBaseCount hierarchy) - . showString " " - . shows (hierarchyLevelCount hierarchy) - . showString " " - . shows (hierarchyVertexCount hierarchy) - -instance Eq (HierarchyHint) where - left == right = - hierarchyBranchFactor left == hierarchyBranchFactor right - && hierarchyBaseCount left == hierarchyBaseCount right - && hierarchyLevelCount left == hierarchyLevelCount right - && V.and (V.zipWith sameSparseMesh (hierarchyLevels left) (hierarchyLevels right)) - --- Two sparse levels are the same hint when they carry the same points and the --- same undirected edges. Half-edge index labelling records the order --- construction happened to visit, so a level rebuilt from scratch and a level --- extended in place are structurally equal while their arrays are not. -sameSparseMesh - :: Triangulation 'Unconstrained (Point) () () () - -> Triangulation 'Unconstrained (Point) () () () - -> Bool -sameSparseMesh left right = - numVertices left == numVertices right - && numUndirectedEdges left == numUndirectedEdges right - && meshPoints left == meshPoints right - && meshEdges left == meshEdges right - where - meshPoints - :: Triangulation mode vertex directed undirected face - -> [Point] - meshPoints triangulation = - sort [vertexPoint triangulation (VertexId (fromIntegral index)) | index <- [0 .. numVertices triangulation - 1]] - - meshEdges - :: Triangulation mode vertex directed undirected face - -> [(Point, Point)] - meshEdges triangulation = - sort - [ if from <= to then (from, to) else (to, from) - | index <- [0 .. numUndirectedEdges triangulation - 1] - , let (fromVertex, toVertex) = undirectedEndpoints triangulation (UndirectedEdgeId (fromIntegral index)) - from = vertexPoint triangulation fromVertex - to = vertexPoint triangulation toVertex - ] - --- | Default sampling stride between hierarchy levels. -defaultHierarchyBranchFactor :: Int -defaultHierarchyBranchFactor = 16 - --- | Number of stored sparse levels. -hierarchyLevelCount :: HierarchyHint -> Int -hierarchyLevelCount = V.length . hierarchyLevels - --- | Total vertices retained across every sparse level. -hierarchyVertexCount :: HierarchyHint -> Int -hierarchyVertexCount = - V.foldl' (\total level -> total + numVertices level) 0 . hierarchyLevels - --- | Build nested sparse Delaunay levels. A branch factor of 16 mirrors Spade's --- default and gives O(log n) expected descent on uniformly distributed input. --- --- Each level is bulk loaded from the sampled points in base order. Base --- vertices carry pairwise distinct positions, so the load deduplicates nothing --- and assigns local handle @j@ to sample @j@ — which is what makes the nesting --- law on 'hierarchyLevels' an identity rather than a lookup. -buildHierarchyHint - :: Int - -> Triangulation mode vertex directed undirected face - -> Either BuildError (HierarchyHint) -buildHierarchyHint requestedBranch triangulation = - HierarchyHint branch count <$> V.mapM buildLevel levelDivisors - where - !branch = max 2 requestedBranch - !count = numVertices triangulation - levelDivisors = - V.unfoldr - (\candidate -> - case candidate of - Nothing -> Nothing - Just divisor -> - let !population = samplePopulation count divisor - next = - if population <= 1 - then Nothing - else Just (safeMultiply divisor branch) - in Just (divisor, next) - ) - (if count <= 0 then Nothing else Just branch) - - buildLevel divisor = - buildTriangulation - <$> delaunay - unitElementDefaults - ( V.generate - (samplePopulation count divisor) - (\index -> - vertexPoint - triangulation - (VertexId (fromIntegral (index * divisor))) - ) - ) - --- | Descend from the coarsest sparse triangulation. The handle a level returns --- is carried to the next finer level by one multiplication, and the same --- multiplication at level 0 names the base vertex. Nothing is relocated: the --- coarse answer is not searched for again, it is computed. -hierarchyHint :: HierarchyHint -> QueryPoint -> Maybe LocationHint -hierarchyHint HierarchyHint{hierarchyBranchFactor, hierarchyLevels} query = - VertexHint <$> descend (V.length hierarchyLevels - 1) Nothing - where - !branch = fromIntegral hierarchyBranchFactor :: Word32 - - descend !levelIndex !coarse - | levelIndex < 0 = Nothing - | otherwise = - case nearestNeighbor (hierarchyLevels V.! levelIndex) coarse query of - Nothing -> Nothing - Just (VertexId local, _) -> - let !finer = VertexId (local * branch) - in if levelIndex == 0 then Just finer else descend (levelIndex - 1) (Just finer) - - --- | Update the nested hierarchy from an insertion's own report: the point the --- insertion was asked for, the handle it answered, and whether it created a --- site. Only the levels selected by the branch divisibility rule are changed. --- Unaffected levels are structurally shared. --- --- No triangulation is named. The hierarchy walks its own levels and nothing --- else, so a base was only ever a lookup table for three facts — its --- cardinality, the stored position of the new vertex, and the position of --- vertex zero — and every one of them is in the report or already in the --- levels, because level-local handle zero is base handle zero at every level. --- A caller maintaining the hierarchy across a run of insertions therefore --- never has to publish a mesh to be allowed to speak to it, which is the whole --- cost of the arrangement this replaces: one full arena copy per step, paid --- only to name the thing that was just edited. --- --- An insertion that found its point already present created no site, and a --- hierarchy valid for a triangulation is valid for that same triangulation, so --- the answer is the argument, unexamined. -updateHierarchyAfterInsertion - :: HierarchyHint - -> Point - -> VertexId - -> InsertionDisposition - -> Either BuildError (HierarchyHint) -updateHierarchyAfterInsertion hierarchy requested vertex disposition = - case disposition of - AlreadyPresent -> Right hierarchy - Inserted - | vertexIndex vertex /= baseIndex -> - Left - ( HierarchyInsertionHandleMismatch - (VertexId (fromIntegral baseIndex)) - vertex - ) - | otherwise -> do - updated <- updateLevels branch (V.toList (hierarchyLevels hierarchy)) - topped <- ensureSingletonTop updated - pure - hierarchy - { hierarchyBaseCount = baseIndex + 1 - , hierarchyLevels = V.fromList topped - } - where - !branch = hierarchyBranchFactor hierarchy - !baseIndex = hierarchyBaseCount hierarchy - -- A level holds what the mesh stores, not what the caller wrote: storage - -- rounds a signed zero, and a level built from the unrounded point would - -- settle a distance tie against a different handle. - !point = canonicalPoint requested - - -- An update is the only operation that can break the nesting law, so the law - -- is stated here as an equation rather than trusted: a level admitted to the - -- new base vertex must already hold exactly @baseIndex / divisor@ samples, - -- and must receive the vertex at its end. - updateLevels !_ [] = Right [] - updateLevels !divisor levels@(level : rest) - | baseIndex `rem` divisor /= 0 = Right levels - | safeMultiply (numVertices level) divisor /= baseIndex = - Left - ( HierarchyLevelPopulationMismatch - divisor - (numVertices level) - baseIndex - ) - | otherwise = do - inserted <- insert level point - if vertexIndex (insertionVertex inserted) /= numVertices level - then - Left - ( HierarchyInsertionHandleMismatch - (VertexId (fromIntegral (numVertices level))) - (insertionVertex inserted) - ) - else (insertionTriangulation inserted :) <$> updateLevels (safeMultiply divisor branch) rest - - -- With no levels at all the base was empty, so the vertex just appended is - -- vertex zero. Otherwise vertex zero is the finest level's local vertex - -- zero, under the same law that makes the descent a multiplication. - ensureSingletonTop [] = pure <$> singletonLevel point - ensureSingletonTop levels@(finest : _) = - case reverse levels of - top : _ - | numVertices top <= 1 -> Right levels - | otherwise -> - (\first -> levels ++ [first]) - <$> singletonLevel (vertexPoint finest (VertexId 0)) - [] -> Right levels - --- | Repair the nested hierarchy from a removal's swap report — the slot --- compaction freed and the position of the vertex it moved into that slot, or --- 'Nothing' when the removal took the last vertex and compaction moved --- nothing — rather than rebuilding because removal renumbers. --- --- No triangulation is named, for the reason 'updateHierarchyAfterInsertion' --- gives: the only base position this repair cannot find in its own levels is --- the relocated vertex's, and that is what the report carries. --- --- Swap compaction moves exactly one vertex — the former last one, into the slot --- the removed vertex vacated — so a level's sample sequence changes in at most --- one place, and which place is decided by the two divisibilities the level's --- divisor gives the freed slot and the vacated last index: --- --- * neither is sampled: the level, and every coarser level above it, is --- untouched, because a divisor that divides neither index is divided by no --- multiple of itself either; --- * the vacated index is sampled and the freed slot is not: the level loses its --- last sample and nothing else; --- * both are sampled: the level loses its last sample and that sample's point --- lands in the freed slot's local position — which is the level's own swap --- removal, mirroring the base's; --- * the freed slot is sampled and the vacated index is not: the level keeps its --- population and substitutes the relocated position at an interior local --- slot. No removal expresses a substitution, so that level is rebuilt — from --- its own points and the reported one, never from a mesh. --- --- The last case is the only one that pays a build, and it is the rarest: it --- needs the freed slot to be sampled and the vacated index not to be. -updateHierarchyAfterRemoval - :: HierarchyHint - -> Maybe (VertexId, Point) - -> Either BuildError (HierarchyHint) -updateHierarchyAfterRemoval hierarchy swap - | baseCount <= 0 = Left (RemovalEmptyTriangulation (maybe (VertexId 0) fst swap)) - | otherwise = do - repaired <- repairLevels branch (V.toList (hierarchyLevels hierarchy)) - pure - hierarchy - { hierarchyBaseCount = surviving - , hierarchyLevels = V.fromList (levelsThroughSingleton repaired) - } - where - !branch = hierarchyBranchFactor hierarchy - !baseCount = hierarchyBaseCount hierarchy - !surviving = baseCount - 1 - -- The freed slot is the removed vertex's own index, and it is where the - -- former last vertex now stands. A removal that took the last vertex frees - -- no slot and reports none, and its removed index is that last index. - !freedSlot = maybe surviving (vertexIndex . fst) swap - !vacatedIndex = surviving - - -- The nesting law is stated here as an equation for the same reason the - -- insertion path states it: a repair is the other operation that can break - -- it. A level the removal reaches must hold exactly the samples the - -- pre-removal base owed it. - repairLevels !_ [] = Right [] - repairLevels !divisor levels@(level : rest) - | not freedSampled && not vacatedSampled = Right levels - | numVertices level /= population = - Left - ( HierarchyLevelPopulationMismatch - divisor - (numVertices level) - baseCount - ) - | otherwise = - case swap of - -- The two divisibilities differ only when the two indices do, so a - -- level reaching the substitution has a relocation to substitute: - -- the guard cannot hold while compaction moved nothing. - Just (_, relocated) - | freedSampled && not vacatedSampled -> do - substituted <- substituteSample level (freedSlot `quot` divisor) relocated - (substituted :) <$> repairLevels (safeMultiply divisor branch) rest - _ -> do - shrunk <- removeVertex level (VertexId (fromIntegral localSample)) - (removalTriangulation shrunk :) <$> repairLevels (safeMultiply divisor branch) rest - where - !freedSampled = freedSlot `rem` divisor == 0 - !vacatedSampled = vacatedIndex `rem` divisor == 0 - !population = samplePopulation baseCount divisor - !localSample - | freedSampled = freedSlot `quot` divisor - | otherwise = population - 1 - - -- A build stops at the first level holding one sample, and removal only - -- shrinks populations, so the shape a rebuild would answer with is this list - -- cut after its first singleton. - levelsThroughSingleton - :: [Triangulation mode vertex directed undirected face] - -> [Triangulation mode vertex directed undirected face] - levelsThroughSingleton [] = [] - levelsThroughSingleton (level : rest) - | numVertices level <= 0 = [] - | numVertices level <= 1 = [level] - | otherwise = level : levelsThroughSingleton rest - --- | The coarsest level a growing hierarchy needs: one sample, the base's --- vertex zero. -singletonLevel - :: Point - -> Either BuildError (Triangulation 'Unconstrained (Point) () () ()) -singletonLevel origin = - buildTriangulation <$> delaunay unitElementDefaults (V.singleton origin) - --- | The level a substitution asks for: the same samples in the same local --- order, one slot carrying the relocated position instead of the one that --- left. Stated over the level's own points, so no mesh is consulted. -substituteSample - :: Triangulation 'Unconstrained (Point) () () () - -> Int - -> Point - -> Either BuildError (Triangulation 'Unconstrained (Point) () () ()) -substituteSample level localSlot relocated = - buildTriangulation - <$> delaunay - unitElementDefaults - ( V.generate - (numVertices level) - (\index -> - if index == localSlot - then relocated - else vertexPoint level (VertexId (fromIntegral index)) - ) - ) - --- | Rebuild a hierarchy after an operation that may renumber vertices, such as --- removal. The branch factor remains canonical. -rebuildHierarchyHint - :: HierarchyHint - -> Triangulation mode vertex directed undirected face - -> Either BuildError (HierarchyHint) -rebuildHierarchyHint hierarchy = buildHierarchyHint (hierarchyBranchFactor hierarchy) - --- | Remove many points, each locate starting from the hierarchy's nearest --- sample instead of the mesh boundary. One session publishes once; the --- hierarchy is rebuilt against the surviving mesh and returned alongside it. -removeManyWithHierarchy - :: HierarchyHint - -> Triangulation mode vertex directed undirected face - -> V.Vector (Point) - -> Either - BuildError - ( V.Vector (Maybe (RemovalOutcome vertex)) - , Triangulation mode vertex directed undirected face - , HierarchyHint - ) -removeManyWithHierarchy hierarchy triangulation points = do - queryPoints <- traverse (validatePoint Nothing) points - let guesses = fmap hierarchyGuess queryPoints - (outcomes, surviving, _) <- - withSession triangulation 0 (removeManyAtNear guesses points) - repaired <- rebuildHierarchyHint hierarchy surviving - pure (outcomes, surviving, repaired) - where - hierarchyGuess queryPoint = - case hierarchyHint hierarchy queryPoint of - Just (VertexHint vertex) -> Just vertex - _ -> Nothing - -safeMultiply :: Int -> Int -> Int -safeMultiply left right - | left > maxBound `quot` right = maxBound - | otherwise = left * right - --- | How many samples a divisor takes from a base of this size. Sampling takes --- index zero and every @divisor@-th index after it; the direct --- vector generator above states the same ceiling without constructing an --- intermediate handle list. -samplePopulation :: Int -> Int -> Int -samplePopulation count divisor - | count <= 0 = 0 - | otherwise = 1 + (count - 1) `quot` divisor - -vertexIndex :: VertexId -> Int -vertexIndex (VertexId value) = fromIntegral value - --- The hierarchy is consulted once per query from another package, so its --- polymorphic entries expose their unfoldings for the same reason the search --- itself does. --- --- The two level constructors are listed for a second reason, and the list is --- not complete without them: they are overloaded and the entries call them, so --- an entry specialised in the consumer that reaches an unspecialised --- constructor threads the dictionary right back into the build it was --- specialised to avoid. Only a stable unfolding is a specialisation candidate --- across a package boundary; the optimised one GHC publishes on its own is not. --- These two were 'where' bindings before they were named, and a 'where' binding --- is specialised with the function that encloses it — so naming them is what --- put the dictionary in, and this is what takes it back out. diff --git a/src-embedding/Moonlight/Triangulation/Internal/Overlay/Embedding.hs b/src-embedding/Moonlight/Triangulation/Internal/Overlay/Embedding.hs deleted file mode 100644 --- a/src-embedding/Moonlight/Triangulation/Internal/Overlay/Embedding.hs +++ /dev/null @@ -1,502 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} - --- | Bounded certification of local binary64 embedding obligations for a --- declared exact arrangement draft. -module Moonlight.Triangulation.Internal.Overlay.Embedding - ( DraftVertexId (..) - , DraftSegmentId (..) - , DraftSourceId (..) - , DraftIncidence (..) - , DraftNeighborhood (..) - , ExactArrangementDraft (..) - , DraftReference (..) - , OverlayEmbeddingObstruction (..) - , EmbeddingObligation (..) - , EmbeddingResidual - , residualUndischargedObligations - , milestoneOneResidual - , LocalEmbeddingCertificate (..) - , certifyLocalEmbedding - ) where - -import Control.DeepSeq (NFData) -import Data.List (sort, tails) -import 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 - , exactOrient2d - , exactPointToEmbeddingCandidate - , exactSegmentRelation - ) -import Moonlight.Triangulation.Internal.BoundaryCycle (cyclePairs) -import Moonlight.Triangulation.Internal.ExactRational (ExactRational) -import qualified Moonlight.Triangulation.Math as Math - ( orient2d - , segmentRelation - ) -import Moonlight.Triangulation.Types - ( Point (..) - , PointValidationError - ) - --- | Draft-local vertex label. -newtype DraftVertexId = DraftVertexId Int - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - --- | Draft-local atomic-segment label. -newtype DraftSegmentId = DraftSegmentId Int - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - --- | Draft-local source-segment label. -newtype DraftSourceId = DraftSourceId Int - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - --- | A declared relation between two atomic draft segments. -data DraftIncidence = DraftIncidence - { -- | First declared atomic segment. - draftIncidenceFirstSegment :: !DraftSegmentId - , -- | Second declared atomic segment. - draftIncidenceSecondSegment :: !DraftSegmentId - , -- | Relation declared to hold in both exact and rounded geometry. - draftIncidenceRelation :: !SegmentRelation - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - --- | One exact vertex and the cyclic neighbor order declared around it. -data DraftNeighborhood = DraftNeighborhood - { -- | Center of the declared local rotation. - draftNeighborhoodCenter :: !DraftVertexId - , -- | Neighbors in cyclic rotation order. - draftNeighborhoodNeighbors :: !(NonEmpty DraftVertexId) - } - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - --- | A hand-built exact arrangement draft. It contains only declared local --- structure; no arrangement or global crossing search is derived here. -data ExactArrangementDraft = ExactArrangementDraft - { -- | Exact coordinates keyed by draft-local vertex identity. - draftVertices :: !(Map DraftVertexId ExactPoint) - , -- | Atomic segment endpoint identities. - draftSegments :: !(Map DraftSegmentId (DraftVertexId, DraftVertexId)) - , -- | Exact split parameters and vertices in source-segment order. - draftSourceMemberships :: !(Map DraftSourceId [(ExactRational, DraftVertexId)]) - , -- | Segment relations declared to remain invariant under projection. - draftIncidences :: ![DraftIncidence] - , -- | Cyclic local rotations declared to remain orientation-stable. - draftNeighborhoods :: ![DraftNeighborhood] - } - deriving stock (Eq, Show, Generic) - deriving anyclass (NFData) - --- | The typed identity of a missing draft reference. -data DraftReference - = DraftVertexReference !DraftVertexId - | DraftSegmentReference !DraftSegmentId - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - --- | A witness that prevents local embedding certification. -data OverlayEmbeddingObstruction - = DraftReferenceMissing !DraftReference - | VertexProjectionRefused !DraftVertexId !PointValidationError - | RoundedVerticesCollide !DraftVertexId !DraftVertexId !Point - | SplitOrderNotPreserved !DraftSourceId !DraftVertexId !DraftVertexId - | IncidenceRelationChanged - !DraftSegmentId - !DraftSegmentId - !SegmentRelation - !SegmentRelation - !SegmentRelation - | NeighborhoodOrientationChanged - !DraftVertexId - !DraftVertexId - !DraftVertexId - !Ordering - !Ordering - | GlobalRelationAdded - !DraftSegmentId - !DraftSegmentId - !SegmentRelation - | GlobalRelationRemoved - !DraftSegmentId - !DraftSegmentId - !SegmentRelation - | GlobalRelationChanged - !DraftSegmentId - !DraftSegmentId - !SegmentRelation - !SegmentRelation - | ProjectedSegmentCollapsed - !DraftSegmentId - !DraftVertexId - !DraftVertexId - deriving stock (Eq, Show, Generic) - deriving anyclass (NFData) - --- | An embedding obligation not discharged by the bounded local certifier. -data EmbeddingObligation - = GlobalNoNewCrossing - deriving stock (Bounded, Enum, Eq, Ord, Show, Generic) - deriving anyclass (NFData) - --- | A nonempty collection of obligations deferred to a later owner. -newtype EmbeddingResidual = EmbeddingResidual (NonEmpty EmbeddingObligation) - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData) - --- | Read the obligations that remain explicitly undischarged. -residualUndischargedObligations - :: EmbeddingResidual - -> NonEmpty EmbeddingObligation -residualUndischargedObligations (EmbeddingResidual obligations) = obligations - --- | The Milestone 1 residual: the arrangement sweep has not yet proved global --- absence of new crossings. -milestoneOneResidual :: EmbeddingResidual -milestoneOneResidual = EmbeddingResidual (GlobalNoNewCrossing :| []) - --- | A certificate for exactly four local obligations on a declared draft: --- vertex distinctness, source split order, declared incidences, and local --- neighborhood orientation. Global absence of new crossings is unproved until --- the Milestone 2 arrangement sweep supplies the complete obligation set. -data LocalEmbeddingCertificate = LocalEmbeddingCertificate - { -- | Number of rounded vertex-pair distinctness checks discharged. - certificateRoundedVertexDistinctnessCount :: !Int - , -- | Number of adjacent source split-order checks discharged. - certificateSplitOrderPreservationCount :: !Int - , -- | Number of declared incidence checks discharged. - certificateIncidenceRelationPreservationCount :: !Int - , -- | Number of consecutive neighborhood orientation checks discharged. - certificateNeighborhoodOrientationStabilityCount :: !Int - , -- | The candidate projection certified by the four local obligations. - certificateRoundedVertices :: !(Map DraftVertexId Point) - , -- | The necessarily nonempty global obligation residual. - certificateResidual :: !EmbeddingResidual - } - deriving stock (Eq, Show, Generic) - deriving anyclass (NFData) - --- | Certify the four bounded local embedding obligations, collecting every --- witness within each obligation and preserving obligation order. -certifyLocalEmbedding - :: ExactArrangementDraft - -> Either (NonEmpty OverlayEmbeddingObstruction) LocalEmbeddingCertificate -certifyLocalEmbedding draft = - case NonEmpty.nonEmpty (structuralObstructions draft) of - Just obstructions -> Left obstructions - Nothing -> - case projectVertices (draftVertices draft) of - Invalid obstructions -> Left obstructions - Valid projectedVertices -> - certifyProjectedDraft draft projectedVertices - -data Validation value - = Invalid !(NonEmpty OverlayEmbeddingObstruction) - | Valid value - -instance Functor Validation where - fmap _ (Invalid obstructions) = Invalid obstructions - fmap transform (Valid value) = Valid (transform value) - -instance Applicative Validation where - pure = Valid - Invalid left <*> Invalid right = Invalid (left <> right) - Invalid obstructions <*> Valid _ = Invalid obstructions - Valid _ <*> Invalid obstructions = Invalid obstructions - Valid transform <*> Valid value = Valid (transform value) - -invalid :: OverlayEmbeddingObstruction -> Validation value -invalid obstruction = Invalid (obstruction :| []) - -data ProjectedVertex = ProjectedVertex - { projectedExactPoint :: !ExactPoint - , projectedRoundedPoint :: !Point - } - -data ResolvedSegment = ResolvedSegment - { resolvedSegmentId :: !DraftSegmentId - , resolvedSegmentFrom :: !ResolvedVertex - , resolvedSegmentTo :: !ResolvedVertex - } - -data ResolvedVertex = ResolvedVertex - { resolvedVertexId :: !DraftVertexId - , resolvedProjectedVertex :: !ProjectedVertex - } - -data ResolvedMembership = ResolvedMembership - { resolvedMembershipParameter :: !ExactRational - , resolvedMembershipVertex :: !ResolvedVertex - } - -structuralObstructions - :: ExactArrangementDraft - -> [OverlayEmbeddingObstruction] -structuralObstructions draft = - segmentEndpointObstructions - <> sourceMembershipObstructions - <> incidenceObstructions - <> neighborhoodObstructions - where - vertices = draftVertices draft - segments = draftSegments draft - missingVertex vertexId = - [ DraftReferenceMissing (DraftVertexReference vertexId) - | Map.notMember vertexId vertices - ] - missingSegment segmentId = - [ DraftReferenceMissing (DraftSegmentReference segmentId) - | Map.notMember segmentId segments - ] - segmentEndpointObstructions = - concatMap - (\(_, (from, to)) -> missingVertex from <> missingVertex to) - (Map.toAscList segments) - sourceMembershipObstructions = - concatMap - (concatMap (missingVertex . snd) . snd) - (Map.toAscList (draftSourceMemberships draft)) - incidenceObstructions = - concatMap - ( \incidence -> - missingSegment (draftIncidenceFirstSegment incidence) - <> missingSegment (draftIncidenceSecondSegment incidence) - ) - (draftIncidences draft) - neighborhoodObstructions = - concatMap - ( \neighborhood -> - missingVertex (draftNeighborhoodCenter neighborhood) - <> concatMap missingVertex (draftNeighborhoodNeighbors neighborhood) - ) - (draftNeighborhoods draft) - -projectVertices - :: Map DraftVertexId ExactPoint - -> Validation (Map DraftVertexId ProjectedVertex) -projectVertices = - Map.traverseWithKey - ( \vertexId point -> - case exactPointToEmbeddingCandidate point of - Left projectionError -> - invalid (VertexProjectionRefused vertexId projectionError) - Right roundedPoint -> Valid (ProjectedVertex point roundedPoint) - ) - -certifyProjectedDraft - :: ExactArrangementDraft - -> Map DraftVertexId ProjectedVertex - -> Either (NonEmpty OverlayEmbeddingObstruction) LocalEmbeddingCertificate -certifyProjectedDraft draft projectedVertices = - case resolvedFailures of - Left obstruction -> Left (obstruction :| []) - Right localFailures -> - case NonEmpty.nonEmpty (collisionFailures <> localFailures) of - Just obstructions -> Left obstructions - Nothing -> - Right - LocalEmbeddingCertificate - { certificateRoundedVertexDistinctnessCount = distinctnessCount - , certificateSplitOrderPreservationCount = splitOrderCount - , certificateIncidenceRelationPreservationCount = incidenceCount - , certificateNeighborhoodOrientationStabilityCount = neighborhoodCount - , certificateRoundedVertices = Map.map projectedRoundedPoint projectedVertices - , certificateResidual = milestoneOneResidual - } - where - collisionFailures = roundedVertexCollisionObstructions projectedVertices - resolvedFailures = do - splitFailures <- traverse (uncurry resolveSource) (Map.toAscList (draftSourceMemberships draft)) - incidenceFailures <- traverse resolveIncidence (draftIncidences draft) - neighborhoodFailures <- traverse resolveNeighborhood (draftNeighborhoods draft) - pure (concat splitFailures <> concat incidenceFailures <> concat neighborhoodFailures) - resolveVertex vertexId = - case Map.lookup vertexId projectedVertices of - Nothing -> Left (DraftReferenceMissing (DraftVertexReference vertexId)) - Just projectedVertex -> Right (ResolvedVertex vertexId projectedVertex) - resolveSegment segmentId = - case Map.lookup segmentId (draftSegments draft) of - Nothing -> Left (DraftReferenceMissing (DraftSegmentReference segmentId)) - Just (from, to) -> - ResolvedSegment segmentId - <$> resolveVertex from - <*> resolveVertex to - resolveSource sourceId memberships = - splitOrderObstructions sourceId - <$> traverse - ( \(parameter, vertexId) -> - ResolvedMembership parameter <$> resolveVertex vertexId - ) - memberships - resolveIncidence incidence = - incidenceRelationObstructions - (draftIncidenceRelation incidence) - <$> resolveSegment (draftIncidenceFirstSegment incidence) - <*> resolveSegment (draftIncidenceSecondSegment incidence) - resolveNeighborhood neighborhood = - neighborhoodOrientationObstructions - <$> resolveVertex (draftNeighborhoodCenter neighborhood) - <*> traverse resolveVertex (draftNeighborhoodNeighbors neighborhood) - vertexCount = Map.size projectedVertices - distinctnessCount = vertexCount * (vertexCount - 1) `quot` 2 - splitOrderCount = - sum - ( map - (max 0 . subtract 1 . length) - (Map.elems (draftSourceMemberships draft)) - ) - incidenceCount = length (draftIncidences draft) - neighborhoodCount = - sum - ( map - (length . draftNeighborhoodNeighbors) - (draftNeighborhoods draft) - ) - -roundedVertexCollisionObstructions - :: Map DraftVertexId ProjectedVertex - -> [OverlayEmbeddingObstruction] -roundedVertexCollisionObstructions projectedVertices = - [ RoundedVerticesCollide leftId rightId roundedPoint - | (roundedPoint, vertexIds) <- Map.toAscList verticesByRoundedPoint - , (leftId : remainingIds) <- tails (sort vertexIds) - , rightId <- remainingIds - ] - where - verticesByRoundedPoint = - Map.fromListWith (<>) - [ (projectedRoundedPoint projectedVertex, [vertexId]) - | (vertexId, projectedVertex) <- Map.toAscList projectedVertices - ] - -splitOrderObstructions - :: DraftSourceId - -> [ResolvedMembership] - -> [OverlayEmbeddingObstruction] -splitOrderObstructions sourceId memberships = - case memberships of - firstMembership : secondMembership : remainingMemberships -> - let finalMembership = - 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 = - projectedRoundedPoint - . resolvedProjectedVertex - . resolvedMembershipVertex - -roundedOrderAlong :: Point -> Point -> Point -> Point -> Ordering -roundedOrderAlong - (Point sourceFromX sourceFromY) - (Point sourceToX sourceToY) - (Point leftX leftY) - (Point rightX rightY) = - let directionX = sourceToX - sourceFromX - directionY = sourceToY - sourceFromY - in if abs directionX >= abs directionY - then - if directionX >= 0 - then compare leftX rightX - else compare rightX leftX - else - if directionY >= 0 - then compare leftY rightY - else compare rightY leftY - -incidenceRelationObstructions - :: SegmentRelation - -> ResolvedSegment - -> ResolvedSegment - -> [OverlayEmbeddingObstruction] -incidenceRelationObstructions declaredRelation firstSegment secondSegment = - [ IncidenceRelationChanged - (resolvedSegmentId firstSegment) - (resolvedSegmentId secondSegment) - declaredRelation - exactRelation - roundedRelation - | exactRelation /= declaredRelation || roundedRelation /= declaredRelation - ] - where - exactRelation = - relationFor exactSegmentRelation projectedExactPoint firstSegment secondSegment - roundedRelation = - relationFor Math.segmentRelation projectedRoundedPoint firstSegment secondSegment - -relationFor - :: (point -> point -> point -> point -> SegmentRelation) - -> (ProjectedVertex -> point) - -> ResolvedSegment - -> ResolvedSegment - -> SegmentRelation -relationFor relation project firstSegment secondSegment = - relation - (project (resolvedProjectedVertex (resolvedSegmentFrom firstSegment))) - (project (resolvedProjectedVertex (resolvedSegmentTo firstSegment))) - (project (resolvedProjectedVertex (resolvedSegmentFrom secondSegment))) - (project (resolvedProjectedVertex (resolvedSegmentTo secondSegment))) - -neighborhoodOrientationObstructions - :: ResolvedVertex - -> NonEmpty ResolvedVertex - -> [OverlayEmbeddingObstruction] -neighborhoodOrientationObstructions center neighbors = - [ NeighborhoodOrientationChanged - (resolvedVertexId center) - (resolvedVertexId leftNeighbor) - (resolvedVertexId rightNeighbor) - exactOrientation - roundedOrientation - | (leftNeighbor, rightNeighbor) <- - cyclePairs neighbors - , let exactOrientation = - exactOrient2d - (exactVertexPoint center) - (exactVertexPoint leftNeighbor) - (exactVertexPoint rightNeighbor) - roundedOrientation = - Math.orient2d - (roundedVertexPoint center) - (roundedVertexPoint leftNeighbor) - (roundedVertexPoint rightNeighbor) - , exactOrientation /= roundedOrientation - ] - -exactVertexPoint :: ResolvedVertex -> ExactPoint -exactVertexPoint = projectedExactPoint . resolvedProjectedVertex - -roundedVertexPoint :: ResolvedVertex -> Point -roundedVertexPoint = projectedRoundedPoint . resolvedProjectedVertex diff --git a/src-ffi/Moonlight/Triangulation/Foreign/ABI.hs b/src-ffi/Moonlight/Triangulation/Foreign/ABI.hs --- a/src-ffi/Moonlight/Triangulation/Foreign/ABI.hs +++ b/src-ffi/Moonlight/Triangulation/Foreign/ABI.hs @@ -1,27 +1,57 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} module Moonlight.Triangulation.Foreign.ABI ( CObstruction (..) + , CMinkowskiReceipt (..) + , CMesh + , CRegion + , CStructuringElement , delaunayF64 , meshInsertManyF64 - , meshUnion - , meshIntersection - , meshDifference - , meshSymmetricDifference + , -- | Exported for measurement. @meshInsertManyF64@ is a pointer boundary and + -- cannot be timed against a Haskell arm without dragging marshalling into + -- one side only; this is the same route with the pointers already resolved. + insertGeometryBatch + , meshSiteUnion + , meshSiteIntersection + , meshSiteDifference + , meshSiteSymmetricDifference , meshVertexCount , meshTriangleCount , meshCopyVerticesF64 , meshCopyTrianglesU32 , meshFree + , regionCreateF64 + , regionCounts + , regionCopyF64 + , regionUnion + , regionIntersection + , regionDifference + , regionSymmetricDifference + , regionLocatePointF64 + , regionMeasure + , regionFree + , structuringElementCreateF64 + , structuringElementFree + , regionMinkowskiSum + , regionOffset + , regionInset + , regionOpen + , regionClose ) where import Control.Exception (SomeException, displayException, try) import Control.Monad (void) -import Data.Foldable (traverse_) +import Data.Bifunctor (first) +import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map import Data.Word (Word32, Word64) import Foreign.C.String (peekCString, withCStringLen) -import Foreign.C.Types (CDouble (..), CSize (..), CUInt (..)) +import Foreign.C.Types (CChar, CDouble (..), CSize (..), CUInt (..)) import Foreign.Marshal.Utils (copyBytes, fillBytes) import Foreign.Ptr (Ptr, castPtr, nullPtr, plusPtr) import Foreign.StablePtr @@ -35,11 +65,20 @@ import Foreign.Storable (Storable (..)) import qualified Data.Vector as V import qualified Moonlight.Triangulation as T -import Moonlight.Triangulation.Math (validatePoint) +import Moonlight.Triangulation.Math (canonicalPoint, validatePoint) import qualified Moonlight.Triangulation.Session as Session type GeometryMesh = T.DelaunayTriangulation () +data CMesh +data CRegion +data CStructuringElement + +type family HandleValue carrier where + HandleValue CMesh = GeometryMesh + HandleValue CRegion = T.PlanarRegion + HandleValue CStructuringElement = T.StructuringElement + data CObstruction = CObstruction { obstructionCode :: !Word32 , obstructionCoordinateError :: !Word32 @@ -56,7 +95,7 @@ instance Storable CObstruction where sizeOf _ = 320 - alignment _ = alignment (undefined :: Word64) + alignment _ = alignment (0 :: Word64) peek pointer = do obstructionCode <- peekByteOff pointer 0 obstructionCoordinateError <- peekByteOff pointer 4 @@ -79,19 +118,59 @@ pokeByteOff pointer 40 obstructionSecondValue pokeByteOff pointer 48 obstructionPointX pokeByteOff pointer 56 obstructionPointY - let messagePointer = castPtr pointer `plusPtr` 64 + let messagePointer = castPtr pointer `plusPtr` 64 :: Ptr CChar fillBytes messagePointer 0 256 withCStringLen obstructionMessage $ \(source, lengthInBytes) -> copyBytes messagePointer source (min 255 lengthInBytes) +-- | Fixed-width projection of the existing Haskell morphology receipt. +data CMinkowskiReceipt = CMinkowskiReceipt + { receiptOperation :: !Word32 + , receiptInputComponents :: !Word64 + , receiptConvexPieces :: !Word64 + , receiptGeneratedPieces :: !Word64 + , receiptGeneratedConvolutionEdges :: !Word64 + , receiptOverlayPasses :: !Word64 + , receiptExactCrossings :: !Word64 + , receiptOutputCells :: !Word64 + , receiptExactCoordinateBitGrowth :: !Word64 + } + deriving stock (Eq, Show) + +instance Storable CMinkowskiReceipt where + sizeOf _ = 72 + alignment _ = alignment (0 :: Word64) + peek pointer = do + receiptOperation <- peekByteOff pointer 0 + receiptInputComponents <- peekByteOff pointer 8 + receiptConvexPieces <- peekByteOff pointer 16 + receiptGeneratedPieces <- peekByteOff pointer 24 + receiptGeneratedConvolutionEdges <- peekByteOff pointer 32 + receiptOverlayPasses <- peekByteOff pointer 40 + receiptExactCrossings <- peekByteOff pointer 48 + receiptOutputCells <- peekByteOff pointer 56 + receiptExactCoordinateBitGrowth <- peekByteOff pointer 64 + pure CMinkowskiReceipt {..} + poke pointer CMinkowskiReceipt {..} = do + pokeByteOff pointer 0 receiptOperation + pokeByteOff pointer 4 (0 :: Word32) + pokeByteOff pointer 8 receiptInputComponents + pokeByteOff pointer 16 receiptConvexPieces + pokeByteOff pointer 24 receiptGeneratedPieces + pokeByteOff pointer 32 receiptGeneratedConvolutionEdges + pokeByteOff pointer 40 receiptOverlayPasses + pokeByteOff pointer 48 receiptExactCrossings + pokeByteOff pointer 56 receiptOutputCells + pokeByteOff pointer 64 receiptExactCoordinateBitGrowth + data AbiFailure = AbiFailure !CUInt !CObstruction -statusOk, statusNullPointer, statusCountOverflow, statusBufferTooSmall, statusBuildObstruction, statusRuntimeFailure :: CUInt +statusOk, statusNullPointer, statusCountOverflow, statusBufferTooSmall, statusGeometryObstruction, statusRuntimeFailure :: CUInt statusOk = 0 statusNullPointer = 1 statusCountOverflow = 2 statusBufferTooSmall = 3 -statusBuildObstruction = 4 +statusGeometryObstruction = 4 statusRuntimeFailure = 5 emptyObstruction :: CObstruction @@ -113,6 +192,10 @@ apiFailure status code message = AbiFailure status emptyObstruction {obstructionCode = code, obstructionMessage = message} +geometryFailure :: Show obstruction => Word32 -> obstruction -> AbiFailure +geometryFailure code obstruction = + apiFailure statusGeometryObstruction code (show obstruction) + nullPointerFailure :: String -> AbiFailure nullPointerFailure label = apiFailure statusNullPointer 100 (label <> " must not be null") @@ -180,99 +263,127 @@ pure (T.Point x y) ) -prepareMeshOutput :: Ptr (Ptr ()) -> IO (Either AbiFailure ()) -prepareMeshOutput pointer = +prepareHandleOutput :: Ptr (Ptr carrier) -> IO (Either AbiFailure ()) +prepareHandleOutput pointer = case requirePointer "result" pointer of Left failure -> pure (Left failure) Right () -> poke pointer nullPtr >> pure (Right ()) -publishMesh :: Ptr (Ptr ()) -> GeometryMesh -> IO () -publishMesh output mesh = do - stable <- newStablePtr mesh - poke output (castStablePtrToPtr stable) +publishHandle :: Ptr (Ptr carrier) -> HandleValue carrier -> IO () +publishHandle output value = do + stable <- newStablePtr value + poke output (castPtr (castStablePtrToPtr stable)) -produceMesh :: Ptr (Ptr ()) -> IO (Either AbiFailure (Either T.BuildError GeometryMesh)) -> IO (Either AbiFailure ()) -produceMesh output obtain = do - prepared <- prepareMeshOutput output +produceHandle + :: Ptr (Ptr carrier) + -> IO (Either AbiFailure (HandleValue carrier)) + -> IO (Either AbiFailure ()) +produceHandle output obtain = do + prepared <- prepareHandleOutput output case prepared of Left failure -> pure (Left failure) Right () -> do outcome <- obtain case outcome of Left failure -> pure (Left failure) - Right (Left obstruction) -> - pure (Left (AbiFailure statusBuildObstruction (buildErrorObstruction obstruction))) - Right (Right mesh) -> publishMesh output mesh >> pure (Right ()) + Right value -> publishHandle output value >> pure (Right ()) -delaunayF64 :: Ptr CDouble -> CSize -> Ptr (Ptr ()) -> Ptr CObstruction -> IO CUInt +dereferenceHandle :: Ptr carrier -> IO (HandleValue carrier) +dereferenceHandle pointer = deRefStablePtr (castPtrToStablePtr (castPtr pointer)) + +freeHandle :: Ptr carrier -> IO () +freeHandle pointer + | pointer == nullPtr = pure () + | otherwise = freeStablePtr (castPtrToStablePtr (castPtr pointer) :: StablePtr ()) + +buildFailure :: T.BuildError -> AbiFailure +buildFailure obstruction = + AbiFailure statusGeometryObstruction (buildErrorObstruction obstruction) + +delaunayF64 :: Ptr CDouble -> CSize -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt delaunayF64 coordinates rawCount output obstructionPointer = - runBoundary obstructionPointer $ produceMesh output $ do + runBoundary obstructionPointer $ produceHandle output $ do case checkedCount 2 rawCount of Left failure -> pure (Left failure) - Right count -> fmap (fmap T.delaunayGeometry) (readPoints coordinates count) + Right count -> do + points <- readPoints coordinates count + pure (points >>= first buildFailure . T.delaunayGeometry) -meshInsertManyF64 :: Ptr () -> Ptr CDouble -> CSize -> Ptr (Ptr ()) -> Ptr CObstruction -> IO CUInt +meshInsertManyF64 :: Ptr CMesh -> Ptr CDouble -> CSize -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt meshInsertManyF64 meshPointer coordinates rawCount output obstructionPointer = - runBoundary obstructionPointer $ produceMesh output $ do - case (requirePointer "mesh" meshPointer, checkedCount 2 rawCount) of - (Left failure, _) -> pure (Left failure) - (_, Left failure) -> pure (Left failure) - (Right (), Right count) -> do - pointsOutcome <- readPoints coordinates count - case pointsOutcome of + runBoundary obstructionPointer $ produceHandle output $ do + case requirePointer "mesh" meshPointer >> checkedCount 2 rawCount of + Left failure -> pure (Left failure) + Right count -> do + points <- readPoints coordinates count + case points of Left failure -> pure (Left failure) - Right points -> do - mesh <- dereferenceMesh meshPointer - pure (Right (insertGeometryBatch mesh points)) + Right admitted -> do + mesh <- dereferenceHandle meshPointer + pure (first buildFailure (insertGeometryBatch mesh admitted)) +-- | Admission stays where it was — every point is validated before any point +-- is inserted, so a malformed input at the end still refuses the whole batch — +-- but it no longer materializes a second vector to carry the canonical +-- coordinates. @imapM@ over 'Either' cannot fill in place, so the discarded +-- form is the one that costs nothing; canonicalization is exactly what +-- @queryPointValue . validatePoint@ returned, applied where the point is used. insertGeometryBatch :: GeometryMesh -> V.Vector T.Point -> Either T.BuildError GeometryMesh insertGeometryBatch mesh points = do - normalized <- - V.imapM - (\index point -> T.queryPointValue <$> validatePoint (Just index) point) - points + V.imapM_ (\index point -> () <$ validatePoint (Just index) point) points (_, revised, _) <- Session.withSession mesh - (V.length normalized) - (traverse_ (\point -> void (Session.insertVertexAt point ())) normalized) + (V.length points) + (V.mapM_ (\point -> void (Session.insertVertexAt (canonicalPoint point) ())) points) pure revised -meshUnion, meshIntersection, meshDifference, meshSymmetricDifference :: Ptr () -> Ptr () -> Ptr (Ptr ()) -> Ptr CObstruction -> IO CUInt -meshUnion = binaryMeshOperation T.union -meshIntersection = binaryMeshOperation T.intersection -meshDifference = binaryMeshOperation T.difference -meshSymmetricDifference = binaryMeshOperation T.symmetricDifference +meshSiteUnion, meshSiteIntersection, meshSiteDifference, meshSiteSymmetricDifference :: Ptr CMesh -> Ptr CMesh -> Ptr (Ptr CMesh) -> Ptr CObstruction -> IO CUInt +meshSiteUnion = binaryMeshOperation T.union +meshSiteIntersection = binaryMeshOperation T.intersection +meshSiteDifference = binaryMeshOperation T.difference +meshSiteSymmetricDifference = binaryMeshOperation T.symmetricDifference -binaryMeshOperation :: (GeometryMesh -> GeometryMesh -> Either T.BuildError GeometryMesh) -> Ptr () -> Ptr () -> Ptr (Ptr ()) -> Ptr CObstruction -> IO CUInt +binaryMeshOperation + :: (GeometryMesh -> GeometryMesh -> Either T.BuildError GeometryMesh) + -> Ptr CMesh + -> Ptr CMesh + -> Ptr (Ptr CMesh) + -> Ptr CObstruction + -> IO CUInt binaryMeshOperation operation leftPointer rightPointer output obstructionPointer = - runBoundary obstructionPointer $ produceMesh output $ do - case (requirePointer "left mesh" leftPointer, requirePointer "right mesh" rightPointer) of - (Left failure, _) -> pure (Left failure) - (_, Left failure) -> pure (Left failure) - (Right (), Right ()) -> do - left <- dereferenceMesh leftPointer - right <- dereferenceMesh rightPointer - pure (Right (operation left right)) + runBoundary obstructionPointer $ produceHandle output $ do + case requirePointer "left mesh" leftPointer >> requirePointer "right mesh" rightPointer of + Left failure -> pure (Left failure) + Right () -> do + left <- dereferenceHandle leftPointer + right <- dereferenceHandle rightPointer + pure (first buildFailure (operation left right)) -meshVertexCount, meshTriangleCount :: Ptr () -> Ptr CSize -> Ptr CObstruction -> IO CUInt -meshVertexCount = meshCount T.numVertices -meshTriangleCount = meshCount (V.length . T.innerFaceVertexTriples) +meshVertexCount, meshTriangleCount :: Ptr CMesh -> Ptr CSize -> Ptr CObstruction -> IO CUInt +meshVertexCount = handleCount "mesh" T.numVertices +meshTriangleCount = handleCount "mesh" (V.length . T.innerFaceVertexTriples) -meshCount :: (GeometryMesh -> Int) -> Ptr () -> Ptr CSize -> Ptr CObstruction -> IO CUInt -meshCount observe meshPointer output obstructionPointer = +handleCount + :: String + -> (HandleValue carrier -> Int) + -> Ptr carrier + -> Ptr CSize + -> Ptr CObstruction + -> IO CUInt +handleCount handleLabel observe handlePointer output obstructionPointer = runBoundary obstructionPointer $ - case (requirePointer "mesh" meshPointer, requirePointer "count" output) of - (Left failure, _) -> pure (Left failure) - (_, Left failure) -> pure (Left failure) - (Right (), Right ()) -> do - mesh <- dereferenceMesh meshPointer - poke output (fromIntegral (observe mesh)) + case requirePointer handleLabel handlePointer >> requirePointer "count" output of + Left failure -> pure (Left failure) + Right () -> do + value <- dereferenceHandle handlePointer + poke output (fromIntegral (observe value)) pure (Right ()) -meshCopyVerticesF64 :: Ptr () -> Ptr CDouble -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt +meshCopyVerticesF64 :: Ptr CMesh -> Ptr CDouble -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt meshCopyVerticesF64 = - copyMeshProjection + copyHandleProjection + "mesh" "points_written" "coordinates" T.vertexPoints @@ -281,31 +392,39 @@ pokeElemOff output (index * 2 + 1) (CDouble y) ) -meshCopyTrianglesU32 :: Ptr () -> Ptr Word32 -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt +meshCopyTrianglesU32 :: Ptr CMesh -> Ptr Word32 -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt meshCopyTrianglesU32 = - copyMeshProjection + copyHandleProjection + "mesh" "triangles_written" "triangles" T.innerFaceVertexTriples - ( \output index (first, second, third) -> do - pokeElemOff output (index * 3) (T.unVertexId first) - pokeElemOff output (index * 3 + 1) (T.unVertexId second) - pokeElemOff output (index * 3 + 2) (T.unVertexId third) + ( \output index (firstVertex, secondVertex, thirdVertex) -> do + pokeElemOff output (index * 3) (T.unVertexId firstVertex) + pokeElemOff output (index * 3 + 1) (T.unVertexId secondVertex) + pokeElemOff output (index * 3 + 2) (T.unVertexId thirdVertex) ) -copyMeshProjection - :: String -> String -> (GeometryMesh -> V.Vector item) -> (Ptr element -> Int -> item -> IO ()) - -> Ptr () -> Ptr element -> CSize -> Ptr CSize -> Ptr CObstruction -> IO CUInt -{-# INLINE copyMeshProjection #-} -copyMeshProjection writtenLabel outputLabel project writeItem meshPointer output rawCapacity written obstructionPointer = +copyHandleProjection + :: String + -> String + -> String + -> (HandleValue carrier -> V.Vector item) + -> (Ptr element -> Int -> item -> IO ()) + -> Ptr carrier + -> Ptr element + -> CSize + -> Ptr CSize + -> Ptr CObstruction + -> IO CUInt +{-# INLINE copyHandleProjection #-} +copyHandleProjection handleLabel writtenLabel outputLabel project writeItem handlePointer output rawCapacity written obstructionPointer = runBoundary obstructionPointer $ - case (requirePointer "mesh" meshPointer, requirePointer writtenLabel written, checkedCount 1 rawCapacity) of - (Left failure, _, _) -> pure (Left failure) - (_, Left failure, _) -> pure (Left failure) - (_, _, Left failure) -> pure (Left failure) - (Right (), Right (), Right capacity) -> do - mesh <- dereferenceMesh meshPointer - let items = project mesh + case requirePointer handleLabel handlePointer >> requirePointer writtenLabel written >> checkedCount 1 rawCapacity of + Left failure -> pure (Left failure) + Right capacity -> do + value <- dereferenceHandle handlePointer + let items = project value required = V.length items poke written (fromIntegral required) case requireOutputCapacity outputLabel output required capacity of @@ -318,14 +437,552 @@ | required > 0 = requirePointer label output | otherwise = Right () -dereferenceMesh :: Ptr () -> IO GeometryMesh -dereferenceMesh = deRefStablePtr . (castPtrToStablePtr :: Ptr () -> StablePtr GeometryMesh) +meshFree :: Ptr CMesh -> IO () +meshFree = freeHandle -meshFree :: Ptr () -> IO () -meshFree pointer - | pointer == nullPtr = pure () - | otherwise = freeStablePtr ((castPtrToStablePtr pointer) :: StablePtr GeometryMesh) +data RegionCountKind + = LoopPointCounts + | ComponentLoopCounts + deriving stock (Eq, Show) +data RegionLayoutError + = RegionGroupEmpty !RegionCountKind !Int + | RegionCountTotalMismatch !RegionCountKind !Integer !Integer + | RegionStructuringElementEmpty + deriving stock (Eq, Show) + +regionLayoutFailure :: RegionLayoutError -> AbiFailure +regionLayoutFailure layoutError = + AbiFailure statusGeometryObstruction (layoutObstruction layoutError) + +layoutObstruction :: RegionLayoutError -> CObstruction +layoutObstruction layoutError = + (case layoutError of + RegionCountTotalMismatch _ actual expected -> + base + { obstructionFirstIndex = fromIntegral actual + , obstructionSecondIndex = fromIntegral expected + } + RegionGroupEmpty _ index -> base {obstructionInputIndex = fromIntegral index} + RegionStructuringElementEmpty -> base + ) + {obstructionMessage = show layoutError} + where + base = emptyObstruction {obstructionCode = 200} + +regionValidationFailure :: T.RegionValidationError -> AbiFailure +regionValidationFailure = geometryFailure 201 + +overlayFailure :: T.OverlayError Bool Bool -> AbiFailure +overlayFailure = geometryFailure 202 + +regionPublicationFailure :: T.RegionPublicationError -> AbiFailure +regionPublicationFailure = geometryFailure 203 + +valuationFailure :: T.ValuationError -> AbiFailure +valuationFailure = geometryFailure 204 + +minkowskiFailure :: T.MinkowskiError -> AbiFailure +minkowskiFailure = geometryFailure 205 + +pointInputFailure :: Int -> T.Point -> T.PointValidationError -> AbiFailure +pointInputFailure index (T.Point x y) pointError = + AbiFailure statusGeometryObstruction emptyObstruction + { obstructionCode = 1 + , obstructionCoordinateError = coordinateErrorCode reason + , obstructionInputIndex = fromIntegral index + , obstructionFirstValue = invalidValue + , obstructionPointX = x + , obstructionPointY = y + , obstructionMessage = show pointError + } + where + (invalidValue, reason) = + case pointError of + T.InvalidPointX coordinateError -> (x, coordinateError) + T.InvalidPointY coordinateError -> (y, coordinateError) + +projectionFailure :: Int -> T.PointValidationError -> AbiFailure +projectionFailure index pointError = + AbiFailure statusGeometryObstruction emptyObstruction + { obstructionCode = 206 + , obstructionCoordinateError = + coordinateErrorCode + (case pointError of + T.InvalidPointX coordinateError -> coordinateError + T.InvalidPointY coordinateError -> coordinateError) + , obstructionInputIndex = fromIntegral index + , obstructionMessage = show pointError + } + +readCounts + :: String + -> Ptr CSize + -> Int + -> IO (Either AbiFailure (V.Vector Int)) +readCounts _ _ 0 = pure (Right V.empty) +readCounts label pointer count + | pointer == nullPtr = pure (Left (nullPointerFailure label)) + | otherwise = do + rawCounts <- V.generateM count (peekElemOff pointer) + pure (V.mapM (checkedCount 1) rawCounts) + +validateCounts + :: RegionCountKind + -> Int + -> V.Vector Int + -> Either RegionLayoutError () +validateCounts kind expectedTotal counts = + case V.findIndex (== 0) counts of + Just index -> Left (RegionGroupEmpty kind index) + Nothing + | observedTotal /= toInteger expectedTotal -> + Left (RegionCountTotalMismatch kind observedTotal (toInteger expectedTotal)) + | otherwise -> Right () + where + observedTotal = V.foldl' (\total count -> total + toInteger count) 0 counts + +regionCreateF64 + :: Ptr CDouble + -> CSize + -> Ptr CSize + -> CSize + -> Ptr CSize + -> CSize + -> Ptr (Ptr CRegion) + -> Ptr CObstruction + -> IO CUInt +regionCreateF64 coordinates rawPointCount loopPointCounts rawLoopCount componentLoopCounts rawComponentCount output obstructionPointer = + runBoundary obstructionPointer $ + produceHandle output $ + readRegionF64 + coordinates + rawPointCount + loopPointCounts + rawLoopCount + componentLoopCounts + rawComponentCount + +readRegionF64 + :: Ptr CDouble + -> CSize + -> Ptr CSize + -> CSize + -> Ptr CSize + -> CSize + -> IO (Either AbiFailure T.PlanarRegion) +readRegionF64 coordinates rawPointCount loopPointCounts rawLoopCount componentLoopCounts rawComponentCount = + case checkedRegionInputCounts rawPointCount rawLoopCount rawComponentCount of + Left failure -> pure (Left failure) + Right (pointCount, loopCount, componentCount) -> do + points <- readPoints coordinates pointCount + loopCounts <- readCounts "loop_point_counts" loopPointCounts loopCount + componentCounts <- readCounts "component_loop_counts" componentLoopCounts componentCount + pure $ do + admittedPoints <- points + admittedLoopCounts <- loopCounts + admittedComponentCounts <- componentCounts + first regionLayoutFailure (validateCounts LoopPointCounts pointCount admittedLoopCounts) + first regionLayoutFailure (validateCounts ComponentLoopCounts loopCount admittedComponentCounts) + buildRegion admittedPoints admittedLoopCounts admittedComponentCounts + +checkedRegionInputCounts + :: CSize + -> CSize + -> CSize + -> Either AbiFailure (Int, Int, Int) +checkedRegionInputCounts rawPointCount rawLoopCount rawComponentCount = do + pointCount <- checkedCount 2 rawPointCount + loopCount <- checkedCount 1 rawLoopCount + componentCount <- checkedCount 1 rawComponentCount + pure (pointCount, loopCount, componentCount) + +buildRegion + :: V.Vector T.Point + -> V.Vector Int + -> V.Vector Int + -> Either AbiFailure T.PlanarRegion +buildRegion points loopCounts componentCounts = do + exactPoints <- + V.imapM + (\index point -> first (pointInputFailure index point) (T.exactPointFromPoint point)) + points + loops <- + V.imapM + (buildLoop exactPoints) + (adjacentOffsets loopCounts) + components <- + V.imapM + (buildComponent loops) + (adjacentOffsets componentCounts) + first regionValidationFailure (T.planarRegion (V.toList components)) + +adjacentOffsets :: V.Vector Int -> V.Vector (Int, Int) +adjacentOffsets counts = + let offsets = V.scanl' (+) 0 counts + in V.zip offsets (V.drop 1 offsets) + +buildLoop + :: V.Vector T.ExactPoint + -> Int + -> (Int, Int) + -> Either AbiFailure T.ExactLoop +buildLoop points loopIndex (start, end) = + case NonEmpty.nonEmpty (V.toList (V.slice start (end - start) points)) of + Nothing -> Left (regionLayoutFailure (RegionGroupEmpty LoopPointCounts loopIndex)) + Just submitted -> first regionValidationFailure (T.exactLoop submitted) + +buildComponent + :: V.Vector T.ExactLoop + -> Int + -> (Int, Int) + -> Either AbiFailure T.PolygonComponent +buildComponent loops componentIndex (start, end) = + case NonEmpty.nonEmpty (V.toList (V.slice start (end - start) loops)) of + Nothing -> Left (regionLayoutFailure (RegionGroupEmpty ComponentLoopCounts componentIndex)) + Just (outer :| holes) -> first regionValidationFailure (T.polygonComponent outer holes) + +regionShape + :: T.PlanarRegion + -> ([T.PolygonComponent], [[T.ExactLoop]], [T.ExactLoop]) +regionShape region = + let components = T.planarRegionComponents region + componentLoops component = T.polygonOuterLoop component : T.polygonHoleLoops component + loopsByComponent = map componentLoops components + in (components, loopsByComponent, concat loopsByComponent) + +regionCounts + :: Ptr CRegion + -> Ptr CSize + -> Ptr CSize + -> Ptr CSize + -> Ptr CObstruction + -> IO CUInt +regionCounts regionPointer componentCountOutput loopCountOutput pointCountOutput obstructionPointer = + runBoundary obstructionPointer $ + case + requirePointer "region" regionPointer + >> requirePointer "component_count" componentCountOutput + >> requirePointer "loop_count" loopCountOutput + >> requirePointer "point_count" pointCountOutput + of + Left failure -> pure (Left failure) + Right () -> do + region <- dereferenceHandle regionPointer + let (components, _, loops) = regionShape region + pointCount = sum (map (NonEmpty.length . T.exactLoopPoints) loops) + poke componentCountOutput (fromIntegral (length components)) + poke loopCountOutput (fromIntegral (length loops)) + poke pointCountOutput (fromIntegral pointCount) + pure (Right ()) + +data RegionProjection = RegionProjection + { projectionPoints :: !(V.Vector T.Point) + , projectionLoopPointOffsets :: !(V.Vector CSize) + , projectionComponentLoopOffsets :: !(V.Vector CSize) + } + +regionProjection :: T.PlanarRegion -> Either AbiFailure RegionProjection +regionProjection region = do + let (_, loopsByComponent, loops) = regionShape region + exactPoints = concatMap (NonEmpty.toList . T.exactLoopPoints) loops + loopPointOffsets = scanl (+) 0 (map (NonEmpty.length . T.exactLoopPoints) loops) + componentLoopOffsets = scanl (+) 0 (map length loopsByComponent) + projectedPoints <- + V.fromList + <$> traverse + (uncurry projectPoint) + (zip [0 ..] exactPoints) + pure + RegionProjection + { projectionPoints = projectedPoints + , projectionLoopPointOffsets = V.fromList (map fromIntegral loopPointOffsets) + , projectionComponentLoopOffsets = V.fromList (map fromIntegral componentLoopOffsets) + } + where + projectPoint index point = + first (projectionFailure index) (T.exactPointToEmbeddingCandidate point) + +regionCopyF64 + :: Ptr CRegion + -> Ptr CDouble + -> CSize + -> Ptr CSize + -> CSize + -> Ptr CSize + -> CSize + -> Ptr CObstruction + -> IO CUInt +regionCopyF64 regionPointer coordinates rawPointCapacity loopPointOffsets rawLoopOffsetCapacity componentLoopOffsets rawComponentOffsetCapacity obstructionPointer = + runBoundary obstructionPointer $ + case + ( (,,) + <$> (requirePointer "region" regionPointer >> checkedCount 2 rawPointCapacity) + <*> checkedCount 1 rawLoopOffsetCapacity + <*> checkedCount 1 rawComponentOffsetCapacity + ) + of + Left failure -> pure (Left failure) + Right (pointCapacity, loopOffsetCapacity, componentOffsetCapacity) -> do + region <- dereferenceHandle regionPointer + case regionProjection region of + Left failure -> pure (Left failure) + Right RegionProjection {..} -> + case + requireOutputCapacity "coordinates" coordinates (V.length projectionPoints) pointCapacity + >> requireOutputCapacity "loop_point_offsets" loopPointOffsets (V.length projectionLoopPointOffsets) loopOffsetCapacity + >> requireOutputCapacity "component_loop_offsets" componentLoopOffsets (V.length projectionComponentLoopOffsets) componentOffsetCapacity + of + Left failure -> pure (Left failure) + Right () -> do + V.imapM_ + (\index (T.Point x y) -> do + pokeElemOff coordinates (index * 2) (CDouble x) + pokeElemOff coordinates (index * 2 + 1) (CDouble y)) + projectionPoints + V.imapM_ (pokeElemOff loopPointOffsets) projectionLoopPointOffsets + V.imapM_ (pokeElemOff componentLoopOffsets) projectionComponentLoopOffsets + pure (Right ()) + +regionUnion, regionIntersection, regionDifference, regionSymmetricDifference :: Ptr CRegion -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CObstruction -> IO CUInt +regionUnion = binaryRegionOperation (\(left, right) -> left || right) +regionIntersection = binaryRegionOperation (\(left, right) -> left && right) +regionDifference = binaryRegionOperation (\(left, right) -> left && not right) +regionSymmetricDifference = binaryRegionOperation (uncurry (/=)) + +binaryRegionOperation + :: ((Bool, Bool) -> Bool) + -> Ptr CRegion + -> Ptr CRegion + -> Ptr (Ptr CRegion) + -> Ptr CObstruction + -> IO CUInt +binaryRegionOperation selected leftPointer rightPointer output obstructionPointer = + runBoundary obstructionPointer $ produceHandle output $ do + case requirePointer "left region" leftPointer >> requirePointer "right region" rightPointer of + Left failure -> pure (Left failure) + Right () -> do + left <- dereferenceHandle leftPointer + right <- dereferenceHandle rightPointer + pure (exactRegionBoolean selected left right) + +exactRegionBoolean + :: ((Bool, Bool) -> Bool) + -> T.PlanarRegion + -> T.PlanarRegion + -> Either AbiFailure T.PlanarRegion +exactRegionBoolean selected left right = do + leftLayer <- first regionValidationFailure (T.planarLayer False (Map.singleton True left)) + rightLayer <- first regionValidationFailure (T.planarLayer False (Map.singleton True right)) + overlay <- first overlayFailure (T.overlayLayers leftLayer rightLayer) + first regionPublicationFailure (T.overlaySelectedRegion selected overlay) + +regionLocatePointF64 + :: Ptr CRegion + -> CDouble + -> CDouble + -> Ptr CUInt + -> Ptr CObstruction + -> IO CUInt +regionLocatePointF64 regionPointer (CDouble x) (CDouble y) output obstructionPointer = + runBoundary obstructionPointer $ + case + requirePointer "region" regionPointer + >> requirePointer "location" output + >> first (pointInputFailure 0 (T.Point x y)) (T.exactPointFromPoint (T.Point x y)) + of + Left failure -> pure (Left failure) + Right query -> do + region <- dereferenceHandle regionPointer + poke output (regionLocationCode (T.regionPointLocation region query)) + pure (Right ()) + +regionLocationCode :: T.RegionPointLocation -> CUInt +regionLocationCode location = + case location of + T.RegionExterior -> 0 + T.RegionOnBoundary -> 1 + T.RegionInterior -> 2 + +regionMeasure + :: Ptr CRegion + -> Ptr Int64 + -> Ptr CChar + -> CSize + -> Ptr CSize + -> Ptr CDouble + -> Ptr CDouble + -> Ptr CObstruction + -> IO CUInt +regionMeasure regionPointer eulerOutput areaRatioOutput rawAreaCapacity areaBytesWritten perimeterLowerOutput perimeterUpperOutput obstructionPointer = + runBoundary obstructionPointer $ + case + requirePointer "region" regionPointer + >> requirePointer "euler_characteristic" eulerOutput + >> requirePointer "area_bytes_written" areaBytesWritten + >> requirePointer "perimeter_lower" perimeterLowerOutput + >> requirePointer "perimeter_upper" perimeterUpperOutput + >> checkedCount 1 rawAreaCapacity + of + Left failure -> pure (Left failure) + Right areaCapacity -> do + region <- dereferenceHandle regionPointer + case regionMeasurements region of + Left failure -> pure (Left failure) + Right (valuations, perimeter) -> do + let area = T.exactAreaValue (T.valuationArea valuations) + areaText = + show (T.exactRationalNumerator area) + <> "/" + <> show (T.exactRationalDenominator area) + bounds = T.exactLengthBounds perimeter + poke eulerOutput (fromIntegral (T.eulerCharacteristicValue (T.valuationEuler valuations))) + poke perimeterLowerOutput (CDouble (T.intervalLower bounds)) + poke perimeterUpperOutput (CDouble (T.intervalUpper bounds)) + copyCStringOutput areaText areaRatioOutput areaCapacity areaBytesWritten + +regionMeasurements + :: T.PlanarRegion + -> Either AbiFailure (T.PlanarValuations, T.ExactLengthMeasurement) +regionMeasurements region = do + valuations <- first valuationFailure (T.regionValuations region) + perimeter <- first valuationFailure (T.planarValuationsPerimeter valuations) + pure (valuations, perimeter) + +copyCStringOutput + :: String + -> Ptr CChar + -> Int + -> Ptr CSize + -> IO (Either AbiFailure ()) +copyCStringOutput value output capacity bytesWritten = + withCStringLen value $ \(source, byteCount) -> do + poke bytesWritten (fromIntegral byteCount) + case requireOutputCapacity "area_ratio_utf8" output (byteCount + 1) capacity of + Left failure -> pure (Left failure) + Right () -> do + copyBytes output source byteCount + pokeElemOff output byteCount 0 + pure (Right ()) + +regionFree :: Ptr CRegion -> IO () +regionFree = freeHandle + +structuringElementCreateF64 + :: Ptr CDouble + -> CSize + -> Ptr (Ptr CStructuringElement) + -> Ptr CObstruction + -> IO CUInt +structuringElementCreateF64 coordinates rawPointCount output obstructionPointer = + runBoundary obstructionPointer $ produceHandle output $ do + case checkedCount 2 rawPointCount of + Left failure -> pure (Left failure) + Right pointCount -> do + points <- readPoints coordinates pointCount + pure (points >>= buildStructuringElement) + +buildStructuringElement + :: V.Vector T.Point + -> Either AbiFailure T.StructuringElement +buildStructuringElement points = do + exactPoints <- + V.imapM + (\index point -> first (pointInputFailure index point) (T.exactPointFromPoint point)) + points + submitted <- + maybe + (Left (regionLayoutFailure RegionStructuringElementEmpty)) + Right + (NonEmpty.nonEmpty (V.toList exactPoints)) + polygon <- first minkowskiFailure (T.convexPolygon submitted) + first minkowskiFailure (T.structuringElement polygon) + +structuringElementFree :: Ptr CStructuringElement -> IO () +structuringElementFree = freeHandle + +regionMinkowskiSum + :: Ptr CRegion + -> Ptr CRegion + -> Ptr (Ptr CRegion) + -> Ptr CMinkowskiReceipt + -> Ptr CObstruction + -> IO CUInt +regionMinkowskiSum leftPointer rightPointer output receiptOutput obstructionPointer = + runBoundary obstructionPointer $ + produceRegionWithReceipt output receiptOutput $ do + case requirePointer "left region" leftPointer >> requirePointer "right region" rightPointer of + Left failure -> pure (Left failure) + Right () -> do + left <- dereferenceHandle leftPointer + right <- dereferenceHandle rightPointer + pure (first minkowskiFailure (T.minkowskiSum left right)) + +regionOffset, regionInset, regionOpen, regionClose :: Ptr CStructuringElement -> Ptr CRegion -> Ptr (Ptr CRegion) -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt +regionOffset = structuringElementOperation T.polygonOffset +regionInset = structuringElementOperation T.polygonInset +regionOpen = structuringElementOperation T.openWith +regionClose = structuringElementOperation T.closeWith + +structuringElementOperation + :: (T.StructuringElement -> T.PlanarRegion -> Either T.MinkowskiError (T.PlanarRegion, T.MinkowskiReceipt)) + -> Ptr CStructuringElement + -> Ptr CRegion + -> Ptr (Ptr CRegion) + -> Ptr CMinkowskiReceipt + -> Ptr CObstruction + -> IO CUInt +structuringElementOperation operation elementPointer regionPointer output receiptOutput obstructionPointer = + runBoundary obstructionPointer $ + produceRegionWithReceipt output receiptOutput $ do + case requirePointer "structuring element" elementPointer >> requirePointer "region" regionPointer of + Left failure -> pure (Left failure) + Right () -> do + element <- dereferenceHandle elementPointer + region <- dereferenceHandle regionPointer + pure (first minkowskiFailure (operation element region)) + +produceRegionWithReceipt + :: Ptr (Ptr CRegion) + -> Ptr CMinkowskiReceipt + -> IO (Either AbiFailure (T.PlanarRegion, T.MinkowskiReceipt)) + -> IO (Either AbiFailure ()) +produceRegionWithReceipt output receiptOutput obtain = do + prepared <- prepareHandleOutput output + case (prepared, requirePointer "receipt" receiptOutput) of + (Left failure, _) -> pure (Left failure) + (_, Left failure) -> pure (Left failure) + (Right (), Right ()) -> do + outcome <- obtain + case outcome of + Left failure -> pure (Left failure) + Right (region, receipt) -> do + poke receiptOutput (minkowskiReceiptProjection receipt) + publishHandle output region + pure (Right ()) + +minkowskiReceiptProjection :: T.MinkowskiReceipt -> CMinkowskiReceipt +minkowskiReceiptProjection receipt = + CMinkowskiReceipt + { receiptOperation = minkowskiOperationCode (T.minkowskiOperation receipt) + , receiptInputComponents = fromIntegral (T.minkowskiInputComponents receipt) + , receiptConvexPieces = fromIntegral (T.minkowskiConvexPieces receipt) + , receiptGeneratedPieces = fromIntegral (T.minkowskiGeneratedPieces receipt) + , receiptGeneratedConvolutionEdges = fromIntegral (T.minkowskiGeneratedConvolutionEdges receipt) + , receiptOverlayPasses = fromIntegral (T.minkowskiOverlayPasses receipt) + , receiptExactCrossings = fromIntegral (T.minkowskiExactCrossings receipt) + , receiptOutputCells = fromIntegral (T.minkowskiOutputCells receipt) + , receiptExactCoordinateBitGrowth = fromIntegral (T.minkowskiExactCoordinateBitGrowth receipt) + } + +minkowskiOperationCode :: T.MinkowskiOperation -> Word32 +minkowskiOperationCode operation = + case operation of + T.MinkowskiAddition -> 0 + T.MinkowskiErosion -> 1 + T.MinkowskiOpening -> 2 + T.MinkowskiClosing -> 3 + buildErrorObstruction :: T.BuildError -> CObstruction buildErrorObstruction failure = (case failure of @@ -340,13 +997,13 @@ T.LocationWalkExhausted (T.Point x y) steps -> (pointObstruction 3 x y) {obstructionFirstIndex = fromIntegral steps} T.RefinementInputTopologyInvalid _ -> codeOnly 4 - T.FreshInsertionMatchedExistingVertex first second -> indices 5 (T.unVertexId first) (T.unVertexId second) + T.FreshInsertionMatchedExistingVertex firstVertex secondVertex -> indices 5 (T.unVertexId firstVertex) (T.unVertexId secondVertex) T.DegenerateLineEndpointMissingOutgoing vertex -> firstIndex 6 (T.unVertexId vertex) T.DegenerateLineEndpointTurnMissing index -> firstIndex 7 index T.DegenerateLineConnectedVertexMissing index -> firstIndex 8 index T.HullStartNotVisible edge -> firstIndex 9 (T.unDirectedEdgeId edge) - T.OuterRangeDidNotTerminate first second steps -> - (indices 10 (T.unDirectedEdgeId first) (T.unDirectedEdgeId second)) + T.OuterRangeDidNotTerminate firstEdge secondEdge steps -> + (indices 10 (T.unDirectedEdgeId firstEdge) (T.unDirectedEdgeId secondEdge)) {obstructionFirstValue = fromIntegral steps} T.OuterRangeContainsInnerEdge edge face -> indices 11 (T.unDirectedEdgeId edge) (T.unFaceId face) T.ConstrainedEdgeFlipRefused edge -> firstIndex 12 (T.unUndirectedEdgeId edge) @@ -365,8 +1022,8 @@ (indices 22 (T.unVertexId vertex) (T.unDirectedEdgeId edge)) {obstructionFirstValue = fromIntegral steps} T.CircleSweepHullEmpty -> codeOnly 23 - T.OuterCycleDidNotTerminate first second steps -> - (indices 24 (T.unDirectedEdgeId first) (T.unDirectedEdgeId second)) + T.OuterCycleDidNotTerminate firstEdge secondEdge steps -> + (indices 24 (T.unDirectedEdgeId firstEdge) (T.unDirectedEdgeId secondEdge)) {obstructionFirstValue = fromIntegral steps} T.HierarchyLevelPopulationMismatch level expected observed -> (indices 25 expected observed) {obstructionFirstValue = fromIntegral level} @@ -408,18 +1065,18 @@ firstIndex :: Integral index => Word32 -> index -> CObstruction firstIndex code index = (codeOnly code) {obstructionFirstIndex = fromIntegral index} indices :: (Integral first, Integral second) => Word32 -> first -> second -> CObstruction - indices code first second = + indices code firstIndexValue secondIndexValue = (codeOnly code) - { obstructionFirstIndex = fromIntegral first - , obstructionSecondIndex = fromIntegral second + { obstructionFirstIndex = fromIntegral firstIndexValue + , obstructionSecondIndex = fromIntegral secondIndexValue } firstValue :: Word32 -> Double -> CObstruction firstValue code value = (codeOnly code) {obstructionFirstValue = value} values :: Word32 -> Double -> Double -> CObstruction - values code first second = + values code firstCoordinateValue secondCoordinateValue = (codeOnly code) - { obstructionFirstValue = first - , obstructionSecondValue = second + { obstructionFirstValue = firstCoordinateValue + , obstructionSecondValue = secondCoordinateValue } pointObstruction :: Word32 -> Double -> Double -> CObstruction pointObstruction code x y = diff --git a/src-planar/Moonlight/Triangulation/Internal/Minkowski/Convex.hs b/src-planar/Moonlight/Triangulation/Internal/Minkowski/Convex.hs new file mode 100644 --- /dev/null +++ b/src-planar/Moonlight/Triangulation/Internal/Minkowski/Convex.hs @@ -0,0 +1,326 @@ +-- | Pure exact convex-polygon algebra: admission, linear edge-angle +-- convolution, reflection, hull construction, and support-half-plane erosion. +module Moonlight.Triangulation.Internal.Minkowski.Convex + ( convexPolygon + , convexPolygonPoints + , convexPolygonRegion + , admittedConvexLoop + , structuringElement + , structuringElementPolygon + , convexMinkowskiSum + , convexMinkowskiPolygon + , convexHullPolygon + , reflectConvexPolygon + , convexPolygonCentroid + , erodeConvexBy + , addExactPoints + , subtractExactPoints + ) where + +import Control.Monad (foldM) +import Data.Bifunctor (first) +import 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 + , ExactVector (..) + , addExactVectors + , compareExactVectorAngle + , exactVectorFromPoints + , exactSegment + , exactSupportingLineIntersection + , exactOrient2d + , exactPoint + , exactPointCoordinates + , translateExactPoint + ) +import Moonlight.Triangulation.Internal.BoundaryCycle + ( cyclePairs + , cyclePairsNonEmpty + , cyclicTriples + , rotateCycleLeast + , rotateCycleLeastBy + ) +import Moonlight.Triangulation.Internal.ExactRational + ( ExactRational + , exactDivide + ) +import Moonlight.Triangulation.Internal.Minkowski.Types + ( ConvexPolygon (..) + , MinkowskiError (..) + , StructuringElement (..) + ) +import Moonlight.Triangulation.Internal.Region.Types + ( ExactLoop (..) + , PlanarRegion (..) + , PolygonComponent (..) + , RegionPointLocation (..) + ) +import Moonlight.Triangulation.Region + ( exactLoop + , exactLoopPoints + , regionPointLocation + ) + +convexPolygon + :: NonEmpty ExactPoint + -> Either MinkowskiError ConvexPolygon +convexPolygon submitted = do + loop <- first MinkowskiInvalidConvexLoop (exactLoop submitted) + let points = exactLoopPoints loop + case + [ (index, turn) + | (index, (previous, current, next)) <- + zip [0 :: Int ..] (cyclicTriples (NonEmpty.toList points)) + , let turn = exactOrient2d previous current next + , turn /= GT + ] of + (index, turn) : _ -> Left (MinkowskiNonConvexTurn index turn) + [] -> Right (ConvexPolygon loop) + +convexPolygonPoints :: ConvexPolygon -> NonEmpty ExactPoint +convexPolygonPoints (ConvexPolygon loop) = exactLoopPoints loop + +convexPolygonRegion :: ConvexPolygon -> PlanarRegion +convexPolygonRegion (ConvexPolygon loop) = + PlanarRegion [PolygonComponent loop []] + +admittedConvexLoop :: ExactLoop -> Maybe ConvexPolygon +admittedConvexLoop loop + | all ((== GT) . orderedTurn) (cyclicTriples (NonEmpty.toList (exactLoopPoints loop))) = + Just (ConvexPolygon loop) + | otherwise = Nothing + where + orderedTurn (previous, current, next) = + exactOrient2d previous current next + +structuringElement + :: ConvexPolygon + -> Either MinkowskiError StructuringElement +structuringElement polygon = + let origin = exactPoint 0 0 + location = regionPointLocation (convexPolygonRegion polygon) origin + in case location of + RegionExterior -> Left (MinkowskiOriginOutside location) + _ -> Right (StructuringElement polygon) + +structuringElementPolygon :: StructuringElement -> ConvexPolygon +structuringElementPolygon (StructuringElement polygon) = polygon + +convexMinkowskiSum + :: ConvexPolygon + -> ConvexPolygon + -> PlanarRegion +convexMinkowskiSum left right = + convexPolygonRegion (convexMinkowskiPolygon left right) + +convexMinkowskiPolygon + :: ConvexPolygon + -> ConvexPolygon + -> ConvexPolygon +convexMinkowskiPolygon left right = + let leftPoints = rotateCycleLeastBy pointSweepKey (convexPolygonPoints left) + rightPoints = rotateCycleLeastBy pointSweepKey (convexPolygonPoints right) + start = addExactPoints (NonEmpty.head leftPoints) (NonEmpty.head rightPoints) + directions = + mergeDirections + (edgeDirections leftPoints) + (edgeDirections rightPoints) + directionList = NonEmpty.toList directions + scanned = scanl translateExactPoint start directionList + resultPoints = start :| take (length directionList - 1) (drop 1 scanned) + in ConvexPolygon (ExactLoop (rotateCycleLeast resultPoints)) + +convexHullPolygon + :: NonEmpty ExactPoint + -> Either MinkowskiError ConvexPolygon +convexHullPolygon submitted = + let points = NonEmpty.toList submitted + in case convexHullPoints points of + Nothing -> Left (MinkowskiConvexHullDegenerate points) + Just hullPoints -> Right (ConvexPolygon (ExactLoop (rotateCycleLeast hullPoints))) + +reflectConvexPolygon :: ConvexPolygon -> ConvexPolygon +reflectConvexPolygon polygon = + ConvexPolygon + ( ExactLoop + ( rotateCycleLeast + (NonEmpty.reverse (fmap negateExactPoint (convexPolygonPoints polygon))) + ) + ) + +convexPolygonCentroid + :: ConvexPolygon + -> Either MinkowskiError ExactPoint +convexPolygonCentroid polygon = do + let points = convexPolygonPoints polygon + count = fromIntegral (NonEmpty.length points) + (sumX, sumY) = + List.foldl' + (\(accumulatedX, accumulatedY) point -> + let (x, y) = exactPointCoordinates point + in (accumulatedX + x, accumulatedY + y)) + (0, 0) + points + x <- first MinkowskiExactArithmetic (exactDivide sumX count) + y <- first MinkowskiExactArithmetic (exactDivide sumY count) + pure (exactPoint x y) + +-- | Erode one convex polygon by another through the strongest translated +-- support half-plane for each source edge. Sutherland--Hodgman descent keeps +-- the construction exact; a lower-dimensional residual is represented by the +-- empty polygonal region at this two-dimensional publication boundary. +erodeConvexBy + :: ConvexPolygon + -> ConvexPolygon + -> Either MinkowskiError (Maybe ConvexPolygon) +erodeConvexBy source kernel = do + let sourcePoints = convexPolygonPoints source + kernelPoints = convexPolygonPoints kernel + firstKernel = NonEmpty.head kernelPoints + initial = + map + (`subtractExactPoints` firstKernel) + (NonEmpty.toList sourcePoints) + halfPlanes = + [ strongestHalfPlane kernelPoints from to + | (from, to) <- cyclePairs sourcePoints + ] + clipped <- foldM clipPolygon initial halfPlanes + pure (ConvexPolygon . ExactLoop . rotateCycleLeast <$> convexHullPoints clipped) + +edgeDirections :: NonEmpty ExactPoint -> NonEmpty ExactVector +edgeDirections = fmap (uncurry exactVectorFromPoints) . cyclePairsNonEmpty + +mergeDirections + :: NonEmpty ExactVector + -> NonEmpty ExactVector + -> NonEmpty ExactVector +mergeDirections (left :| leftTail) (right :| rightTail) = + case compareExactVectorAngle left right of + LT -> left :| mergeRemaining leftTail (right : rightTail) + GT -> right :| mergeRemaining (left : leftTail) rightTail + EQ -> addExactVectors left right :| mergeRemaining leftTail rightTail + +mergeRemaining :: [ExactVector] -> [ExactVector] -> [ExactVector] +mergeRemaining [] right = right +mergeRemaining left [] = left +mergeRemaining left@(leftHead : leftTail) right@(rightHead : rightTail) = + case compareExactVectorAngle leftHead rightHead of + LT -> leftHead : mergeRemaining leftTail right + GT -> rightHead : mergeRemaining left rightTail + EQ -> addExactVectors leftHead rightHead : mergeRemaining leftTail rightTail + +pointSweepKey :: ExactPoint -> (ExactRational, ExactRational) +pointSweepKey point = + let (x, y) = exactPointCoordinates point + in (y, x) + +convexHullPoints :: [ExactPoint] -> Maybe (NonEmpty ExactPoint) +convexHullPoints submitted = + case Set.toAscList (Set.fromList submitted) of + firstPoint : secondPoint : thirdPoint : remaining -> + let ordered = firstPoint : secondPoint : thirdPoint : remaining + lower = dropFinal (reverse (List.foldl' hullStep [] ordered)) + upper = dropFinal (reverse (List.foldl' hullStep [] (reverse ordered))) + in case lower <> upper of + firstHullPoint : secondHullPoint : thirdHullPoint : hullTail -> + Just (firstHullPoint :| (secondHullPoint : thirdHullPoint : hullTail)) + _ -> Nothing + _ -> Nothing + +hullStep :: [ExactPoint] -> ExactPoint -> [ExactPoint] +hullStep (current : previous : remaining) candidate + | exactOrient2d previous current candidate /= GT = + hullStep (previous : remaining) candidate +hullStep hull candidate = candidate : hull + +dropFinal :: [value] -> [value] +dropFinal values = + case reverse values of + _ : remaining -> reverse remaining + [] -> [] + +strongestHalfPlane + :: NonEmpty ExactPoint + -> ExactPoint + -> ExactPoint + -> (ExactPoint, ExactPoint) +strongestHalfPlane kernelPoints from to = + let direction = exactVectorFromPoints from to + supportPoint = + case kernelPoints of + initial :| remaining -> + List.foldl' + (\selected candidate -> + if directionPointCross direction candidate + < directionPointCross direction selected + then candidate + else selected) + initial + remaining + in ( subtractExactPoints from supportPoint + , subtractExactPoints to supportPoint + ) + +directionPointCross :: ExactVector -> ExactPoint -> ExactRational +directionPointCross (ExactVector directionX directionY) point = + let (x, y) = exactPointCoordinates point + in directionX * y - directionY * x + +clipPolygon + :: [ExactPoint] + -> (ExactPoint, ExactPoint) + -> Either MinkowskiError [ExactPoint] +clipPolygon [] _ = Right [] +clipPolygon polygon halfPlane = + concat <$> traverse (clipEdge halfPlane) (cyclePairsList polygon) + +clipEdge + :: (ExactPoint, ExactPoint) + -> (ExactPoint, ExactPoint) + -> Either MinkowskiError [ExactPoint] +clipEdge (boundaryFrom, boundaryTo) (from, to) = + case (inside from, inside to) of + (True, True) -> Right [to] + (True, False) -> (: []) <$> supportingLineIntersection from to boundaryFrom boundaryTo + (False, True) -> do + crossing <- supportingLineIntersection from to boundaryFrom boundaryTo + pure [crossing, to] + (False, False) -> Right [] + where + inside point = exactOrient2d boundaryFrom boundaryTo point /= LT + +supportingLineIntersection + :: ExactPoint + -> ExactPoint + -> ExactPoint + -> ExactPoint + -> Either MinkowskiError ExactPoint +supportingLineIntersection lineFrom lineTo boundaryFrom boundaryTo = do + clippedSegment <- first MinkowskiInvalidSegment (exactSegment lineFrom lineTo) + boundarySegment <- first MinkowskiInvalidSegment (exactSegment boundaryFrom boundaryTo) + first MinkowskiLineIntersection + (exactSupportingLineIntersection clippedSegment boundarySegment) + +addExactPoints :: ExactPoint -> ExactPoint -> ExactPoint +addExactPoints left right = + let (leftX, leftY) = exactPointCoordinates left + (rightX, rightY) = exactPointCoordinates right + in exactPoint (leftX + rightX) (leftY + rightY) + +subtractExactPoints :: ExactPoint -> ExactPoint -> ExactPoint +subtractExactPoints left right = + let (leftX, leftY) = exactPointCoordinates left + (rightX, rightY) = exactPointCoordinates right + in exactPoint (leftX - rightX) (leftY - rightY) + +negateExactPoint :: ExactPoint -> ExactPoint +negateExactPoint point = + let (x, y) = exactPointCoordinates point + in exactPoint (negate x) (negate y) + +cyclePairsList :: [value] -> [(value, value)] +cyclePairsList = maybe [] cyclePairs . NonEmpty.nonEmpty diff --git a/src-planar/Moonlight/Triangulation/Internal/Minkowski/Types.hs b/src-planar/Moonlight/Triangulation/Internal/Minkowski/Types.hs new file mode 100644 --- /dev/null +++ b/src-planar/Moonlight/Triangulation/Internal/Minkowski/Types.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Closed vocabulary and invariant carriers for exact polygonal morphology. +module Moonlight.Triangulation.Internal.Minkowski.Types + ( ConvexPolygon (..) + , StructuringElement (..) + , MinkowskiOperation (..) + , MinkowskiError (..) + , MinkowskiReceipt (..) + ) where + +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) +import Moonlight.Triangulation.Exact + ( ExactGeometryError + , ExactIntersectionError + , ExactPoint + ) +import Moonlight.Triangulation.Handles.HandleDefs (FaceId) +import Moonlight.Triangulation.Internal.ExactRational (ExactArithmeticError) +import Moonlight.Triangulation.Internal.Overlay.Types + ( OverlayCellId + , OverlayCellWitness + , OverlayError + ) +import Moonlight.Triangulation.Internal.Region.Types + ( ExactLoop + , RegionPublicationError + , RegionPointLocation + , RegionValidationError + ) + +newtype ConvexPolygon = ConvexPolygon ExactLoop + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +newtype StructuringElement = StructuringElement ConvexPolygon + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +data MinkowskiOperation + = MinkowskiAddition + | MinkowskiErosion + | MinkowskiOpening + | MinkowskiClosing + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +data MinkowskiError + = MinkowskiInvalidConvexLoop !RegionValidationError + | MinkowskiInvalidSegment !ExactGeometryError + | MinkowskiNonConvexTurn !Int !Ordering + | MinkowskiOriginOutside !RegionPointLocation + | MinkowskiExactArithmetic !ExactArithmeticError + | MinkowskiLineIntersection !ExactIntersectionError + | MinkowskiOverlayFailed !(OverlayError Bool Bool) + | MinkowskiPublicationFailed !RegionPublicationError + | MinkowskiOverlayCellWitness !OverlayCellWitness + | MinkowskiFaceArity !FaceId !Int + | MinkowskiCandidateCellMissing !OverlayCellId + | MinkowskiInclusionAmbiguous !OverlayCellId !ExactPoint + | MinkowskiConvexHullDegenerate ![ExactPoint] + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +data MinkowskiReceipt = MinkowskiReceipt + { minkowskiOperation :: !MinkowskiOperation + , minkowskiInputComponents :: !Int + , minkowskiConvexPieces :: !Int + , minkowskiGeneratedPieces :: !Int + , minkowskiGeneratedConvolutionEdges :: !Int + , minkowskiOverlayPasses :: !Int + , minkowskiExactCrossings :: !Int + , minkowskiOutputCells :: !Int + , minkowskiExactCoordinateBitGrowth :: !Int + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) diff --git a/src-planar/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs b/src-planar/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs new file mode 100644 --- /dev/null +++ b/src-planar/Moonlight/Triangulation/Internal/Overlay/Arrangement.hs @@ -0,0 +1,814 @@ +{-# 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 + , exactPointFromPoint + , exactSegment + , exactSegmentEndpoints + , exactVectorFromPoints + ) +import Moonlight.Triangulation.Internal.BoundaryCycle + ( consecutivePairs + , orderedPair + , unorderedPairs + ) +import Moonlight.Triangulation.Internal.ExactRational + ( ExactRational + , exactDivide + , exactRationalIsZero + ) +import Moonlight.Triangulation.Internal.ExactSegmentEvents + ( ExactSegmentEvent (..) + , ExactSegmentEventPlan + , ExactSweepSegmentId (..) + , exactSegmentEventPlan + , exactSegmentEvents + , exactSegmentPairChecks + , exactSegmentRelationMap + , exactSegmentSplitPoints + , exactSegmentSweepMaximumHeight + ) +import Moonlight.Triangulation.Internal.Overlay.Embedding + ( DraftId (..) + , DraftIncidence (..) + , DraftNeighborhood (..) + , DraftReference (..) + , DraftVertexId + , ExactArrangementDraft (..) + , LocalEmbeddingCertificate (..) + , OverlayEmbeddingObstruction (..) + , certifyLocalEmbedding + ) +import Moonlight.Triangulation.Internal.Overlay.Types +import Moonlight.Triangulation.Internal.Types (HasPosition (..), Point) +import Moonlight.Triangulation.Region + ( ExactLoop + , PlanarLayer + , PolygonComponent + , exactLoopPoints + , planarLayerOutsideLabel + , planarLayerRegions + , planarRegionComponents + , polygonHoleLoops + , polygonOuterLoop + ) + +type ExactEdgeKey = (ExactPoint, ExactPoint) + +data SourceBoundary leftLabel rightLabel + = LeftSourceBoundary + !ExactSegment + !leftLabel + !(BoundaryVertexRef 'LeftOverlayOperand) + !(BoundaryVertexRef 'LeftOverlayOperand) + !(BoundaryEdgeRef 'LeftOverlayOperand) + | RightSourceBoundary + !ExactSegment + !rightLabel + !(BoundaryVertexRef 'RightOverlayOperand) + !(BoundaryVertexRef 'RightOverlayOperand) + !(BoundaryEdgeRef 'RightOverlayOperand) + +type SourceBoundaryConstructor operand label leftLabel rightLabel = + ExactSegment + -> label + -> BoundaryVertexRef operand + -> BoundaryVertexRef operand + -> BoundaryEdgeRef operand + -> SourceBoundary leftLabel rightLabel + +data AtomicContribution leftLabel rightLabel = + AtomicContribution !(SourceBoundary leftLabel rightLabel) !Bool + +data AtomicEdge leftLabel rightLabel = AtomicEdge + { atomicEdgeSegment :: !ExactSegment + , atomicEdgeOrigin :: !OverlayEdgeOrigin + , atomicEdgeLeftTransition :: !(Maybe (leftLabel, leftLabel)) + , atomicEdgeRightTransition :: !(Maybe (rightLabel, rightLabel)) + } + +data OriginAccumulation = OriginAccumulation + { accumulatedLeftVertices :: !(Set (BoundaryVertexRef 'LeftOverlayOperand)) + , accumulatedRightVertices :: !(Set (BoundaryVertexRef 'RightOverlayOperand)) + , accumulatedLeftEdges :: !(Set (BoundaryEdgeRef 'LeftOverlayOperand)) + , accumulatedRightEdges :: !(Set (BoundaryEdgeRef 'RightOverlayOperand)) + } + +data OverlayVertexSeed = OverlayVertexSeed + { seedExactPoint :: !ExactPoint + , seedEmbeddedPoint :: !Point + , seedOrigin :: !OverlayVertexOrigin + } + deriving stock (Eq, Ord, Show, Generic) + +instance HasPosition OverlayVertexSeed where + position = seedEmbeddedPoint + +data ArrangementMetrics = ArrangementMetrics + { arrangementInputSegments :: !Int + , arrangementRelationEvents :: !Int + , arrangementExactCrossings :: !Int + , arrangementOverlapIntervals :: !Int + , arrangementEmbeddingCandidates :: !Int + , arrangementTotalRelationChecks :: !Int + , arrangementSweepMaximumHeight :: !Int + } + +data CertifiedArrangement leftLabel rightLabel = CertifiedArrangement + { certifiedAtomicEdges :: !(V.Vector (AtomicEdge leftLabel rightLabel)) + , certifiedVertexSeeds :: !(V.Vector OverlayVertexSeed) + , certifiedConstraints :: !(V.Vector (Int, Int)) + , 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) + projectedPoints <- projectedExactPoints localCertificate + let 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 + -> Either (OverlayError leftLabel rightLabel) (Map DraftVertexId ExactPoint) +projectedExactPoints certificate = + Map.traverseWithKey + (\vertex point -> + first + (\projectionError -> + OverlayEmbeddingRefused + (VertexProjectionRefused vertex projectionError :| [])) + (exactPointFromPoint point)) + (certificateRoundedVertices certificate) + +projectedAtomicSegments + :: V.Vector (AtomicEdge leftLabel rightLabel) + -> Map ExactPoint DraftVertexId + -> Map DraftVertexId ExactPoint + -> Either (OverlayError leftLabel rightLabel) (V.Vector ExactSegment) +projectedAtomicSegments edges pointIds projected = + V.imapM project edges + where + project segmentIndex edge = do + fromId <- requireDraftVertex pointIds (atomicEdgeFrom edge) + toId <- requireDraftVertex pointIds (atomicEdgeTo edge) + from <- requireProjected fromId + to <- requireProjected toId + first + (\_ -> + OverlayEmbeddingRefused + ( ProjectedSegmentCollapsed + (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 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-planar/Moonlight/Triangulation/Internal/Overlay/Embedding.hs b/src-planar/Moonlight/Triangulation/Internal/Overlay/Embedding.hs new file mode 100644 --- /dev/null +++ b/src-planar/Moonlight/Triangulation/Internal/Overlay/Embedding.hs @@ -0,0 +1,533 @@ +{-# 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 + ) + +-- | 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 candidate projection certified by the four local obligations. + certificateRoundedVertices :: !(Map DraftVertexId Point) + , -- | The necessarily nonempty global obligation residual. + certificateResidual :: !EmbeddingResidual + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | Certify the four bounded local embedding obligations, collecting every +-- witness within each obligation and preserving obligation order. +certifyLocalEmbedding + :: ExactArrangementDraft + -> Either (NonEmpty OverlayEmbeddingObstruction) LocalEmbeddingCertificate +certifyLocalEmbedding draft = + case NonEmpty.nonEmpty (structuralObstructions draft) of + Just obstructions -> Left obstructions + Nothing -> + case projectVertices (draftVertices draft) of + Invalid obstructions -> Left obstructions + Valid projectedVertices -> + certifyProjectedDraft draft projectedVertices + +data Validation value + = Invalid !(NonEmpty OverlayEmbeddingObstruction) + | Valid value + +instance Functor Validation where + fmap _ (Invalid obstructions) = Invalid obstructions + fmap transform (Valid value) = Valid (transform value) + +instance Applicative Validation where + pure = Valid + Invalid left <*> Invalid right = Invalid (left <> right) + Invalid obstructions <*> Valid _ = Invalid obstructions + Valid _ <*> Invalid obstructions = Invalid obstructions + Valid transform <*> Valid value = Valid (transform value) + +invalid :: OverlayEmbeddingObstruction -> Validation value +invalid obstruction = Invalid (obstruction :| []) + +data ProjectedVertex = ProjectedVertex + { projectedExactPoint :: !ExactPoint + , projectedRoundedPoint :: !Point + } + +data ResolvedSegment = ResolvedSegment + { resolvedSegmentId :: !DraftSegmentId + , resolvedSegmentFrom :: !ResolvedVertex + , resolvedSegmentTo :: !ResolvedVertex + } + +data ResolvedVertex = ResolvedVertex + { resolvedVertexId :: !DraftVertexId + , resolvedProjectedVertex :: !ProjectedVertex + } + +data ResolvedMembership = ResolvedMembership + { resolvedMembershipParameter :: !ExactRational + , resolvedMembershipVertex :: !ResolvedVertex + } + +structuralObstructions + :: ExactArrangementDraft + -> [OverlayEmbeddingObstruction] +structuralObstructions draft = + segmentEndpointObstructions + <> sourceMembershipObstructions + <> incidenceObstructions + <> neighborhoodObstructions + where + vertices = draftVertices draft + segments = draftSegments draft + missingVertex vertexId = + [ DraftReferenceMissing (DraftVertexReference vertexId) + | Map.notMember vertexId vertices + ] + missingSegment segmentId = + [ DraftReferenceMissing (DraftSegmentReference segmentId) + | Map.notMember segmentId segments + ] + segmentEndpointObstructions = + concatMap + (\(_, (from, to)) -> missingVertex from <> missingVertex to) + (Map.toAscList segments) + sourceMembershipObstructions = + concatMap + (concatMap (missingVertex . snd) . snd) + (Map.toAscList (draftSourceMemberships draft)) + incidenceObstructions = + concatMap + ( \incidence -> + missingSegment (draftIncidenceFirstSegment incidence) + <> missingSegment (draftIncidenceSecondSegment incidence) + ) + (draftIncidences draft) + neighborhoodObstructions = + concatMap + ( \neighborhood -> + missingVertex (draftNeighborhoodCenter neighborhood) + <> concatMap missingVertex (draftNeighborhoodNeighbors neighborhood) + ) + (draftNeighborhoods draft) + +projectVertices + :: Map DraftVertexId ExactPoint + -> Validation (Map DraftVertexId ProjectedVertex) +projectVertices = + Map.traverseWithKey + ( \vertexId point -> + case exactPointToEmbeddingCandidate point of + Left projectionError -> + invalid (VertexProjectionRefused vertexId projectionError) + Right roundedPoint -> Valid (ProjectedVertex point roundedPoint) + ) + +certifyProjectedDraft + :: ExactArrangementDraft + -> Map DraftVertexId ProjectedVertex + -> Either (NonEmpty OverlayEmbeddingObstruction) LocalEmbeddingCertificate +certifyProjectedDraft draft projectedVertices = + case resolvedFailures of + Left obstruction -> Left (obstruction :| []) + Right localFailures -> + case NonEmpty.nonEmpty (collisionFailures <> localFailures) of + Just obstructions -> Left obstructions + Nothing -> + Right + LocalEmbeddingCertificate + { certificateRoundedVertexDistinctnessCount = distinctnessCount + , certificateSplitOrderPreservationCount = splitOrderCount + , certificateIncidenceRelationPreservationCount = incidenceCount + , 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 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 = + projectedRoundedPoint + . resolvedProjectedVertex + . resolvedMembershipVertex + +roundedOrderAlong :: Point -> Point -> Point -> Point -> Ordering +roundedOrderAlong + (Point sourceFromX sourceFromY) + (Point sourceToX sourceToY) + (Point leftX leftY) + (Point rightX rightY) = + let directionX = sourceToX - sourceFromX + directionY = sourceToY - sourceFromY + in if abs directionX >= abs directionY + then + if directionX >= 0 + then compare leftX rightX + else compare rightX leftX + else + if directionY >= 0 + then compare leftY rightY + else compare rightY leftY + +incidenceRelationObstructions + :: SegmentRelation + -> ResolvedSegment + -> ResolvedSegment + -> [OverlayEmbeddingObstruction] +incidenceRelationObstructions declaredRelation firstSegment secondSegment = + [ IncidenceRelationChanged + (resolvedSegmentId firstSegment) + (resolvedSegmentId secondSegment) + declaredRelation + exactRelation + roundedRelation + | exactRelation /= declaredRelation || roundedRelation /= declaredRelation + ] + where + exactRelation = + relationFor exactSegmentRelation projectedExactPoint firstSegment secondSegment + roundedRelation = + relationFor Math.segmentRelation projectedRoundedPoint firstSegment secondSegment + +relationFor + :: (point -> point -> point -> point -> SegmentRelation) + -> (ProjectedVertex -> point) + -> ResolvedSegment + -> ResolvedSegment + -> SegmentRelation +relationFor relation project firstSegment secondSegment = + relation + (project (resolvedProjectedVertex (resolvedSegmentFrom firstSegment))) + (project (resolvedProjectedVertex (resolvedSegmentTo firstSegment))) + (project (resolvedProjectedVertex (resolvedSegmentFrom secondSegment))) + (project (resolvedProjectedVertex (resolvedSegmentTo secondSegment))) + +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 = projectedRoundedPoint . resolvedProjectedVertex diff --git a/src-planar/Moonlight/Triangulation/Internal/Overlay/Resident.hs b/src-planar/Moonlight/Triangulation/Internal/Overlay/Resident.hs new file mode 100644 --- /dev/null +++ b/src-planar/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.Handles.HandleDefs + ( DirectedEdgeId + , FaceId + , UndirectedEdgeId + , VertexId + , asUndirected + , directedPair + , reverseEdge + ) +import Moonlight.Triangulation.Handles.Iterators.FixedIterators + ( allFaces + , innerFaces + , undirectedEdges + ) +import Moonlight.Triangulation.Internal.BoxedPaged (boxedFromVector) +import Moonlight.Triangulation.Internal.BoundaryCycle + ( consecutivePairs + , 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-planar/Moonlight/Triangulation/Internal/Overlay/Types.hs b/src-planar/Moonlight/Triangulation/Internal/Overlay/Types.hs new file mode 100644 --- /dev/null +++ b/src-planar/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.Handles.HandleDefs + ( FaceId + , UndirectedEdgeId + , VertexId + ) +import Moonlight.Triangulation.Internal.Cdt.Types (CdtError) +import Moonlight.Triangulation.Internal.ExactRational (ExactArithmeticError) +import Moonlight.Triangulation.Internal.ExactSegmentEvents (ExactSegmentEventObstruction) +import Moonlight.Triangulation.Internal.Overlay.Embedding (OverlayEmbeddingObstruction) +import Moonlight.Triangulation.Internal.Region.Types + ( ExactLoop + , PolygonComponent + , RegionPublicationError + ) +import Moonlight.Triangulation.Internal.Representation (Triangulation) +import Moonlight.Triangulation.Internal.Types + ( ConstraintMode (Constrained) + ) + +-- | Which cycle inside a polygon component supplied a source reference. +data BoundaryLoopRef + = BoundaryOuterLoop + | BoundaryHoleLoop !Int + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +data OverlayOperand + = LeftOverlayOperand + | RightOverlayOperand + +-- | 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-planar/Moonlight/Triangulation/Minkowski.hs b/src-planar/Moonlight/Triangulation/Minkowski.hs new file mode 100644 --- /dev/null +++ b/src-planar/Moonlight/Triangulation/Minkowski.hs @@ -0,0 +1,595 @@ +{-# LANGUAGE DataKinds #-} + +-- | Exact polygonal Minkowski addition and regularized two-dimensional +-- morphology. Convex convolution is direct; nonconvex construction descends +-- through the existing exact overlay, resident CDT, and grouped publication +-- owners. Lower-dimensional erosion residuals cannot inhabit 'PlanarRegion' +-- and therefore publish as empty rather than being forged as polygons. +module Moonlight.Triangulation.Minkowski + ( ConvexPolygon + , convexPolygon + , convexPolygonPoints + , StructuringElement + , structuringElement + , MinkowskiOperation (..) + , MinkowskiError (..) + , MinkowskiReceipt (..) + , convexMinkowskiSum + , minkowskiSum + , erodeBy + , openWith + , closeWith + , polygonOffset + , polygonInset + ) where + +import Control.Applicative ((<|>)) +import Control.Monad (filterM) +import Data.Bifunctor (first) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (fromMaybe) +import qualified Data.Set as Set +import qualified Data.Vector as V +import Moonlight.Triangulation.Dcel + ( faceData + , faceVertices + , vertexData + ) +import Moonlight.Triangulation.Exact + ( ExactPoint + , exactPointCoordinates + ) +import Moonlight.Triangulation.Handles.HandleDefs + ( FaceId + ) +import Moonlight.Triangulation.Handles.Iterators.FixedIterators (innerFaces) +import Moonlight.Triangulation.Internal.ExactRational + ( ExactRational + , exactRationalDenominator + , exactRationalNumerator + ) +import Moonlight.Triangulation.Internal.BoundaryCycle (cyclePairs) +import Moonlight.Triangulation.Internal.Dyadic (integerBitLength) +import Moonlight.Triangulation.Internal.Minkowski.Convex + ( addExactPoints + , admittedConvexLoop + , convexHullPolygon + , convexMinkowskiPolygon + , convexMinkowskiSum + , convexPolygon + , convexPolygonCentroid + , convexPolygonPoints + , convexPolygonRegion + , erodeConvexBy + , reflectConvexPolygon + , structuringElement + , structuringElementPolygon + ) +import Moonlight.Triangulation.Internal.Minkowski.Types +import Moonlight.Triangulation.Internal.Overlay.Resident + ( faceCarriesExactArea + , faceLabels + ) +import Moonlight.Triangulation.Internal.Overlay.Types + ( OverlayCell (..) + , OverlayCellGeometry (..) + , OverlayCellId (..) + , OverlayFace (..) + , OverlayResult (..) + , OverlayVertex (..) + ) +import Moonlight.Triangulation.Overlay + ( OverlayReceipt (..) + , overlayLayers + , overlayReceipt + , overlaySelectedRegion + ) +import Moonlight.Triangulation.Region + ( PlanarLayer + , PlanarRegion + , PolygonComponent + , RegionPointLocation (..) + , emptyPlanarRegion + , exactLoopPoints + , planarLayerRegions + , planarRegionComponents + , polygonHoleLoops + , polygonOuterLoop + , regionPointLocation + ) +import Moonlight.Triangulation.Internal.Region.Publication + ( labelledPlanarLayerFromExactCoordinates + , planarLayerFromAdmittedComponents + ) + +data MorphologyMetrics = MorphologyMetrics + { metricOverlayPasses :: !Int + , metricExactCrossings :: !Int + , metricOutputCells :: !(Maybe Int) + } + +emptyMetrics :: MorphologyMetrics +emptyMetrics = MorphologyMetrics 0 0 Nothing + +appendMetrics :: MorphologyMetrics -> MorphologyMetrics -> MorphologyMetrics +appendMetrics left right = + MorphologyMetrics + { metricOverlayPasses = metricOverlayPasses left + metricOverlayPasses right + , metricExactCrossings = metricExactCrossings left + metricExactCrossings right + , metricOutputCells = metricOutputCells right <|> metricOutputCells left + } + +minkowskiSum + :: PlanarRegion + -> PlanarRegion + -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) +minkowskiSum left right = do + (leftPieces, leftMetrics) <- decomposeRegion left + (rightPieces, rightMetrics) <- decomposeRegion right + let generated = + [ convexMinkowskiPolygon leftPiece rightPiece + | leftPiece <- leftPieces + , rightPiece <- rightPieces + ] + generatedRegions = map convexPolygonRegion generated + convolutionEdges = sum (map (NonEmpty.length . convexPolygonPoints) generated) + (result, unionMetrics) <- unionRegions generatedRegions + let metrics = leftMetrics `appendMetrics` rightMetrics `appendMetrics` unionMetrics + pure + ( result + , MinkowskiReceipt + { minkowskiOperation = MinkowskiAddition + , minkowskiInputComponents = + length (planarRegionComponents left) + + length (planarRegionComponents right) + , minkowskiConvexPieces = length leftPieces + length rightPieces + , minkowskiGeneratedPieces = length generated + , minkowskiGeneratedConvolutionEdges = convolutionEdges + , minkowskiOverlayPasses = metricOverlayPasses metrics + , minkowskiExactCrossings = metricExactCrossings metrics + , minkowskiOutputCells = fromMaybe 0 (metricOutputCells metrics) + , minkowskiExactCoordinateBitGrowth = + coordinateBitGrowth [left, right] result + } + ) + +-- | Erode a polygonal region by an origin-anchored convex kernel and publish +-- the regularized full-dimensional result. A residual consisting only of +-- points or segments is represented by 'emptyPlanarRegion'. +erodeBy + :: StructuringElement + -> PlanarRegion + -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) +erodeBy element source = + case singleConvexRegion source of + Just sourcePolygon -> convexErosion element source sourcePolygon + Nothing -> generalErosion element source + +openWith + :: StructuringElement + -> PlanarRegion + -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) +openWith element source = do + (eroded, erosionReceipt) <- erodeBy element source + (opened, additionReceipt) <- polygonOffset element eroded + pure + ( opened + , composeReceipts + MinkowskiOpening + (length (planarRegionComponents source)) + erosionReceipt + additionReceipt + ) + +closeWith + :: StructuringElement + -> PlanarRegion + -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) +closeWith element source = do + (expanded, additionReceipt) <- polygonOffset element source + (closed, erosionReceipt) <- erodeBy element expanded + pure + ( closed + , composeReceipts + MinkowskiClosing + (length (planarRegionComponents source)) + additionReceipt + erosionReceipt + ) + +polygonOffset + :: StructuringElement + -> PlanarRegion + -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) +polygonOffset element source = + minkowskiSum source (convexPolygonRegion (structuringElementPolygon element)) + +polygonInset + :: StructuringElement + -> PlanarRegion + -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) +polygonInset = erodeBy + +decomposeRegion + :: PlanarRegion + -> Either MinkowskiError ([ConvexPolygon], MorphologyMetrics) +decomposeRegion region = + case traverse convexComponent (planarRegionComponents region) of + Just convexPieces -> Right (convexPieces, emptyMetrics) + Nothing -> triangulatedPieces region + +convexComponent :: PolygonComponent -> Maybe ConvexPolygon +convexComponent component = + case polygonHoleLoops component of + [] -> admittedConvexLoop (polygonOuterLoop component) + _ -> Nothing + +singleConvexRegion :: PlanarRegion -> Maybe ConvexPolygon +singleConvexRegion region = + case planarRegionComponents region of + [component] -> convexComponent component + _ -> Nothing + +triangulatedPieces + :: PlanarRegion + -> Either MinkowskiError ([ConvexPolygon], MorphologyMetrics) +triangulatedPieces region = do + let sourceLayer = morphologyLayer region + result <- first MinkowskiOverlayFailed (overlayLayers sourceLayer emptyMorphologyLayer) + selectedFaces <- + filterM + (\face -> + if faceCarriesExactArea result face + then + fmap fst + ( first MinkowskiOverlayCellWitness + (faceLabels result face) + ) + else Right False) + (innerFaces (overlayResultTriangulation result)) + pieces <- traverse (faceConvexPolygon result) selectedFaces + pure (pieces, metricsFromOverlay result (length pieces)) + +faceConvexPolygon + :: OverlayResult leftLabel rightLabel + -> FaceId + -> Either MinkowskiError ConvexPolygon +faceConvexPolygon result face = + case + map + (overlayExactPoint . vertexData triangulation) + (faceVertices triangulation face) of + [firstPoint, secondPoint, thirdPoint] -> + convexHullPolygon (firstPoint :| [secondPoint, thirdPoint]) + vertices -> Left (MinkowskiFaceArity face (length vertices)) + where + triangulation = overlayResultTriangulation result + +unionRegions + :: [PlanarRegion] + -> Either MinkowskiError (PlanarRegion, MorphologyMetrics) +unionRegions [] = Right (emptyPlanarRegion, emptyMetrics) +unionRegions [region] = + Right + ( region + , emptyMetrics{metricOutputCells = Just (length (planarRegionComponents region))} + ) +unionRegions regions = do + let (leftRegions, rightRegions) = splitAt (length regions `div` 2) regions + left <- unionRegions leftRegions + right <- unionRegions rightRegions + glueRegionUnion left right + +glueRegionUnion + :: (PlanarRegion, MorphologyMetrics) + -> (PlanarRegion, MorphologyMetrics) + -> Either MinkowskiError (PlanarRegion, MorphologyMetrics) +glueRegionUnion (left, leftMetrics) (right, rightMetrics) + | null (planarRegionComponents left) = Right (right, leftMetrics `appendMetrics` rightMetrics) + | null (planarRegionComponents right) = Right (left, leftMetrics `appendMetrics` rightMetrics) + | otherwise = do + result <- + first MinkowskiOverlayFailed + (overlayLayers (morphologyLayer left) (morphologyLayer right)) + published <- + first MinkowskiPublicationFailed + ( overlaySelectedRegion + (uncurry (||)) + result + ) + let selectedCells = + V.foldl' + (\count cell -> + case overlayCellGeometry cell of + BoundedOverlayCell _ + | overlayCellLeft cell || overlayCellRight cell -> + count + 1 + _ -> count) + 0 + (overlayResultCells result) + pure + ( published + , leftMetrics + `appendMetrics` rightMetrics + `appendMetrics` metricsFromOverlay result selectedCells + ) + +convexErosion + :: StructuringElement + -> PlanarRegion + -> ConvexPolygon + -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) +convexErosion element source sourcePolygon = do + eroded <- erodeConvexBy sourcePolygon (structuringElementPolygon element) + let result = maybe emptyPlanarRegion convexPolygonRegion eroded + outputCells = maybe 0 (const 1) eroded + generatedEdges = maybe 0 (NonEmpty.length . convexPolygonPoints) eroded + pure + ( result + , MinkowskiReceipt + { minkowskiOperation = MinkowskiErosion + , minkowskiInputComponents = 1 + , minkowskiConvexPieces = 2 + , minkowskiGeneratedPieces = outputCells + , minkowskiGeneratedConvolutionEdges = generatedEdges + , minkowskiOverlayPasses = 0 + , minkowskiExactCrossings = 0 + , minkowskiOutputCells = outputCells + , minkowskiExactCoordinateBitGrowth = + coordinateBitGrowth + [ source + , convexPolygonRegion (structuringElementPolygon element) + ] + result + } + ) + +generalErosion + :: StructuringElement + -> PlanarRegion + -> Either MinkowskiError (PlanarRegion, MinkowskiReceipt) +generalErosion element source + | null sourceEdges = Right (emptyPlanarRegion, emptyErosionReceipt) + | otherwise = do + sweptPolygons <- traverse (sweepBoundaryEdge reflectedKernel) sourceEdges + let sweptRegions = map convexPolygonRegion sweptPolygons + generatedEdges = + sum (map (NonEmpty.length . convexPolygonPoints) sweptPolygons) + (contactRegion, unionMetrics) <- unionRegions sweptRegions + candidateOverlay <- + first MinkowskiOverlayFailed + (overlayLayers (morphologyLayer contactRegion) emptyMorphologyLayer) + kernelWitness <- convexPolygonCentroid kernel + let representativeFaceByCell = representativeFaces candidateOverlay + selectedCellIds <- + Set.fromList + <$> filterM + ( classifyCandidateCell + source + kernelWitness + representativeFaceByCell + candidateOverlay + ) + (boundedOutsideCellIds candidateOverlay) + published <- publishCellSelection selectedCellIds candidateOverlay + let candidateMetrics = + metricsFromOverlay candidateOverlay (Set.size selectedCellIds) + metrics = unionMetrics `appendMetrics` candidateMetrics + pure + ( published + , MinkowskiReceipt + { minkowskiOperation = MinkowskiErosion + , minkowskiInputComponents = length (planarRegionComponents source) + , minkowskiConvexPieces = 1 + , minkowskiGeneratedPieces = length sweptPolygons + , minkowskiGeneratedConvolutionEdges = generatedEdges + , minkowskiOverlayPasses = metricOverlayPasses metrics + , minkowskiExactCrossings = metricExactCrossings metrics + , minkowskiOutputCells = Set.size selectedCellIds + , minkowskiExactCoordinateBitGrowth = + coordinateBitGrowth + [source, convexPolygonRegion kernel] + published + } + ) + where + kernel = structuringElementPolygon element + reflectedKernel = reflectConvexPolygon kernel + sourceEdges = regionBoundaryEdges source + emptyErosionReceipt = + MinkowskiReceipt + { minkowskiOperation = MinkowskiErosion + , minkowskiInputComponents = 0 + , minkowskiConvexPieces = 1 + , minkowskiGeneratedPieces = 0 + , minkowskiGeneratedConvolutionEdges = 0 + , minkowskiOverlayPasses = 0 + , minkowskiExactCrossings = 0 + , minkowskiOutputCells = 0 + , minkowskiExactCoordinateBitGrowth = 0 + } + +sweepBoundaryEdge + :: ConvexPolygon + -> (ExactPoint, ExactPoint) + -> Either MinkowskiError ConvexPolygon +sweepBoundaryEdge reflectedKernel (from, to) = + case convexPolygonPoints reflectedKernel of + firstKernelPoint :| remainingKernelPoints -> + convexHullPolygon + ( addExactPoints from firstKernelPoint + :| ( map (addExactPoints from) remainingKernelPoints + <> map (addExactPoints to) kernelPoints + ) + ) + where + kernelPoints = NonEmpty.toList (convexPolygonPoints reflectedKernel) + +boundedOutsideCellIds + :: OverlayResult Bool Bool + -> [OverlayCellId] +boundedOutsideCellIds result = + V.ifoldr + (\index cell selected -> + case overlayCellGeometry cell of + BoundedOverlayCell _ + | not (overlayCellLeft cell) + && not (overlayCellRight cell) -> + OverlayCellId index : selected + _ -> selected) + [] + (overlayResultCells result) + +classifyCandidateCell + :: PlanarRegion + -> ExactPoint + -> IntMap.IntMap FaceId + -> OverlayResult Bool Bool + -> OverlayCellId + -> Either MinkowskiError Bool +classifyCandidateCell source kernelWitness representativeFaceByCell result cellId = do + face <- + maybe + (Left (MinkowskiCandidateCellMissing cellId)) + Right + (IntMap.lookup (overlayCellIndex cellId) representativeFaceByCell) + candidate <- convexPolygonCentroid =<< faceConvexPolygon result face + let inclusionWitness = addExactPoints candidate kernelWitness + case regionPointLocation source inclusionWitness of + RegionInterior -> Right True + RegionExterior -> Right False + RegionOnBoundary -> Left (MinkowskiInclusionAmbiguous cellId inclusionWitness) + +representativeFaces + :: OverlayResult leftLabel rightLabel + -> IntMap.IntMap FaceId +representativeFaces result = + IntMap.fromListWith min + [ (overlayCellIndex (overlayFaceCellId (faceData triangulation face)), face) + | face <- innerFaces triangulation + , faceCarriesExactArea result face + ] + where + triangulation = overlayResultTriangulation result + +overlayCellIndex :: OverlayCellId -> Int +overlayCellIndex (OverlayCellId index) = index + +publishCellSelection + :: Set.Set OverlayCellId + -> OverlayResult leftLabel rightLabel + -> Either MinkowskiError PlanarRegion +publishCellSelection selected result = do + layer <- + first MinkowskiPublicationFailed + ( labelledPlanarLayerFromExactCoordinates + False + triangulation + (\vertex -> Right (overlayExactPoint (vertexData triangulation vertex))) + (\face -> + if faceCarriesExactArea result face + then + Right + ( Set.member + (overlayFaceCellId (faceData triangulation face)) + selected + ) + else Right False) + ) + pure (Map.findWithDefault emptyPlanarRegion True (planarLayerRegions layer)) + where + triangulation = overlayResultTriangulation result + +morphologyLayer + :: PlanarRegion + -> PlanarLayer Bool +morphologyLayer region = + planarLayerFromAdmittedComponents + False + [(True, component) | component <- planarRegionComponents region] + +emptyMorphologyLayer :: PlanarLayer Bool +emptyMorphologyLayer = morphologyLayer emptyPlanarRegion + +regionBoundaryEdges :: PlanarRegion -> [(ExactPoint, ExactPoint)] +regionBoundaryEdges region = + concatMap + (\component -> + concatMap + (cyclePairs . exactLoopPoints) + (polygonOuterLoop component : polygonHoleLoops component)) + (planarRegionComponents region) + +metricsFromOverlay + :: OverlayResult leftLabel rightLabel + -> Int + -> MorphologyMetrics +metricsFromOverlay result outputCells = + MorphologyMetrics + { metricOverlayPasses = 1 + , metricExactCrossings = overlayExactCrossings (overlayReceipt result) + , metricOutputCells = Just outputCells + } + +composeReceipts + :: MinkowskiOperation + -> Int + -> MinkowskiReceipt + -> MinkowskiReceipt + -> MinkowskiReceipt +composeReceipts operation inputComponents firstReceipt secondReceipt = + MinkowskiReceipt + { minkowskiOperation = operation + , minkowskiInputComponents = inputComponents + , minkowskiConvexPieces = + minkowskiConvexPieces firstReceipt + + minkowskiConvexPieces secondReceipt + , minkowskiGeneratedPieces = + minkowskiGeneratedPieces firstReceipt + + minkowskiGeneratedPieces secondReceipt + , minkowskiGeneratedConvolutionEdges = + minkowskiGeneratedConvolutionEdges firstReceipt + + minkowskiGeneratedConvolutionEdges secondReceipt + , minkowskiOverlayPasses = + minkowskiOverlayPasses firstReceipt + + minkowskiOverlayPasses secondReceipt + , minkowskiExactCrossings = + minkowskiExactCrossings firstReceipt + + minkowskiExactCrossings secondReceipt + , minkowskiOutputCells = minkowskiOutputCells secondReceipt + , minkowskiExactCoordinateBitGrowth = + max + (minkowskiExactCoordinateBitGrowth firstReceipt) + (minkowskiExactCoordinateBitGrowth secondReceipt) + } + +coordinateBitGrowth :: [PlanarRegion] -> PlanarRegion -> Int +coordinateBitGrowth inputs output = + max 0 + ( regionCoordinateBits output + - List.foldl' (\maximumBits -> max maximumBits . regionCoordinateBits) 0 inputs + ) + +regionCoordinateBits :: PlanarRegion -> Int +regionCoordinateBits = List.foldl' componentBits 0 . planarRegionComponents + where + componentBits maximumBits component = + List.foldl' + loopBits + maximumBits + (polygonOuterLoop component : polygonHoleLoops component) + loopBits maximumBits = + List.foldl' pointBits maximumBits . exactLoopPoints + pointBits maximumBits point = + let (x, y) = exactPointCoordinates point + in max maximumBits (max (rationalBits x) (rationalBits y)) + +rationalBits :: ExactRational -> Int +rationalBits value = + max + (integerBitLength (abs (exactRationalNumerator value))) + (integerBitLength (exactRationalDenominator value)) diff --git a/src-planar/Moonlight/Triangulation/Overlay.hs b/src-planar/Moonlight/Triangulation/Overlay.hs new file mode 100644 --- /dev/null +++ b/src-planar/Moonlight/Triangulation/Overlay.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Exact labelled common refinement. Source boundaries descend through one +-- exact segment-event plan, glue into canonical atomic constraints, and are +-- admitted only when their binary64 DCEL realization preserves every exact +-- relation. +module Moonlight.Triangulation.Overlay + ( BoundaryLoopRef (..) + , OverlayOperand + , BoundaryRef + , BoundaryVertexRef + , BoundaryEdgeRef + , boundaryRefComponent + , boundaryRefLoop + , boundaryRefLocalIndex + , OverlayVertexOrigin + , overlayOriginLeftVertices + , overlayOriginRightVertices + , overlayOriginLeftEdges + , overlayOriginRightEdges + , OverlayEdgeOrigin + , overlayEdgeLeftSources + , overlayEdgeRightSources + , OverlaySupport + , overlaySupportLabels + , OverlayCellSupport (..) + , OverlayCellId (..) + , OverlayCellGeometry (..) + , OverlayCell (..) + , OverlayFace (..) + , OverlayVertex (..) + , OverlayEdge (..) + , OverlayReceipt (..) + , OverlayArrangementObstruction (..) + , OverlayCellWitness (..) + , OverlayError (..) + , OverlayResult + , OverlaySelectionKind (..) + , OverlaySelectionError (..) + , overlayLayers + , overlayEmbeddedTriangulation + , overlayReceipt + , overlayCells + , overlayArrangementVertices + , overlayArrangementEdges + , overlayPlanarLayer + , overlaySelectedRegion + , overlayClosedUnion + , overlayClosedIntersection + , overlayRegularizedDifference + ) where + +import Data.Bifunctor (first) +import Control.Monad (filterM) +import qualified Data.Map.Strict as Map +import qualified Data.Vector as V +import Moonlight.Triangulation.CellSet (ExactCellSet) +import qualified Moonlight.Triangulation.Dcel as Dcel +import Moonlight.Triangulation.Dcel (vertexData) +import Moonlight.Triangulation.Handles.HandleDefs + ( UndirectedEdgeId + , VertexId + ) +import Moonlight.Triangulation.Handles.Iterators.FixedIterators + ( innerFaces + , undirectedEdges + , vertices + ) +import Moonlight.Triangulation.Internal.CellSet (closeExactCellSetWith) +import Moonlight.Triangulation.Internal.Overlay.Arrangement + ( certifyArrangement + ) +import Moonlight.Triangulation.Internal.Overlay.Resident + ( OverlayDiagonalSchedule (CanonicalOverlayDiagonals) + , edgeSupport + , faceCarriesExactArea + , faceLabels + , regionFaceLabels + , residentOverlay + , vertexSupport + ) +import Moonlight.Triangulation.Internal.Overlay.Types +import Moonlight.Triangulation.Internal.Representation (Triangulation) +import Moonlight.Triangulation.Internal.Types + ( ConstraintMode (Constrained) + ) +import Moonlight.Triangulation.Region + ( PlanarLayer + , PlanarRegion + , RegionPublicationError (..) + , emptyPlanarRegion + , planarLayerOutsideLabel + , planarLayerRegions + ) +import Moonlight.Triangulation.Internal.Region.Publication + ( labelledPlanarLayerFromExactCoordinates + , planarLayerFromAdmittedComponents + ) + +-- | Construct the exact common refinement and its one faithful resident DCEL. +overlayLayers + :: (Ord leftLabel, Ord rightLabel) + => PlanarLayer leftLabel + -> PlanarLayer rightLabel + -> Either + (OverlayError leftLabel rightLabel) + (OverlayResult leftLabel rightLabel) +overlayLayers leftLayer rightLayer = do + certified <- certifyArrangement leftLayer rightLayer + residentOverlay + CanonicalOverlayDiagonals + (planarLayerOutsideLabel leftLayer, planarLayerOutsideLabel rightLayer) + certified + +-- | The binary64 realization used by existing DCEL observations. Exact overlay +-- operations accept 'OverlayResult', never this projection. +overlayEmbeddedTriangulation + :: OverlayResult leftLabel rightLabel + -> Triangulation + 'Constrained + OverlayVertex + () + OverlayEdge + OverlayFace +overlayEmbeddedTriangulation = overlayResultTriangulation + +overlayReceipt :: OverlayResult leftLabel rightLabel -> OverlayReceipt +overlayReceipt = overlayResultReceipt + +overlayCells + :: OverlayResult leftLabel rightLabel + -> [(OverlayCellId, OverlayCell leftLabel rightLabel)] +overlayCells result = + V.toList + (V.imap (\index cell -> (OverlayCellId index, cell)) (overlayResultCells result)) + +overlayArrangementVertices + :: OverlayResult leftLabel rightLabel + -> [(VertexId, OverlayVertex)] +overlayArrangementVertices result = + let triangulation = overlayResultTriangulation result + in [(vertex, vertexData triangulation vertex) | vertex <- vertices triangulation] + +overlayArrangementEdges + :: OverlayResult leftLabel rightLabel + -> [(UndirectedEdgeId, OverlayEdgeOrigin)] +overlayArrangementEdges result = + let triangulation = overlayResultTriangulation result + in [ (edge, origin) + | edge <- undirectedEdges triangulation + , OverlayBoundary origin <- [Dcel.undirectedEdgeData triangulation edge] + ] + +-- | Publish the already-admitted bounded cell geometry. The resident DCEL is +-- a realization of these exact cells, not a second authoring source. +overlayPlanarLayer + :: (Ord leftLabel, Ord rightLabel) + => OverlayResult leftLabel rightLabel + -> PlanarLayer (leftLabel, rightLabel) +overlayPlanarLayer result = + planarLayerFromAdmittedComponents + (overlayResultOutsideLabels result) + [ ( (overlayCellLeft cell, overlayCellRight cell) + , component + ) + | cell <- V.toList (overlayResultCells result) + , (overlayCellLeft cell, overlayCellRight cell) + /= overlayResultOutsideLabels result + , BoundedOverlayCell component <- [overlayCellGeometry cell] + ] + +-- | Publish the selected two-dimensional cells. Internal arrangement edges +-- between differently labelled but jointly selected cells dissolve because +-- selection precedes component descent. +overlaySelectedRegion + :: ((leftLabel, rightLabel) -> Bool) + -> OverlayResult leftLabel rightLabel + -> Either RegionPublicationError PlanarRegion +overlaySelectedRegion selected result + | selected (overlayResultOutsideLabels result) = Left RegionUnboundedSelection + | otherwise = do + published <- + labelledPlanarLayerFromExactCoordinates + False + triangulation + exactPointAt + labelFace + pure (Map.findWithDefault emptyPlanarRegion True (planarLayerRegions published)) + where + triangulation = overlayResultTriangulation result + exactPointAt vertex = Right (overlayExactPoint (vertexData triangulation vertex)) + labelFace face + | faceCarriesExactArea result face = + selected <$> regionFaceLabels result face + | otherwise = Right False + +overlayClosedUnion + :: (Ord leftLabel, Ord rightLabel) + => (leftLabel -> Bool) + -> (rightLabel -> Bool) + -> OverlayResult leftLabel rightLabel + -> Either OverlaySelectionError ExactCellSet +overlayClosedUnion selectLeft selectRight = + selectClosedCells + ClosedUnionSelection + (\support -> supportAny selectLeft (overlaySupportLeft support) || supportAny selectRight (overlaySupportRight support)) + (\leftLabel rightLabel -> selectLeft leftLabel || selectRight rightLabel) + +overlayClosedIntersection + :: (Ord leftLabel, Ord rightLabel) + => (leftLabel -> Bool) + -> (rightLabel -> Bool) + -> OverlayResult leftLabel rightLabel + -> Either OverlaySelectionError ExactCellSet +overlayClosedIntersection selectLeft selectRight = + selectClosedCells + ClosedIntersectionSelection + (\support -> supportAny selectLeft (overlaySupportLeft support) && supportAny selectRight (overlaySupportRight support)) + (\leftLabel rightLabel -> selectLeft leftLabel && selectRight rightLabel) + +overlayRegularizedDifference + :: (leftLabel -> Bool) + -> (rightLabel -> Bool) + -> OverlayResult leftLabel rightLabel + -> Either OverlaySelectionError ExactCellSet +overlayRegularizedDifference selectLeft selectRight result = + let outsidePair = overlayResultOutsideLabels result + selectFace leftLabel rightLabel = selectLeft leftLabel && not (selectRight rightLabel) + in if uncurry selectFace outsidePair + then Left (OverlaySelectionContainsUnboundedCell RegularizedDifferenceSelection) + else closeSelectedCells [] [] selectFace result + +selectClosedCells + :: (Ord leftLabel, Ord rightLabel) + => OverlaySelectionKind + -> (OverlayCellSupport leftLabel rightLabel -> Bool) + -> (leftLabel -> rightLabel -> Bool) + -> OverlayResult leftLabel rightLabel + -> Either OverlaySelectionError ExactCellSet +selectClosedCells selectionKind selectSupport selectFace result = + let outsidePair = overlayResultOutsideLabels result + triangulation = overlayResultTriangulation result + in if uncurry selectFace outsidePair + then Left (OverlaySelectionContainsUnboundedCell selectionKind) + else do + selectedVertices <- + filterM + ( fmap selectSupport + . first OverlaySelectionProvenance + . vertexSupport result + ) + (vertices triangulation) + selectedEdges <- + filterM + (\edge -> + case Dcel.undirectedEdgeData triangulation edge of + OverlayDiagonal -> Right False + OverlayBoundary _ -> + selectSupport + <$> first OverlaySelectionProvenance (edgeSupport result edge)) + (undirectedEdges triangulation) + closeSelectedCells selectedVertices selectedEdges selectFace result + +closeSelectedCells + :: [VertexId] + -> [UndirectedEdgeId] + -> (leftLabel -> rightLabel -> Bool) + -> OverlayResult leftLabel rightLabel + -> Either OverlaySelectionError ExactCellSet +closeSelectedCells selectedVertices selectedEdges selectFace result = + let triangulation = overlayResultTriangulation result + exactPointAt vertex = Right (overlayExactPoint (vertexData triangulation vertex)) + in do + selectedFaces <- + filterM + (\face -> + if faceCarriesExactArea result face + then + fmap (uncurry selectFace) + ( first OverlaySelectionProvenance + (faceLabels result face) + ) + else Right False) + (innerFaces triangulation) + first OverlaySelectionInvalid + ( closeExactCellSetWith + exactPointAt + triangulation + selectedVertices + selectedEdges + selectedFaces + ) + +supportAny :: (label -> Bool) -> OverlaySupport label -> Bool +supportAny predicate = any predicate . overlaySupportLabels 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 @@ -98,10 +98,12 @@ , conflictFirstSegment , conflictSecondSegment , ConstrainedUnionError (..) + , ConstraintBatchResult + , constraintBatchTriangulation + , constraintBatchOutcomes + , constraintBatchStats , ConstrainedExtensionResult - , constrainedExtensionTriangulation - , constrainedExtensionConstraintOutcomes - , constrainedExtensionConstraintStats + , constrainedExtensionConstraintBatch , constrainedExtensionBuildStats , ConstrainedSeamSource (..) , ConstrainedSeamFaceEvidence @@ -186,13 +188,16 @@ -- ** Face regions and alpha filtration , FaceComponent , faceComponentFaces + , BoundaryOrientation (..) , BoundaryLoop + , boundaryLoopOrientation , boundaryLoopVertices , RegionBoundary , regionBoundaryOuterLoop , regionBoundaryHoleLoops , BoundaryObstruction (..) , faceComponents + , componentBoundaryLoops , componentBoundary , RadiusSquared , RadiusSquaredError (..) @@ -289,6 +294,7 @@ , ValuationError (..) , cellValuations , regionValuations + , planarValuationsPerimeter , cellSetPerimeter , regionPerimeter , ConvexPolygon @@ -355,13 +361,16 @@ import Moonlight.Triangulation.FloodFillIterator ( BoundaryLoop , BoundaryObstruction (..) + , BoundaryOrientation (..) , FaceComponent , RadiusSquared , RegionBoundary , RadiusSquaredError (..) , alphaShapeContainsFace + , boundaryLoopOrientation , boundaryLoopVertices , componentBoundary + , componentBoundaryLoops , faceComponentFaces , faceComponents , facesAtEvenBarrierDepth @@ -419,12 +428,14 @@ , ConstrainedSeamFaceEvidence , ConstrainedSeamResult , ConstrainedSeamSource (..) + , ConstraintBatchResult , ConstraintConflict , CorridorObstruction (..) , constrainedExtensionBuildStats - , constrainedExtensionConstraintOutcomes - , constrainedExtensionConstraintStats - , constrainedExtensionTriangulation + , constrainedExtensionConstraintBatch + , constraintBatchOutcomes + , constraintBatchStats + , constraintBatchTriangulation , constrainedSeamBuildStats , constrainedSeamConstraintRecovery , constrainedSeamConstraintSegment @@ -602,6 +613,7 @@ , exactLengthExpression , exactLengthTerms , lengthCoefficient + , planarValuationsPerimeter , regionPerimeter , regionValuations , squaredLength diff --git a/src-public/Moonlight/Triangulation/HintGenerator.hs b/src-public/Moonlight/Triangulation/HintGenerator.hs new file mode 100644 --- /dev/null +++ b/src-public/Moonlight/Triangulation/HintGenerator.hs @@ -0,0 +1,492 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} + +-- | Reusable point-location hints and their topology-preserving maintenance. +module Moonlight.Triangulation.HintGenerator + ( LastUsedHint + , emptyLastUsedHint + , lastUsedHint + , rememberVertex + , HierarchyHint + , defaultHierarchyBranchFactor + , buildHierarchyHint + , hierarchyHint + , hierarchyBranchFactor + , hierarchyBaseCount + , hierarchyLevelCount + , hierarchyVertexCount + , updateHierarchyAfterInsertion + , updateHierarchyAfterRemoval + , rebuildHierarchyHint + , removeManyWithHierarchy + ) where + +import qualified Data.Vector as V +import Control.DeepSeq (NFData) +import Data.List (sort) +import Data.Word (Word32) +import Moonlight.Triangulation.BulkLoad (delaunay, insert) +import Moonlight.Triangulation.Dcel (numUndirectedEdges, numVertices, undirectedEndpoints, vertexPoint) +import Moonlight.Triangulation.Handles.HandleDefs (UndirectedEdgeId (..), VertexId (..)) +import Moonlight.Triangulation.Interpolation (nearestNeighbor) +import Moonlight.Triangulation.Math (canonicalPoint, validatePoint) +import Moonlight.Triangulation.Removal (RemovalOutcome, removalTriangulation, removeVertex) +import Moonlight.Triangulation.Session (removeManyAtNear, withSession) +import Moonlight.Triangulation.Types +import GHC.Generics (Generic) + +-- | Most recently admitted vertex, suitable as the next descent seed. +newtype LastUsedHint = LastUsedHint (Maybe VertexId) + deriving stock (Show) + deriving newtype (Eq, Ord) + +-- | A last-used hint with no remembered vertex. +emptyLastUsedHint :: LastUsedHint +emptyLastUsedHint = LastUsedHint Nothing + +-- | Project a remembered vertex into a location hint. +lastUsedHint :: LastUsedHint -> Maybe LocationHint +lastUsedHint (LastUsedHint vertex) = VertexHint <$> vertex + +-- | Replace the remembered vertex. +rememberVertex :: VertexId -> LastUsedHint -> LastUsedHint +rememberVertex vertex _ = LastUsedHint (Just vertex) + +-- | A Delaunay hierarchy for logarithmic expected random point location. +-- The first vector element is the finest sparse level; the final element is +-- the coarsest. The base triangulation is not duplicated. +-- +-- The levels are nested by a single arithmetic law rather than by a stored +-- correspondence. Level @i@ holds every @branch^(i+1)@-th base vertex in base +-- order, so a level-local handle @j@ names handle @j * branch@ one level finer +-- — and at level 0 the finer level is the base mesh itself, under the very +-- same multiplication. Descent therefore never rediscovers a handle it has +-- already computed, and no level carries an index vector. +-- +-- 'hierarchyBaseCount' is the base cardinality the levels were sampled from. +-- It is the hierarchy's claim about which triangulation it answers for, and +-- every maintenance entry is stated against it: a base whose cardinality is not +-- the one recorded here plus the movement the operation performs is not the +-- base this hierarchy describes, and is rebuilt for rather than patched. +data HierarchyHint = HierarchyHint + { hierarchyBranchFactor :: {-# UNPACK #-} !Int + -- ^ Sampling stride between adjacent hierarchy levels. + , hierarchyBaseCount :: {-# UNPACK #-} !Int + -- ^ Cardinality of the base mesh described by the hierarchy. + , hierarchyLevels :: !(V.Vector (Triangulation 'Unconstrained (Point) () () ())) + } + deriving stock (Generic) + deriving anyclass (NFData) + +instance Show (HierarchyHint) where + showsPrec precedence hierarchy = + showParen (precedence > 10) $ + showString "HierarchyHint " + . shows (hierarchyBranchFactor hierarchy) + . showString " " + . shows (hierarchyBaseCount hierarchy) + . showString " " + . shows (hierarchyLevelCount hierarchy) + . showString " " + . shows (hierarchyVertexCount hierarchy) + +instance Eq (HierarchyHint) where + left == right = + hierarchyBranchFactor left == hierarchyBranchFactor right + && hierarchyBaseCount left == hierarchyBaseCount right + && hierarchyLevelCount left == hierarchyLevelCount right + && V.and (V.zipWith sameSparseMesh (hierarchyLevels left) (hierarchyLevels right)) + +-- Two sparse levels are the same hint when they carry the same points and the +-- same undirected edges. Half-edge index labelling records the order +-- construction happened to visit, so a level rebuilt from scratch and a level +-- extended in place are structurally equal while their arrays are not. +sameSparseMesh + :: Triangulation 'Unconstrained (Point) () () () + -> Triangulation 'Unconstrained (Point) () () () + -> Bool +sameSparseMesh left right = + numVertices left == numVertices right + && numUndirectedEdges left == numUndirectedEdges right + && meshPoints left == meshPoints right + && meshEdges left == meshEdges right + where + meshPoints + :: Triangulation mode vertex directed undirected face + -> [Point] + meshPoints triangulation = + sort [vertexPoint triangulation (VertexId (fromIntegral index)) | index <- [0 .. numVertices triangulation - 1]] + + meshEdges + :: Triangulation mode vertex directed undirected face + -> [(Point, Point)] + meshEdges triangulation = + sort + [ if from <= to then (from, to) else (to, from) + | index <- [0 .. numUndirectedEdges triangulation - 1] + , let (fromVertex, toVertex) = undirectedEndpoints triangulation (UndirectedEdgeId (fromIntegral index)) + from = vertexPoint triangulation fromVertex + to = vertexPoint triangulation toVertex + ] + +-- | Default sampling stride between hierarchy levels. +defaultHierarchyBranchFactor :: Int +defaultHierarchyBranchFactor = 16 + +-- | Number of stored sparse levels. +hierarchyLevelCount :: HierarchyHint -> Int +hierarchyLevelCount = V.length . hierarchyLevels + +-- | Total vertices retained across every sparse level. +hierarchyVertexCount :: HierarchyHint -> Int +hierarchyVertexCount = + V.foldl' (\total level -> total + numVertices level) 0 . hierarchyLevels + +-- | Build nested sparse Delaunay levels. A branch factor of 16 mirrors Spade's +-- default and gives O(log n) expected descent on uniformly distributed input. +-- +-- Each level is bulk loaded from the sampled points in base order. Base +-- vertices carry pairwise distinct positions, so the load deduplicates nothing +-- and assigns local handle @j@ to sample @j@ — which is what makes the nesting +-- law on 'hierarchyLevels' an identity rather than a lookup. +buildHierarchyHint + :: Int + -> Triangulation mode vertex directed undirected face + -> Either BuildError (HierarchyHint) +buildHierarchyHint requestedBranch triangulation = + HierarchyHint branch count <$> V.mapM buildLevel levelDivisors + where + !branch = max 2 requestedBranch + !count = numVertices triangulation + levelDivisors = + V.unfoldr + (\candidate -> + case candidate of + Nothing -> Nothing + Just divisor -> + let !population = samplePopulation count divisor + next = + if population <= 1 + then Nothing + else Just (safeMultiply divisor branch) + in Just (divisor, next) + ) + (if count <= 0 then Nothing else Just branch) + + buildLevel divisor = + buildTriangulation + <$> delaunay + unitElementDefaults + ( V.generate + (samplePopulation count divisor) + (\index -> + vertexPoint + triangulation + (VertexId (fromIntegral (index * divisor))) + ) + ) + +-- | Descend from the coarsest sparse triangulation. The handle a level returns +-- is carried to the next finer level by one multiplication, and the same +-- multiplication at level 0 names the base vertex. Nothing is relocated: the +-- coarse answer is not searched for again, it is computed. +hierarchyHint :: HierarchyHint -> QueryPoint -> Maybe LocationHint +hierarchyHint HierarchyHint{hierarchyBranchFactor, hierarchyLevels} query = + VertexHint <$> descend (V.length hierarchyLevels - 1) Nothing + where + !branch = fromIntegral hierarchyBranchFactor :: Word32 + + descend !levelIndex !coarse + | levelIndex < 0 = Nothing + | otherwise = + case nearestNeighbor (hierarchyLevels V.! levelIndex) coarse query of + Nothing -> Nothing + Just (VertexId local, _) -> + let !finer = VertexId (local * branch) + in if levelIndex == 0 then Just finer else descend (levelIndex - 1) (Just finer) + + +-- | Update the nested hierarchy from an insertion's own report: the point the +-- insertion was asked for, the handle it answered, and whether it created a +-- site. Only the levels selected by the branch divisibility rule are changed. +-- Unaffected levels are structurally shared. +-- +-- No triangulation is named. The hierarchy walks its own levels and nothing +-- else, so a base was only ever a lookup table for three facts — its +-- cardinality, the stored position of the new vertex, and the position of +-- vertex zero — and every one of them is in the report or already in the +-- levels, because level-local handle zero is base handle zero at every level. +-- A caller maintaining the hierarchy across a run of insertions therefore +-- never has to publish a mesh to be allowed to speak to it, which is the whole +-- cost of the arrangement this replaces: one full arena copy per step, paid +-- only to name the thing that was just edited. +-- +-- An insertion that found its point already present created no site, and a +-- hierarchy valid for a triangulation is valid for that same triangulation, so +-- the answer is the argument, unexamined. +updateHierarchyAfterInsertion + :: HierarchyHint + -> Point + -> VertexId + -> InsertionDisposition + -> Either BuildError (HierarchyHint) +updateHierarchyAfterInsertion hierarchy requested vertex disposition = + case disposition of + AlreadyPresent -> Right hierarchy + Inserted + | vertexIndex vertex /= baseIndex -> + Left + ( HierarchyInsertionHandleMismatch + (VertexId (fromIntegral baseIndex)) + vertex + ) + | otherwise -> do + updated <- updateLevels branch (V.toList (hierarchyLevels hierarchy)) + topped <- ensureSingletonTop updated + pure + hierarchy + { hierarchyBaseCount = baseIndex + 1 + , hierarchyLevels = V.fromList topped + } + where + !branch = hierarchyBranchFactor hierarchy + !baseIndex = hierarchyBaseCount hierarchy + -- A level holds what the mesh stores, not what the caller wrote: storage + -- rounds a signed zero, and a level built from the unrounded point would + -- settle a distance tie against a different handle. + !point = canonicalPoint requested + + -- An update is the only operation that can break the nesting law, so the law + -- is stated here as an equation rather than trusted: a level admitted to the + -- new base vertex must already hold exactly @baseIndex / divisor@ samples, + -- and must receive the vertex at its end. + updateLevels !_ [] = Right [] + updateLevels !divisor levels@(level : rest) + | baseIndex `rem` divisor /= 0 = Right levels + | safeMultiply (numVertices level) divisor /= baseIndex = + Left + ( HierarchyLevelPopulationMismatch + divisor + (numVertices level) + baseIndex + ) + | otherwise = do + inserted <- insert level point + if vertexIndex (insertionVertex inserted) /= numVertices level + then + Left + ( HierarchyInsertionHandleMismatch + (VertexId (fromIntegral (numVertices level))) + (insertionVertex inserted) + ) + else (insertionTriangulation inserted :) <$> updateLevels (safeMultiply divisor branch) rest + + -- With no levels at all the base was empty, so the vertex just appended is + -- vertex zero. Otherwise vertex zero is the finest level's local vertex + -- zero, under the same law that makes the descent a multiplication. + ensureSingletonTop [] = pure <$> singletonLevel point + ensureSingletonTop levels@(finest : _) = + case reverse levels of + top : _ + | numVertices top <= 1 -> Right levels + | otherwise -> + (\first -> levels ++ [first]) + <$> singletonLevel (vertexPoint finest (VertexId 0)) + [] -> Right levels + +-- | Repair the nested hierarchy from a removal's swap report — the slot +-- compaction freed and the position of the vertex it moved into that slot, or +-- 'Nothing' when the removal took the last vertex and compaction moved +-- nothing — rather than rebuilding because removal renumbers. +-- +-- No triangulation is named, for the reason 'updateHierarchyAfterInsertion' +-- gives: the only base position this repair cannot find in its own levels is +-- the relocated vertex's, and that is what the report carries. +-- +-- Swap compaction moves exactly one vertex — the former last one, into the slot +-- the removed vertex vacated — so a level's sample sequence changes in at most +-- one place, and which place is decided by the two divisibilities the level's +-- divisor gives the freed slot and the vacated last index: +-- +-- * neither is sampled: the level, and every coarser level above it, is +-- untouched, because a divisor that divides neither index is divided by no +-- multiple of itself either; +-- * the vacated index is sampled and the freed slot is not: the level loses its +-- last sample and nothing else; +-- * both are sampled: the level loses its last sample and that sample's point +-- lands in the freed slot's local position — which is the level's own swap +-- removal, mirroring the base's; +-- * the freed slot is sampled and the vacated index is not: the level keeps its +-- population and substitutes the relocated position at an interior local +-- slot. No removal expresses a substitution, so that level is rebuilt — from +-- its own points and the reported one, never from a mesh. +-- +-- The last case is the only one that pays a build, and it is the rarest: it +-- needs the freed slot to be sampled and the vacated index not to be. +updateHierarchyAfterRemoval + :: HierarchyHint + -> Maybe (VertexId, Point) + -> Either BuildError (HierarchyHint) +updateHierarchyAfterRemoval hierarchy swap + | baseCount <= 0 = Left (RemovalEmptyTriangulation (maybe (VertexId 0) fst swap)) + | otherwise = do + repaired <- repairLevels branch (V.toList (hierarchyLevels hierarchy)) + pure + hierarchy + { hierarchyBaseCount = surviving + , hierarchyLevels = V.fromList (levelsThroughSingleton repaired) + } + where + !branch = hierarchyBranchFactor hierarchy + !baseCount = hierarchyBaseCount hierarchy + !surviving = baseCount - 1 + -- The freed slot is the removed vertex's own index, and it is where the + -- former last vertex now stands. A removal that took the last vertex frees + -- no slot and reports none, and its removed index is that last index. + !freedSlot = maybe surviving (vertexIndex . fst) swap + !vacatedIndex = surviving + + -- The nesting law is stated here as an equation for the same reason the + -- insertion path states it: a repair is the other operation that can break + -- it. A level the removal reaches must hold exactly the samples the + -- pre-removal base owed it. + repairLevels !_ [] = Right [] + repairLevels !divisor levels@(level : rest) + | not freedSampled && not vacatedSampled = Right levels + | numVertices level /= population = + Left + ( HierarchyLevelPopulationMismatch + divisor + (numVertices level) + baseCount + ) + | otherwise = + case swap of + -- The two divisibilities differ only when the two indices do, so a + -- level reaching the substitution has a relocation to substitute: + -- the guard cannot hold while compaction moved nothing. + Just (_, relocated) + | freedSampled && not vacatedSampled -> do + substituted <- substituteSample level (freedSlot `quot` divisor) relocated + (substituted :) <$> repairLevels (safeMultiply divisor branch) rest + _ -> do + shrunk <- removeVertex level (VertexId (fromIntegral localSample)) + (removalTriangulation shrunk :) <$> repairLevels (safeMultiply divisor branch) rest + where + !freedSampled = freedSlot `rem` divisor == 0 + !vacatedSampled = vacatedIndex `rem` divisor == 0 + !population = samplePopulation baseCount divisor + !localSample + | freedSampled = freedSlot `quot` divisor + | otherwise = population - 1 + + -- A build stops at the first level holding one sample, and removal only + -- shrinks populations, so the shape a rebuild would answer with is this list + -- cut after its first singleton. + levelsThroughSingleton + :: [Triangulation mode vertex directed undirected face] + -> [Triangulation mode vertex directed undirected face] + levelsThroughSingleton [] = [] + levelsThroughSingleton (level : rest) + | numVertices level <= 0 = [] + | numVertices level <= 1 = [level] + | otherwise = level : levelsThroughSingleton rest + +-- | The coarsest level a growing hierarchy needs: one sample, the base's +-- vertex zero. +singletonLevel + :: Point + -> Either BuildError (Triangulation 'Unconstrained (Point) () () ()) +singletonLevel origin = + buildTriangulation <$> delaunay unitElementDefaults (V.singleton origin) + +-- | The level a substitution asks for: the same samples in the same local +-- order, one slot carrying the relocated position instead of the one that +-- left. Stated over the level's own points, so no mesh is consulted. +substituteSample + :: Triangulation 'Unconstrained (Point) () () () + -> Int + -> Point + -> Either BuildError (Triangulation 'Unconstrained (Point) () () ()) +substituteSample level localSlot relocated = + buildTriangulation + <$> delaunay + unitElementDefaults + ( V.generate + (numVertices level) + (\index -> + if index == localSlot + then relocated + else vertexPoint level (VertexId (fromIntegral index)) + ) + ) + +-- | Rebuild a hierarchy after an operation that may renumber vertices, such as +-- removal. The branch factor remains canonical. +rebuildHierarchyHint + :: HierarchyHint + -> Triangulation mode vertex directed undirected face + -> Either BuildError (HierarchyHint) +rebuildHierarchyHint hierarchy = buildHierarchyHint (hierarchyBranchFactor hierarchy) + +-- | Remove many points, each locate starting from the hierarchy's nearest +-- sample instead of the mesh boundary. One session publishes once; the +-- hierarchy is rebuilt against the surviving mesh and returned alongside it. +removeManyWithHierarchy + :: HierarchyHint + -> Triangulation mode vertex directed undirected face + -> V.Vector (Point) + -> Either + BuildError + ( V.Vector (Maybe (RemovalOutcome vertex)) + , Triangulation mode vertex directed undirected face + , HierarchyHint + ) +removeManyWithHierarchy hierarchy triangulation points = do + queryPoints <- traverse (validatePoint Nothing) points + let guesses = fmap hierarchyGuess queryPoints + (outcomes, surviving, _) <- + withSession triangulation 0 (removeManyAtNear guesses points) + repaired <- rebuildHierarchyHint hierarchy surviving + pure (outcomes, surviving, repaired) + where + hierarchyGuess queryPoint = + case hierarchyHint hierarchy queryPoint of + Just (VertexHint vertex) -> Just vertex + _ -> Nothing + +safeMultiply :: Int -> Int -> Int +safeMultiply left right + | left > maxBound `quot` right = maxBound + | otherwise = left * right + +-- | How many samples a divisor takes from a base of this size. Sampling takes +-- index zero and every @divisor@-th index after it; the direct +-- vector generator above states the same ceiling without constructing an +-- intermediate handle list. +samplePopulation :: Int -> Int -> Int +samplePopulation count divisor + | count <= 0 = 0 + | otherwise = 1 + (count - 1) `quot` divisor + +vertexIndex :: VertexId -> Int +vertexIndex (VertexId value) = fromIntegral value + +-- The hierarchy is consulted once per query from another package, so its +-- polymorphic entries expose their unfoldings for the same reason the search +-- itself does. +-- +-- The two level constructors are listed for a second reason, and the list is +-- not complete without them: they are overloaded and the entries call them, so +-- an entry specialised in the consumer that reaches an unspecialised +-- constructor threads the dictionary right back into the build it was +-- specialised to avoid. Only a stable unfolding is a specialisation candidate +-- across a package boundary; the optimised one GHC publishes on its own is not. +-- These two were 'where' bindings before they were named, and a 'where' binding +-- is specialised with the function that encloses it — so naming them is what +-- put the dictionary in, and this is what takes it back out. 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 @@ -1,12 +1,18 @@ -- | Exact convex convolution and residual-morphology laws. module Moonlight.Triangulation.MinkowskiSpec (tests) where +import Data.List.NonEmpty (NonEmpty (..)) import Moonlight.Triangulation.AlgebraFixtures ( annulusRegion , polygonRegion , rectangleComponent , rectangleRegion ) +import Moonlight.Triangulation.Exact (ExactPoint, exactPoint) +import Moonlight.Triangulation.Internal.ExactRational + ( ExactRational + , exactRational + ) import Moonlight.Triangulation.Minkowski ( MinkowskiOperation (..) , closeWith @@ -40,6 +46,7 @@ tests = do testConvexConvolution testGeneralAddition + testOffsetClosure testConvexMorphology testGeneralErosion testHoledAndNeckedErosion @@ -111,6 +118,57 @@ if minkowskiOverlayPasses concaveReceipt > 0 then pure () else fail "nonconvex addition bypassed CDT decomposition and overlay union" + +-- Dilation must be closed over its own exact published image. This fixture +-- used to admit the first offset and then refuse the second when rounded +-- resident wedges were mistaken for exact two-cells. +testOffsetClosure :: IO () +testOffsetClosure = do + source <- + polygonRegion + [ (-9, -1) + , (-5, -6) + , (0, -13) + , (7, -9) + , (9, 1) + , (10, 10) + , (5, 12) + , (-7, 8) + ] + shoulder <- + requireRight + "unit octagon shoulder" + (exactRational 1592262918131443 2251799813685248) + kernel <- + requireRight + "unit octagon kernel" + (convexPolygon (centeredOctagon 1 shoulder)) + element <- requireRight "unit octagon element" (structuringElement kernel) + (firstOffset, _) <- + requireRight "first closure-regression offset" (polygonOffset element source) + (secondOffset, secondReceipt) <- + requireRight + "offset remains closed over its own published image" + (polygonOffset element firstOffset) + assertEqual + "offset-of-offset remains one full-dimensional component" + 1 + (length (planarRegionComponents secondOffset)) + if minkowskiOverlayPasses secondReceipt > 0 + then pure () + else fail "offset closure regression did not exercise overlay descent" + +centeredOctagon :: ExactRational -> ExactRational -> NonEmpty ExactPoint +centeredOctagon radius shoulder = + exactPoint radius 0 + :| [ exactPoint shoulder shoulder + , exactPoint 0 radius + , exactPoint (-shoulder) shoulder + , exactPoint (-radius) 0 + , exactPoint (-shoulder) (-shoulder) + , exactPoint 0 (-radius) + , exactPoint shoulder (-shoulder) + ] testConvexMorphology :: IO () testConvexMorphology = do diff --git a/test/cell-complex/Main.hs b/test/cell-complex/Main.hs new file mode 100644 --- /dev/null +++ b/test/cell-complex/Main.hs @@ -0,0 +1,95 @@ +module Main (main) where + +import Data.Foldable (traverse_) +import Data.Vector qualified as Vector +import Moonlight.Triangulation.CellComplex (DCELComplex, fromExactCellSet) +import Moonlight.Homology.Pure.Topology.CellComplex + ( CellComplex2D (..), + CellTypes (..), + OrientedEdge (..), + ValidateComplex2D (..), + eulerCharacteristic, + isBoundaryEdge, + ) +import Moonlight.Triangulation.BulkLoad (delaunayGeometry) +import Moonlight.Triangulation.CellSet + ( ExactCellSet, + closeFaceCellSet, + exactCellSetEdgeCount, + exactCellSetFaceCount, + exactCellSetVertexCount, + ) +import Moonlight.Triangulation.Handles.Iterators.FixedIterators (innerFaces) +import Moonlight.Triangulation.Types (Point (..)) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit ((@?=), Assertion, assertBool, assertFailure, testCase) + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "ExactCellSet bridge" + [ testCase "preserves the admitted cell inventory" preserveCellInventory, + testCase "preserves downward-closed incidence" preserveClosedIncidence, + testCase "marks the triangular exterior as absent" preserveExteriorAdjacency + ] + +preserveCellInventory :: Assertion +preserveCellInventory = + withTriangleComplex $ \cellSet complexValue -> do + length (vertices complexValue) @?= exactCellSetVertexCount cellSet + length (edges complexValue) @?= exactCellSetEdgeCount cellSet + length (faces complexValue) @?= exactCellSetFaceCount cellSet + (length (vertices complexValue), length (edges complexValue), length (faces complexValue)) + @?= (3, 3, 1) + eulerCharacteristic complexValue @?= 1 + validateComplex complexValue @?= [] + +preserveClosedIncidence :: Assertion +preserveClosedIncidence = + withTriangleComplex $ \_ complexValue -> do + traverse_ (assertSelectedEdgeEndpoints complexValue) (edges complexValue) + traverse_ (assertSelectedFaceBoundary complexValue) (faces complexValue) + fmap (length . edgesAtVertex complexValue) (vertices complexValue) @?= [2, 2, 2] + +preserveExteriorAdjacency :: Assertion +preserveExteriorAdjacency = + withTriangleComplex $ \_ complexValue -> + assertBool + "every edge of a single selected triangle has one exterior incident face" + (all (isBoundaryEdge complexValue) (edges complexValue)) + +assertSelectedEdgeEndpoints :: DCELComplex -> Edge DCELComplex -> Assertion +assertSelectedEdgeEndpoints complexValue edgeValue = do + let selectedVertices = vertices complexValue + (sourceVertex, targetVertex) = edgeBoundary complexValue edgeValue + assertBool "edge source is selected" (sourceVertex `elem` selectedVertices) + assertBool "edge target is selected" (targetVertex `elem` selectedVertices) + +assertSelectedFaceBoundary :: DCELComplex -> Face DCELComplex -> Assertion +assertSelectedFaceBoundary complexValue faceValue = do + let selectedEdges = edges complexValue + boundary = faceBoundary complexValue faceValue + length boundary @?= 3 + assertBool + "every oriented boundary edge is selected" + (all ((`elem` selectedEdges) . orientedEdge) boundary) + +withTriangleComplex :: (ExactCellSet -> DCELComplex -> Assertion) -> Assertion +withTriangleComplex assertion = + case delaunayGeometry trianglePoints of + Left buildFailure -> assertFailure ("triangle construction failed: " <> show buildFailure) + Right triangulation -> + case closeFaceCellSet triangulation (innerFaces triangulation) of + Left selectionFailure -> assertFailure ("triangle selection failed: " <> show selectionFailure) + Right cellSet -> assertion cellSet (fromExactCellSet cellSet) + +trianglePoints :: Vector.Vector Point +trianglePoints = + Vector.fromList + [ Point 0 0, + Point 2 0, + Point 0 2 + ] diff --git a/test/ffi/Main.hs b/test/ffi/Main.hs --- a/test/ffi/Main.hs +++ b/test/ffi/Main.hs @@ -2,7 +2,9 @@ import Control.Exception (bracket) import Control.Monad (unless) +import Data.Int (Int64) import Data.Word (Word32) +import Foreign.C.String (peekCString) import Foreign.C.Types (CDouble (..), CSize (..), CUInt) import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Array (allocaArray, peekArray, withArray) @@ -10,34 +12,49 @@ import Foreign.Storable (Storable (sizeOf), peek) import Moonlight.Triangulation.Foreign.ABI -type MeshPointer = Ptr () +type MeshPointer = Ptr CMesh +type RegionPointer = Ptr CRegion +type Point = (Double, Double) +type Loop = [Point] +data ComponentInput = ComponentInput !Loop ![Loop] +data RegionMeasurement = RegionMeasurement + { measuredEuler :: !Int64 + , measuredArea :: !String + , measuredPerimeterLower :: !Double + , measuredPerimeterUpper :: !Double + } + main :: IO () main = do - unless (sizeOf (undefined :: CObstruction) == 320) $ + unless (sizeOf obstructionLayoutWitness == 320) $ fail "C obstruction layout changed" + unless (sizeOf receiptLayoutWitness == 72) $ + fail "C Minkowski receipt layout changed" bracket (buildMesh [(0, 0), (2, 0), (0, 2), (2, 2)]) meshFree $ \left -> bracket (buildMesh [(2, 0), (4, 0), (2, 2), (4, 2)]) meshFree $ \right -> do requireMeshCount "left vertex count" meshVertexCount left 4 requireMeshCount "left triangle count" meshTriangleCount left 2 testDenseCopies left testImmutableBatch left - testBinaryAlgebra left right + testSiteSetAlgebra left right + testExactRegionSurface testTypedCoordinateRefusal testCoordinateCountOverflow testNullPointerRefusal + testRegionLayoutRefusal putStrLn "ffi: ok" -buildMesh :: [(Double, Double)] -> IO MeshPointer +obstructionLayoutWitness :: CObstruction +obstructionLayoutWitness = CObstruction 0 0 0 0 0 0 0 0 0 "" + +receiptLayoutWitness :: CMinkowskiReceipt +receiptLayoutWitness = CMinkowskiReceipt 0 0 0 0 0 0 0 0 0 + +buildMesh :: [Point] -> IO MeshPointer buildMesh points = withPointArray points $ \coordinates -> - alloca $ \output -> - alloca $ \obstruction -> do - status <- delaunayF64 coordinates (fromIntegral (length points)) output obstruction - requireStatus "delaunay" 0 status obstruction - handle <- peek output - unless (handle /= nullPtr) (fail "delaunay returned a null handle") - pure handle + produceHandle "delaunay" (delaunayF64 coordinates (fromIntegral (length points))) testDenseCopies :: MeshPointer -> IO () testDenseCopies mesh = do @@ -68,24 +85,195 @@ testImmutableBatch original = withPointArray [(1, 1), (3, 1)] $ \coordinates -> bracket - (produceMesh "batch insert" (meshInsertManyF64 original coordinates 2)) + (produceHandle "batch insert" (meshInsertManyF64 original coordinates 2)) meshFree (\revised -> do requireMeshCount "original after batch" meshVertexCount original 4 - requireMeshCount "revised after batch" meshVertexCount revised 6 - ) + requireMeshCount "revised after batch" meshVertexCount revised 6) -testBinaryAlgebra :: MeshPointer -> MeshPointer -> IO () -testBinaryAlgebra left right = do - test "union" meshUnion 6 - test "intersection" meshIntersection 2 - test "difference" meshDifference 2 - test "symmetric difference" meshSymmetricDifference 4 +testSiteSetAlgebra :: MeshPointer -> MeshPointer -> IO () +testSiteSetAlgebra left right = do + test "site union" meshSiteUnion 6 + test "site intersection" meshSiteIntersection 2 + test "site difference" meshSiteDifference 2 + test "site symmetric difference" meshSiteSymmetricDifference 4 where test label operation expected = - bracket (produceMesh label (operation left right)) meshFree $ \result -> + bracket (produceHandle label (operation left right)) meshFree $ \result -> requireMeshCount label meshVertexCount result expected +testExactRegionSurface :: IO () +testExactRegionSurface = + bracket (buildRegion [ComponentInput leftSquare []]) regionFree $ \left -> + bracket (buildRegion [ComponentInput rightSquare []]) regionFree $ \right -> do + testRegionProjection left + testRegionBooleans left right + testRegionPointLocation left + testRegionMorphology left right + where + leftSquare = [(0, 0), (2, 0), (2, 2), (0, 2)] + rightSquare = [(1, 0), (3, 0), (3, 2), (1, 2)] + +testRegionProjection :: RegionPointer -> IO () +testRegionProjection region = + alloca $ \componentCountOutput -> + alloca $ \loopCountOutput -> + alloca $ \pointCountOutput -> + alloca $ \obstruction -> do + status <- regionCounts region componentCountOutput loopCountOutput pointCountOutput obstruction + requireStatus "region counts" 0 status obstruction + componentCount <- fromIntegral <$> peek componentCountOutput + loopCount <- fromIntegral <$> peek loopCountOutput + pointCount <- fromIntegral <$> peek pointCountOutput + unless ((componentCount, loopCount, pointCount) == (1, 1, 4)) $ + fail "region counts lost component/loop/point structure" + allocaArray (pointCount * 2) $ \coordinates -> + allocaArray (loopCount + 1) $ \loopOffsets -> + allocaArray (componentCount + 1) $ \componentOffsets -> do + copyStatus <- + regionCopyF64 + region + coordinates + (fromIntegral pointCount) + loopOffsets + (fromIntegral (loopCount + 1)) + componentOffsets + (fromIntegral (componentCount + 1)) + obstruction + requireStatus "region copy" 0 copyStatus obstruction + copiedLoopOffsets <- peekArray (loopCount + 1) loopOffsets + copiedComponentOffsets <- peekArray (componentCount + 1) componentOffsets + unless (copiedLoopOffsets == [0, 4] && copiedComponentOffsets == [0, 1]) $ + fail "region copy changed the bulk offset topology" + +testRegionBooleans :: RegionPointer -> RegionPointer -> IO () +testRegionBooleans left right = do + test "region union" regionUnion 1 "6/1" 10 + test "region intersection" regionIntersection 1 "2/1" 6 + test "region difference" regionDifference 1 "2/1" 6 + test "region symmetric difference" regionSymmetricDifference 2 "4/1" 12 + where + test label operation expectedEuler expectedArea expectedPerimeter = + bracket (produceHandle label (operation left right)) regionFree $ \result -> do + measurement <- measureRegion result + unless (measuredEuler measurement == expectedEuler && measuredArea measurement == expectedArea) $ + fail (label <> " returned the wrong exact valuation") + requireCertifiedContainment + label + expectedPerimeter + (measuredPerimeterLower measurement) + (measuredPerimeterUpper measurement) + +testRegionPointLocation :: RegionPointer -> IO () +testRegionPointLocation region = do + requireRegionLocation "interior location" region (1, 1) 2 + requireRegionLocation "boundary location" region (0, 1) 1 + requireRegionLocation "exterior location" region (3, 1) 0 + +testRegionMorphology :: RegionPointer -> RegionPointer -> IO () +testRegionMorphology left right = + withPointArray [(-0.5, -0.5), (0.5, -0.5), (0.5, 0.5), (-0.5, 0.5)] $ \coordinates -> + bracket + (produceHandle "structuring element" (structuringElementCreateF64 coordinates 4)) + structuringElementFree + (\element -> do + test "Minkowski sum" regionMinkowskiSum left right 0 "16/1" + test "offset" regionOffset element left 0 "9/1" + test "inset" regionInset element left 1 "1/1" + test "open" regionOpen element left 2 "4/1" + test "close" regionClose element left 3 "4/1") + where + test + :: String + -> (first -> RegionPointer -> Ptr RegionPointer -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt) + -> first + -> RegionPointer + -> Word32 + -> String + -> IO () + test label operation firstInput secondInput expectedOperation expectedArea = + bracket + (produceRegionWithReceipt label (operation firstInput secondInput)) + (regionFree . fst) + (\(result, receipt) -> do + measurement <- measureRegion result + unless (receiptOperation receipt == expectedOperation && measuredArea measurement == expectedArea) $ + fail (label <> " lost its result or morphology receipt")) + +measureRegion :: RegionPointer -> IO RegionMeasurement +measureRegion region = + alloca $ \eulerOutput -> + allocaArray 64 $ \areaOutput -> + alloca $ \areaBytesWritten -> + alloca $ \perimeterLowerOutput -> + alloca $ \perimeterUpperOutput -> + alloca $ \obstruction -> do + status <- + regionMeasure + region + eulerOutput + areaOutput + 64 + areaBytesWritten + perimeterLowerOutput + perimeterUpperOutput + obstruction + requireStatus "region measure" 0 status obstruction + measuredEuler <- peek eulerOutput + measuredArea <- peekCString areaOutput + CDouble measuredPerimeterLower <- peek perimeterLowerOutput + CDouble measuredPerimeterUpper <- peek perimeterUpperOutput + pure (RegionMeasurement measuredEuler measuredArea measuredPerimeterLower measuredPerimeterUpper) + +requireCertifiedContainment :: String -> Double -> Double -> Double -> IO () +requireCertifiedContainment label expected lower upper = + unless (lower <= expected && expected <= upper) $ + fail (label <> " perimeter certificate excludes the exact perimeter") + +requireRegionLocation :: String -> RegionPointer -> Point -> CUInt -> IO () +requireRegionLocation label region (x, y) expected = + alloca $ \output -> + alloca $ \obstruction -> do + status <- regionLocatePointF64 region (CDouble x) (CDouble y) output obstruction + requireStatus label 0 status obstruction + observed <- peek output + unless (observed == expected) $ + fail (label <> " returned location " <> show observed) + +buildRegion :: [ComponentInput] -> IO RegionPointer +buildRegion components = + let loopsByComponent = map (\(ComponentInput outer holes) -> outer : holes) components + loops = concat loopsByComponent + points = concat loops + loopPointCounts = map length loops + componentLoopCounts = map length loopsByComponent + in withPointArray points $ \coordinates -> + withArray (map fromIntegral loopPointCounts) $ \loopCounts -> + withArray (map fromIntegral componentLoopCounts) $ \componentCounts -> + produceHandle + "region create" + ( regionCreateF64 + coordinates + (fromIntegral (length points)) + loopCounts + (fromIntegral (length loops)) + componentCounts + (fromIntegral (length components)) + ) + +testRegionLayoutRefusal :: IO () +testRegionLayoutRefusal = + withPointArray [(0, 0), (1, 0), (1, 1), (0, 1)] $ \coordinates -> + withArray [5] $ \loopCounts -> + withArray [1] $ \componentCounts -> + alloca $ \output -> + alloca $ \obstruction -> do + status <- regionCreateF64 coordinates 4 loopCounts 1 componentCounts 1 output obstruction + requireStatus "invalid region layout" 4 status obstruction + refusal <- peek obstruction + unless (obstructionCode refusal == 200) $ + fail "invalid region layout lost its typed obstruction" + testTypedCoordinateRefusal :: IO () testTypedCoordinateRefusal = withPointArray [(0, 0), (0 / 0, 1), (1, 0)] $ \coordinates -> @@ -128,8 +316,8 @@ unless (observed == fromIntegral expected) $ fail (label <> " produced " <> show observed <> ", expected " <> show expected) -produceMesh :: String -> (Ptr MeshPointer -> Ptr CObstruction -> IO CUInt) -> IO MeshPointer -produceMesh label operation = +produceHandle :: String -> (Ptr (Ptr carrier) -> Ptr CObstruction -> IO CUInt) -> IO (Ptr carrier) +produceHandle label operation = alloca $ \output -> alloca $ \obstruction -> do status <- operation output obstruction @@ -138,6 +326,21 @@ unless (handle /= nullPtr) (fail (label <> " returned a null handle")) pure handle +produceRegionWithReceipt + :: String + -> (Ptr RegionPointer -> Ptr CMinkowskiReceipt -> Ptr CObstruction -> IO CUInt) + -> IO (RegionPointer, CMinkowskiReceipt) +produceRegionWithReceipt label operation = + alloca $ \output -> + alloca $ \receiptOutput -> + alloca $ \obstruction -> do + status <- operation output receiptOutput obstruction + requireStatus label 0 status obstruction + handle <- peek output + receipt <- peek receiptOutput + unless (handle /= nullPtr) (fail (label <> " returned a null region")) + pure (handle, receipt) + requireStatus :: String -> CUInt -> CUInt -> Ptr CObstruction -> IO () requireStatus label expected observed obstruction | observed == expected = pure () @@ -145,5 +348,5 @@ refusal <- peek obstruction fail (label <> " returned status " <> show observed <> ": " <> obstructionMessage refusal) -withPointArray :: [(Double, Double)] -> (Ptr CDouble -> IO result) -> IO result +withPointArray :: [Point] -> (Ptr CDouble -> IO result) -> IO result withPointArray points = withArray (concatMap (\(x, y) -> [CDouble x, CDouble y]) points) 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 @@ -38,10 +38,10 @@ ) import Moonlight.Triangulation.Internal.Overlay.Embedding ( DraftIncidence (..) + , DraftId (..) , DraftNeighborhood (..) - , DraftSegmentId (..) - , DraftSourceId (..) - , DraftVertexId (..) + , DraftSegmentId + , DraftVertexId , EmbeddingObligation (..) , ExactArrangementDraft (..) , LocalEmbeddingCertificate (..) @@ -75,6 +75,7 @@ , testExactArithmeticReceipt , testEmbeddingAdmissionReceipt , testOrdinaryDraftCertificate + , testCollinearNeighborhoodRotation , testFrozenBinary64RelationOracle ] @@ -124,9 +125,9 @@ emptyDraft { draftVertices = Map.fromList - [ (DraftVertexId 0, firstCrossing) - , (DraftVertexId 1, secondCrossing) - , (DraftVertexId 2, thirdCrossing) + [ (DraftId 0, firstCrossing) + , (DraftId 1, secondCrossing) + , (DraftId 2, thirdCrossing) ] } assertLeftContains @@ -150,21 +151,22 @@ outerTo = exactPoint zero upper innerFrom = exactPoint zero innerLower innerTo = exactPoint zero innerUpper - outerSegmentId = DraftSegmentId 0 - innerSegmentId = DraftSegmentId 1 + outerSegmentId, innerSegmentId :: DraftSegmentId + outerSegmentId = DraftId 0 + innerSegmentId = DraftId 1 draft = emptyDraft { draftVertices = Map.fromList - [ (DraftVertexId 0, outerFrom) - , (DraftVertexId 1, outerTo) - , (DraftVertexId 2, innerFrom) - , (DraftVertexId 3, innerTo) + [ (DraftId 0, outerFrom) + , (DraftId 1, outerTo) + , (DraftId 2, innerFrom) + , (DraftId 3, innerTo) ] , draftSegments = Map.fromList - [ (outerSegmentId, (DraftVertexId 0, DraftVertexId 1)) - , (innerSegmentId, (DraftVertexId 2, DraftVertexId 3)) + [ (outerSegmentId, (DraftId 0, DraftId 1)) + , (innerSegmentId, (DraftId 2, DraftId 3)) ] , draftIncidences = [ DraftIncidence @@ -219,7 +221,7 @@ unprojectableDraft = emptyDraft { draftVertices = - Map.singleton (DraftVertexId 0) unprojectablePoint + Map.singleton (DraftId 0) unprojectablePoint } assertLeftContains "unprojectable exact draft vertex" @@ -248,15 +250,17 @@ testOrdinaryDraftCertificate :: IO () testOrdinaryDraftCertificate = do half <- requireRight "ordinary draft half parameter" (exactRational 1 2) - let west = DraftVertexId 0 - center = DraftVertexId 1 - east = DraftVertexId 2 - south = DraftVertexId 3 - north = DraftVertexId 4 - westCenter = DraftSegmentId 0 - centerEast = DraftSegmentId 1 - southCenter = DraftSegmentId 2 - centerNorth = DraftSegmentId 3 + let west, center, east, south, north :: DraftVertexId + west = DraftId 0 + center = DraftId 1 + east = DraftId 2 + south = DraftId 3 + north = DraftId 4 + westCenter, centerEast, southCenter, centerNorth :: DraftSegmentId + westCenter = DraftId 0 + centerEast = DraftId 1 + southCenter = DraftId 2 + centerNorth = DraftId 3 draft = ExactArrangementDraft { draftVertices = @@ -276,13 +280,13 @@ ] , draftSourceMemberships = Map.fromList - [ ( DraftSourceId 0 + [ ( DraftId 0 , [ (0, west) , (half, center) , (1, east) ] ) - , ( DraftSourceId 1 + , ( DraftId 1 , [ (0, south) , (half, center) , (1, north) @@ -312,7 +316,7 @@ assertEqual "ordinary neighborhood obligations" 4 - (certificateNeighborhoodOrientationStabilityCount certificate) + (certificateNeighborhoodRotationPreservationCount certificate) assertEqual "ordinary residual" (GlobalNoNewCrossing :| []) @@ -323,7 +327,7 @@ ( certificateRoundedVertexDistinctnessCount certificate , certificateSplitOrderPreservationCount certificate , certificateIncidenceRelationPreservationCount certificate - , certificateNeighborhoodOrientationStabilityCount certificate + , certificateNeighborhoodRotationPreservationCount certificate ) ) putStrLn @@ -331,6 +335,54 @@ <> show (residualUndischargedObligations (certificateResidual certificate)) ) +-- Independent binary64 projection bends the exact straight-through pair at +-- the center, but the cyclic neighbor order is unchanged. The local topology +-- obligation is rotation preservation, not literal preservation of a zero +-- determinant. +testCollinearNeighborhoodRotation :: IO () +testCollinearNeighborhoodRotation = do + oneThird <- requireRight "collinear rotation coordinate" (exactRational 1 3) + let center, right, branch, left :: DraftVertexId + center = DraftId 0 + right = DraftId 1 + branch = DraftId 2 + left = DraftId 3 + centerRight, centerBranch, centerLeft :: DraftSegmentId + centerRight = DraftId 0 + centerBranch = DraftId 1 + centerLeft = DraftId 2 + draft = + emptyDraft + { draftVertices = + Map.fromList + [ (center, exactPoint 1 oneThird) + , (right, integerPoint 3 1) + , (branch, integerPoint 1 2) + , (left, integerPoint 0 0) + ] + , draftSegments = + Map.fromList + [ (centerRight, (center, right)) + , (centerBranch, (center, branch)) + , (centerLeft, (center, left)) + ] + , draftIncidences = + [ DraftIncidence centerRight centerBranch SegmentsShareEndpoint + , DraftIncidence centerBranch centerLeft SegmentsShareEndpoint + , DraftIncidence centerLeft centerRight SegmentsShareEndpoint + ] + , draftNeighborhoods = + [DraftNeighborhood center (right :| [branch, left])] + } + certificate <- + requireRight + "collinear neighborhood retains its cyclic rotation" + (certifyLocalEmbedding draft) + assertEqual + "collinear neighborhood rotation obligations" + 3 + (certificateNeighborhoodRotationPreservationCount certificate) + testExactArithmeticReceipt :: IO () testExactArithmeticReceipt = do enabled <- getRTSStatsEnabled @@ -386,23 +438,23 @@ emptyDraft { draftVertices = Map.fromList - [ (DraftVertexId 0, integerPoint 0 0) - , (DraftVertexId 1, integerPoint 1 0) + [ (DraftId 0, integerPoint 0 0) + , (DraftId 1, integerPoint 1 0) ] } collisionDraft = emptyDraft { draftVertices = Map.fromList - [ (DraftVertexId 0, exactPoint firstCollision 0) - , (DraftVertexId 1, exactPoint secondCollision 0) + [ (DraftId 0, exactPoint firstCollision 0) + , (DraftId 1, exactPoint secondCollision 0) ] } projectionDraft = emptyDraft { draftVertices = Map.singleton - (DraftVertexId 0) + (DraftId 0) (exactPoint (fromInteger (10 ^ (400 :: Int))) 0) } outcomes = diff --git a/test/native/Moonlight/Triangulation/NativeSpec.hs b/test/native/Moonlight/Triangulation/NativeSpec.hs --- a/test/native/Moonlight/Triangulation/NativeSpec.hs +++ b/test/native/Moonlight/Triangulation/NativeSpec.hs @@ -36,7 +36,8 @@ import Moonlight.Triangulation.Dcel import qualified Moonlight.Triangulation.Dcel as Dcel import Moonlight.Triangulation.FloodFillIterator -import Moonlight.Triangulation.Handles +import Moonlight.Triangulation.Handles.HandleDefs +import Moonlight.Triangulation.Handles.Iterators.FixedIterators import Moonlight.Triangulation.HintGenerator import Moonlight.Triangulation.Interpolation import Moonlight.Triangulation.IntersectionIterator @@ -1679,7 +1680,7 @@ ) split <- requireRight "constraint split" (addConstraintAndSplit id cdt1 (VertexId 1) (VertexId 3)) - let splitCdt = constraintTriangulation split + let splitCdt = constraintRecoveryTriangulation split unless (numVertices splitCdt > numVertices cdt1) $ fail "constraint split did not insert an intersection vertex" assertCdtValid "constraint split" splitCdt @@ -1704,9 +1705,10 @@ requireRight "split band base" (constrainedDelaunayMaximal unitElementDefaults bandVertices V.empty) - let bandMapping = cdtBuildInputVertices bandBuild + let bandAcceptedBuild = cdtAcceptedBuild bandBuild + bandMapping = buildInputVertices bandAcceptedBuild bandHandle input = VertexId (indexPrimArray bandMapping input) - bandBase = cdtBuildTriangulation bandBuild + bandBase = buildTriangulation bandAcceptedBuild bandRequests = V.fromList ( (bandHandle 0, bandHandle 1) @@ -1719,7 +1721,7 @@ -> (VertexId, VertexId) -> Either (CdtError) (ConstrainedDelaunayTriangulation (Point)) replaySplit triangulation request = - constraintTriangulation + constraintRecoveryTriangulation <$> uncurry (addConstraintAndSplit id triangulation) request bandBatch <- requireRight @@ -1732,12 +1734,12 @@ assertEqual "split batch topology equals singleton descent" bandDescent - (splitBatchTriangulation bandBatch) + (constraintRecoveryTriangulation bandBatch) assertEqual "split batch added one vertex per crossing" (numVertices bandBase + length bandColumns) - (numVertices (splitBatchTriangulation bandBatch)) - assertCdtValid "split batch" (splitBatchTriangulation bandBatch) + (numVertices (constraintRecoveryTriangulation bandBatch)) + assertCdtValid "split batch" (constraintRecoveryTriangulation bandBatch) -- The same law with the reservation exhausting inside one corridor rather -- than between corridors: the closing horizontal crosses two constraints @@ -1760,9 +1762,10 @@ requireRight "split lace base" (constrainedDelaunayMaximal unitElementDefaults laceVertices laceBuiltIn) - let laceMapping = cdtBuildInputVertices laceBuild + let laceAcceptedBuild = cdtAcceptedBuild laceBuild + laceMapping = buildInputVertices laceAcceptedBuild laceHandle input = VertexId (indexPrimArray laceMapping input) - laceBase = cdtBuildTriangulation laceBuild + laceBase = buildTriangulation laceAcceptedBuild laceRequests = V.fromList ( [ (laceHandle (2 * column + 2), laceHandle (2 * column + 3)) @@ -1781,22 +1784,23 @@ assertEqual "split lace batch topology equals singleton descent" laceDescent - (splitBatchTriangulation laceBatch) + (constraintRecoveryTriangulation laceBatch) assertEqual "split lace batch added one vertex per crossing" (numVertices laceBase + length laceColumns) - (numVertices (splitBatchTriangulation laceBatch)) - assertCdtValid "split lace batch" (splitBatchTriangulation laceBatch) + (numVertices (constraintRecoveryTriangulation laceBatch)) + assertCdtValid "split lace batch" (constraintRecoveryTriangulation laceBatch) let verticesInput :: V.Vector (Point) verticesInput = V.fromList [Point 0 0, Point 4 0, Point 4 4, Point 0 4, Point 0 0] constraintsInput = V.fromList [(0, 2), (1, 3), (4, 1)] bulk <- requireRight "stable CDT bulk load" (constrainedDelaunayMaximal unitElementDefaults verticesInput constraintsInput) - let bulkMapping = cdtBuildInputVertices bulk - unless (sizeofPrimArray bulkMapping > 4) $ fail "cdtBuildInputVertices out of bounds" + let bulkAcceptedBuild = cdtAcceptedBuild bulk + bulkMapping = buildInputVertices bulkAcceptedBuild + unless (sizeofPrimArray bulkMapping > 4) $ fail "buildInputVertices out of bounds" assertEqual "stable duplicate reroute" (VertexId (indexPrimArray bulkMapping 0)) (VertexId (indexPrimArray bulkMapping 4)) assertEqual "conflict reporting" 1 (V.length (cdtRejectedConstraints bulk)) - assertCdtValid "stable CDT bulk load" (cdtBuildTriangulation bulk) + assertCdtValid "stable CDT bulk load" (buildTriangulation bulkAcceptedBuild) testAnnotatedConstrainedUnion :: IO () testAnnotatedConstrainedUnion = do @@ -1954,8 +1958,9 @@ requireRight "asymmetric constrained extension" (extendConstrainedWith Set.union base extension) - let extended = constrainedExtensionTriangulation extendedResult - receipt = constrainedExtensionConstraintStats extendedResult + let constraintBatch = constrainedExtensionConstraintBatch extendedResult + extended = constraintBatchTriangulation constraintBatch + receipt = constraintBatchStats constraintBatch buildReceipt = constrainedExtensionBuildStats extendedResult actualAnnotations = Map.fromList @@ -2001,7 +2006,7 @@ assertEqual "asymmetric extension returns one outcome for each incoming constraint" (V.length (constraintSegments extension)) - (V.length (constrainedExtensionConstraintOutcomes extendedResult)) + (V.length (constraintBatchOutcomes constraintBatch)) assertEqual "asymmetric extension admits every incoming constraint" (V.length (constraintSegments extension)) @@ -2109,7 +2114,8 @@ requireRight "large asymmetric constrained extension" (extendConstrainedWith Set.union base extension) - let extended = constrainedExtensionTriangulation extensionResult + let constraintBatch = constrainedExtensionConstraintBatch extensionResult + extended = constraintBatchTriangulation constraintBatch extendedConstraints = Set.fromList (V.toList (constraintSegments extended)) extendedVertexSnapshot = Map.fromList @@ -2147,7 +2153,7 @@ assertEqual "large asymmetric extension replays only the incoming constraints" (V.length extensionConstraints) - (constraintBatchRequests (constrainedExtensionConstraintStats extensionResult)) + (constraintBatchRequests (constraintBatchStats constraintBatch)) assertCdtValid "large asymmetric constrained extension" extended case extendConstrainedWith Set.union base conflicting of Left (ConstraintUnionConstructionFailed (ConstraintIntersection _)) -> pure () @@ -2703,11 +2709,23 @@ "component provenance mismatch is typed before DCEL lookup" (Left (BoundaryComponentFaceOutOfRange (FaceId 2) 2)) (componentBoundary triangle squareComponent) + assertEqual + "component loop provenance mismatch is typed before DCEL lookup" + (Left (BoundaryComponentFaceOutOfRange (FaceId 2) 2)) + (componentBoundaryLoops triangle squareComponent) squareBoundary <- requireRight "uniform square boundary" (componentBoundary square squareComponent) + squareLoops <- + requireRight + "uniform square oriented boundary loops" + (componentBoundaryLoops square squareComponent) repeatedSquareBoundary <- requireRight "repeated uniform square boundary" (componentBoundary square squareComponent) assertEqual "boundary extraction is deterministic" squareBoundary repeatedSquareBoundary assertEqual + "ordinary oriented loops agree with strict boundary" + (regionBoundaryOuterLoop squareBoundary :| regionBoundaryHoleLoops squareBoundary) + squareLoops + assertEqual "uniform square drops its Delaunay diagonal" (Set.fromList [Point 0 0, Point 2 0, Point 2 2, Point 0 2]) (loopPointSet square (regionBoundaryOuterLoop squareBoundary)) @@ -2794,6 +2812,35 @@ "pinched selected component" True (faceComponents pinched pinchedSelection) + pinchedLoops <- + requireRight + "pinched oriented boundary loops" + (componentBoundaryLoops pinched pinchedComponent) + let pinchedLoopList = toList pinchedLoops + assertEqual "pinched simple loop count" 2 (length pinchedLoopList) + assertEqual + "pinched simple loop vertex counts" + [4, 6] + (sort (fmap (length . boundaryLoopVertices) pinchedLoopList)) + assertEqual + "pinched loop orientations" + [BoundaryCounterClockwise, BoundaryClockwise] + (sort (fmap boundaryLoopOrientation pinchedLoopList)) + traverse_ + (\loop -> do + let loopVertexIds = toList (boundaryLoopVertices loop) + assertEqual + "pinched loop has no repeated vertex" + (length loopVertexIds) + (Set.size (Set.fromList loopVertexIds)) + assertLoopWinding + "pinched loop winding agrees with orientation" + (case boundaryLoopOrientation loop of + BoundaryCounterClockwise -> GT + BoundaryClockwise -> LT) + pinched + loop) + pinchedLoopList case componentBoundary pinched pinchedComponent of Left (BoundaryPinch vertex firstEdge secondEdge) -> do assertEqual "pinch vertex" (Point 1 1) (vertexPoint pinched vertex) @@ -3000,6 +3047,10 @@ -> RegionBoundary -> IO () assertBoundaryShape label triangulation outerVertexCount holeVertexCounts boundary = do + assertEqual + (label <> " outer orientation") + BoundaryCounterClockwise + (boundaryLoopOrientation (regionBoundaryOuterLoop boundary)) assertEqual (label <> " outer vertex count") outerVertexCount (length (boundaryLoopVertices (regionBoundaryOuterLoop boundary))) assertLoopWinding (label <> " outer winding") GT triangulation @@ -3008,6 +3059,10 @@ assertEqual (label <> " hole count") (length holeVertexCounts) (length holes) traverse_ (\(vertexCount, hole) -> do + assertEqual + (label <> " hole orientation") + BoundaryClockwise + (boundaryLoopOrientation hole) assertEqual (label <> " hole vertex count") vertexCount (length (boundaryLoopVertices hole)) assertLoopWinding (label <> " hole winding") LT triangulation hole) diff --git a/weeder.toml b/weeder.toml --- a/weeder.toml +++ b/weeder.toml @@ -13,16 +13,15 @@ '^Moonlight\.Triangulation\.Math$', '^Moonlight\.Triangulation\.Exact$', '^Moonlight\.Triangulation\.CellSet$', + '^Moonlight\.Triangulation\.CellComplex$', '^Moonlight\.Triangulation\.Region$', '^Moonlight\.Triangulation\.Valuation$', '^Moonlight\.Triangulation\.Interop$', '^Moonlight\.Triangulation\.Dcel$', '^Moonlight\.Triangulation\.Payload$', '^Moonlight\.Triangulation\.JoinSemilattice$', - '^Moonlight\.Triangulation\.Handles$', '^Moonlight\.Triangulation\.Handles\.HandleDefs$', '^Moonlight\.Triangulation\.Handles\.Dynamic$', - '^Moonlight\.Triangulation\.Handles\.Iterators$', '^Moonlight\.Triangulation\.Handles\.Iterators\.CircularIterator$', '^Moonlight\.Triangulation\.Handles\.Iterators\.DynamicIterators$', '^Moonlight\.Triangulation\.Handles\.Iterators\.FixedIterators$',